aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorJan Tuomi <jan.tuomi@valuemotive.com>2022-09-25 16:51:54 +0300
committerJan Tuomi <jans.tuomi@gmail.com>2022-12-05 14:21:53 +0200
commit2a35e9cb7ad4f0ed350362135dd0d3094db27d09 (patch)
treec4a1022b9ad74320c6803ad756788ca5c04f5823 /src
parent1bf07cea4e38ba7c190d725fa887a139d229aef0 (diff)
Clean up, add more example code
Diffstat (limited to 'src')
-rw-r--r--src/Builtins.hs3
-rw-r--r--src/Lib.hs18
2 files changed, 11 insertions, 10 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs
index e7f0cda..dc6b44c 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -1,7 +1,8 @@
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Builtins where
import qualified Data.Map as M
-import Control.Monad.Except
+import Control.Monad.Except ( when, MonadError(throwError) )
import Types
builtinEnv :: Env
diff --git a/src/Lib.hs b/src/Lib.hs
index fc4b462..38cf23e 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -12,8 +12,6 @@ import Control.Monad.Reader
import Text.Regex.TDFA
import Types
import Utils
-import Builtins
-import Debug.Trace
_tokenize :: [String] -> String -> String -> LContext [String]
_tokenize acc current src = case src of
@@ -77,7 +75,6 @@ asPairs (a:b:rest) =
in (a, b) : restPaired
asPairs _ = error "odd number of elements to pair up"
-
parseToken :: String -> AST
parseToken token
| isInteger token = ASTInteger (read token)
@@ -127,7 +124,7 @@ parse :: [String] -> LContext [AST]
parse = _parse []
_curryCall :: Env -> [AST] -> LFunction -> LContext AST
-_curryCall env [] f = return $ ASTFunction f
+_curryCall _ [] f = return $ ASTFunction f
_curryCall env (arg:[]) f = f env arg
_curryCall env (arg:rest) f = do
g <- _curryCall env rest f
@@ -179,7 +176,8 @@ makeUserDefFn (ASTSymbol param) exprs =
let replacedExprs = map (traverseAndReplace param arg) exprs
let letExprs = take (length exprs - 1) replacedExprs
letSymValPairs <- letExprs
- $> map (\(ASTFunctionCall v) -> drop 1 v)
+ $> map (\case (ASTFunctionCall v) -> drop 1 v
+ _ -> error $ "unreachable: map letExprs")
.> mapM (evalLetExpr env)
let body = head $ drop (length exprs - 1) replacedExprs
let newBody = traverseAndReplace param arg body
@@ -222,7 +220,7 @@ evaluate env (ASTFunctionCall (first:args))
(cond, rest) <- case args of
[] -> throwError $ LException $ "match called with no arguments"
(_:[]) -> throwError $ LException $ "empty match cases"
- (cond':rest') -> return (cond', rest')
+ (a:b) -> return (a, b)
if length rest `mod` 2 == 0
then do
caseMatchers' <- oddElems rest $> mapM (evaluate env)
@@ -232,11 +230,13 @@ evaluate env (ASTFunctionCall (first:args))
(_, evaledCond) <- evaluate env cond
case M.lookup evaledCond caseMap of
Just branch -> evaluate env branch
- Nothing -> throwError $ LException $ "matching case not found, condition " ++ show cond
+ Nothing -> throwError $ LException $ "matching case not found when matching on value" ++ show cond
else do
- let (defaultBranch:revCases) = reverse rest
+ let (defaultBranch, revCases) = case reverse rest of
+ (a:b) -> (a, b)
+ _ -> error $ "unreachable: reverse rest"
caseMatchers' <- oddElems (reverse revCases) $> mapM (evaluate env)
- let caseMatchers = map (\(_, a) -> a) caseMatchers'
+ let caseMatchers = map snd caseMatchers'
let caseBranches = evenElems (reverse revCases)
let caseMap = M.fromList $ L.zip caseMatchers caseBranches
(_, evaledCond) <- evaluate env cond