diff options
| author | Jan Tuomi <jan.tuomi@valuemotive.com> | 2022-09-25 16:51:54 +0300 |
|---|---|---|
| committer | Jan Tuomi <jans.tuomi@gmail.com> | 2022-12-05 14:21:53 +0200 |
| commit | 2a35e9cb7ad4f0ed350362135dd0d3094db27d09 (patch) | |
| tree | c4a1022b9ad74320c6803ad756788ca5c04f5823 /src | |
| parent | 1bf07cea4e38ba7c190d725fa887a139d229aef0 (diff) | |
Clean up, add more example code
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 3 | ||||
| -rw-r--r-- | src/Lib.hs | 18 |
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 @@ -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 |
