From c1713b4ea6c542fa2fe0d66b51c5b7b27fedf57a Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Tue, 4 Oct 2022 15:21:56 +0300 Subject: Add import! --- app/Main.hs | 2 +- examples/import.lisp | 3 + examples/maybe.lisp | 54 +++++----- lang.cabal | 3 +- src/Evaluator.hs | 227 ----------------------------------------- src/Interpreter.hs | 281 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/Lib.hs | 43 -------- 7 files changed, 313 insertions(+), 300 deletions(-) create mode 100644 examples/import.lisp delete mode 100644 src/Evaluator.hs create mode 100644 src/Interpreter.hs delete mode 100644 src/Lib.hs diff --git a/app/Main.hs b/app/Main.hs index d8fcb61..c71fd2f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,7 @@ import Control.Monad.Except import System.Console.Haskeline import Utils import Builtins -import Lib +import Interpreter parseArgs :: Config -> [String] -> Config parseArgs config args = diff --git a/examples/import.lisp b/examples/import.lisp new file mode 100644 index 0000000..d302562 --- /dev/null +++ b/examples/import.lisp @@ -0,0 +1,3 @@ +(import! M "examples/maybe.lisp") + +(print! (fmt "{0}\n" [(M:just 666)])) diff --git a/examples/maybe.lisp b/examples/maybe.lisp index dab7bf8..7cabfea 100644 --- a/examples/maybe.lisp +++ b/examples/maybe.lisp @@ -31,30 +31,30 @@ ; TESTING -(let! print-line! (\[s] - (print! (concat s "\n")))) - -(let! a (just 10)) -(let! b (nothing)) - -(map (+ 5) a) -(map (+ 5) b) - -(and-then (\[n] (just (+ n 5))) a) -(and-then (\[n] (just (+ n 5))) b) - -(let! m (just 10)) -(match m - (just _) - (print-line! (fmt "found just {0}!" [(unpack-just m)])) - (nothing) - (print-line! "found nothing!")) - -;; (let! exports [ -;; just -;; nothing -;; unpack-just -;; kind -;; map -;; and-then -;; ]) +;; (let! print-line! (\[s] +;; (print! (concat s "\n")))) + +;; (let! a (just 10)) +;; (let! b (nothing)) + +;; (map (+ 5) a) +;; (map (+ 5) b) + +;; (and-then (\[n] (just (+ n 5))) a) +;; (and-then (\[n] (just (+ n 5))) b) + +;; (let! m (just 10)) +;; (match m +;; (just _) +;; (print-line! (fmt "found just {0}!" [(unpack-just m)])) +;; (nothing) +;; (print-line! "found nothing!")) + +(let! exports [ + just + nothing + unpack-just + kind + map + and-then +]) diff --git a/lang.cabal b/lang.cabal index 5954937..0298729 100644 --- a/lang.cabal +++ b/lang.cabal @@ -26,8 +26,7 @@ source-repository head library exposed-modules: Builtins - Evaluator - Lib + Interpreter Parser Tokenizer Utils diff --git a/src/Evaluator.hs b/src/Evaluator.hs deleted file mode 100644 index b7b792b..0000000 --- a/src/Evaluator.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -module Evaluator ( - evaluate, -) where - -import qualified Data.Map as M -import qualified Data.List as L -import Data.Function ( on ) -import Control.Monad.Reader -import Control.Monad.Except ( catchError ) -import Utils --- import Debug.Trace - -type Depth = Int - -_curryCall :: Env -> [AST] -> LFunction -> LContext AST -_curryCall _ [] f = return $ (makeNonsenseAST $ ASTFunction f) -_curryCall env (arg:[]) f = f env arg -_curryCall env (arg:rest) f = do - g <- _curryCall env rest f - case astNode g of - ASTFunction f' -> f' env arg - other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function" - -curryCall :: Env -> [AST] -> LFunction -> LContext AST -curryCall env [] f = f env (makeNonsenseAST ASTUnit) -curryCall env args f = _curryCall env args f - -traverseAndReplace :: String -> AST -> AST -> AST -traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym } - | sym == param = arg - | otherwise = ast -traverseAndReplace param arg ast@AST { astNode = ASTFunctionCall body } = - ast { astNode = ASTFunctionCall $ (map (traverseAndReplace param arg) body) } -traverseAndReplace param arg ast@AST { astNode = ASTVector vec } = - ast { astNode = ASTVector $ (map (traverseAndReplace param arg) vec) } -traverseAndReplace param arg ast@AST { astNode = ASTHashMap hmap } = - ast { astNode = ASTHashMap $ M.assocs hmap - $> L.concatMap (\(a, b) -> [a, b]) - .> map (traverseAndReplace param arg) - .> asPairs .> M.fromList } -traverseAndReplace _ _ other = other - -foldSymValPairs :: [(String, AST)] -> AST -> AST -foldSymValPairs [] body = body -foldSymValPairs ((sym, val):rest) body = - let replacedRestVals = map (snd .> traverseAndReplace sym val) rest - replacedRest = zip (map fst rest) (replacedRestVals) - replacedBody = traverseAndReplace sym val body - in foldSymValPairs replacedRest replacedBody - -letArgsToSymValPairs :: Depth -> Env -> [AST] -> LContext (String, AST) -letArgsToSymValPairs d env args = - case args of - [AST { astNode = ASTSymbol symbol' }, value'] -> do - (_, evaledValue) <- evaluate d env value' - return (symbol', evaledValue) - [AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do - return (symbol', value') - other -> throwL (astPos $ head other) $ "let! called with invalid args " ++ show other - -defineUserFunction :: Depth -> AST -> [AST] -> LContext LFunction -defineUserFunction d AST { astNode = ASTSymbol param } exprs = return fn where - fn :: LFunction - fn env arg = do - let replacedExprs = map (traverseAndReplace param arg) exprs - let letExprs = take (length exprs - 1) replacedExprs - letSymValPairs <- letExprs - $> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v - ast -> throwL (astPos ast) $ "unreachable: map letExprs, ast: " ++ show ast) - .> fmap (mapM $ letArgsToSymValPairs d env) .> join - let body = head $ drop (length exprs - 1) replacedExprs - let newBody = traverseAndReplace param arg body - $> foldSymValPairs letSymValPairs - (_, ret) <- evaluate d env newBody - return ret - -defineUserFunction _ param exprs = throwL (astPos param) - $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs - -defineUserFunctionWithLetExprs :: Depth -> [AST] -> [AST] -> LContext LFunction -defineUserFunctionWithLetExprs d [] exprs = - -- the position info is nonsensical, but it should never get read anyway - defineUserFunction d (makeNonsenseAST $ ASTSymbol "unit") exprs -defineUserFunctionWithLetExprs d (param:[]) exprs = - defineUserFunction d param exprs -defineUserFunctionWithLetExprs d (AST { astNode = ASTSymbol param }:rest) exprs = return fn where - fn :: LFunction - fn _ arg = do - let newExprs = map (traverseAndReplace param arg) exprs - ret <- defineUserFunctionWithLetExprs d rest newExprs - -- the returned AST will not have the correct position info, but that's fine - -- because the info is overridden in evaluateFunctionDef anyway - return $ makeNonsenseAST $ ASTFunction $ ret -defineUserFunctionWithLetExprs _ (param:_) _ = throwL (astPos $ param) - $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param - -evaluateFunctionDef :: Depth -> Env -> [AST] -> LContext (Env, AST) -evaluateFunctionDef d env asts = do - let defAst = head asts - args = tail asts - (params'', exprs) <- case args of - args' - | length args' < 2 -> - throwL (astPos defAst) $ "\\ called with " ++ show (length args) ++ " arguments" - | otherwise -> return $ (head args', tail args') - - AST { astNode = ASTVector params' } <- assertIsASTVector params'' - params <- mapM assertIsASTSymbol params' - - let shadowingParamM = L.find (astNode .> (\(ASTSymbol sym) -> sym) .> isParamNameShadowing) params - case shadowingParamM of - Just shadowingParam -> throwL (astPos shadowingParam) - $ "parameter is shadowing already defined symbol " ++ show (astNode shadowingParam) - Nothing -> return () - - let letExprs = take (length exprs - 1) exprs - let nonLetExprM = L.find (not . isLetAST) letExprs - case nonLetExprM of - Just nonLetExpr -> throwL (astPos nonLetExpr) - $ "non-let expression in function definition before body: " ++ show nonLetExpr - Nothing -> return () - - fn <- defineUserFunctionWithLetExprs d params exprs - return $ (env, defAst { astNode = ASTFunction fn }) - where - isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True - isLetAST _ = False - isParamNameShadowing name = M.member name env - -evaluateMatch :: Depth -> Env -> [AST] -> LContext (Env, AST) -evaluateMatch d env asts = do - let matchAst = head asts - args = tail asts - (actualExpr, rest) <- case args of - [] -> throwL (astPos matchAst) $ "match called with no arguments" - (_:[]) -> throwL (astPos matchAst) "empty match cases" - (a:b) -> return (a, b) - - pairs <- (asPairsM rest) `catchError` - (\_ -> throwL (astPos matchAst) $ "invalid number of arguments passed to match\n" - ++ "- matching on expr: " ++ show actualExpr ++ "\n" - ++ "- arguments: " ++ show rest) - - (_, evaledActual) <- evaluate d env actualExpr - ret <- matchPairs (actualExpr, evaledActual) pairs - return (env, matchAst { astNode = astNode ret }) - where - matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST - matchPairs (actualExpr, evaledActual) [] = throwL (astPos actualExpr) - $ "matching case not found when matching on expression: " ++ show actualExpr - ++ " (actual value: " ++ show evaledActual ++ ")" - matchPairs (actualExpr, evaledActual) ((matcher, branch):restPairs) = do - (_, evaledMatcher) <- evaluate d env matcher - if evaledActual == evaledMatcher - then do - (_, ret) <- evaluate d env branch - return ret - else matchPairs (actualExpr, evaledActual) restPairs - -evaluateLet :: Depth -> Env -> [AST] -> LContext (Env, AST) -evaluateLet d env asts = do - let letAst = head asts - args = tail asts - when (d > 1) $ throwL (astPos letAst) $ "let! can only be called on the top level or in a function definition" - (symbol, value) <- letArgsToSymValPairs d env args - when (M.member symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol - let newEnv = M.insert symbol value env - return $ (newEnv, letAst { astNode = ASTUnit }) - -evaluateEnv :: Depth -> Env -> [AST] -> LContext (Env, AST) -evaluateEnv d env asts = do - let envAst = head asts - when (d > 1) $ throwL (astPos envAst) $ "env! can only be called on the top level or in a function definition" - let pairs = M.assocs env - let longestKey = L.maximumBy (compare `on` (length . fst)) pairs $> fst - let pad s = s ++ take (length longestKey + 4 - length s) (L.repeat ' ') - let rows = pairs $> map (\(k, v) -> pad k ++ show v) - liftIO $ mapM_ putStrLn rows - return (env, envAst { astNode = ASTUnit }) - -evaluateUserFunction :: Depth -> Env -> [AST] -> LContext (Env, AST) -evaluateUserFunction d env children = do - let fnAst = head children - args = tail children - (_, fnEvaled) <- evaluate d env fnAst - AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled - evaledArgs' <- mapM (evaluate d env) args - let evaledArgs = map snd evaledArgs' - doubleEvaledArgs' <- mapM (evaluate d env) evaledArgs - let doubleEvaledArgs = map snd doubleEvaledArgs' - result <- curryCall env (reverse doubleEvaledArgs) fn - -- maybe remove double eval here? can't remember why it was added - return (env, fnAst { astNode = astNode result }) - -evaluateSymbol :: Env -> AST -> LContext (Env, AST) -evaluateSymbol env ast@AST { astNode = ASTSymbol sym } = do - let val = M.lookup sym env - case val of - Just ast' -> return (env, ast') - Nothing -> throwL (astPos ast) $ "symbol " ++ sym ++ " not defined in environment" -evaluateSymbol _ ast = throwL (astPos ast) $ "unreachable: evaluateSymbol, ast: " ++ show ast - -evaluate :: Depth -> Env -> AST -> LContext (Env, AST) -evaluate d env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = - do config <- ask - when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc - case astNode x of - -- remember to add these as reseved keywords in Builtins! - ASTSymbol "\\" -> - evaluateFunctionDef (d + 1) env args - ASTSymbol "match" -> - evaluateMatch (d + 1) env args - ASTSymbol "let!" -> - evaluateLet (d + 1) env args - ASTSymbol "env!" -> - evaluateEnv (d + 1) env args - _ -> - evaluateUserFunction (d + 1) env args -evaluate _ env ast@AST { astNode = (ASTSymbol _) } = - evaluateSymbol env ast -evaluate d env ast@AST { astNode = (ASTVector vec) } = - do rets <- mapM (evaluate (d + 1) env) vec - let vec' = map snd rets - return $ (env, ast { astNode = ASTVector vec' }) -evaluate _ env other = - return (env, other) diff --git a/src/Interpreter.hs b/src/Interpreter.hs new file mode 100644 index 0000000..33e36ea --- /dev/null +++ b/src/Interpreter.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE LambdaCase #-} +module Interpreter ( + runInlineScript, + runScriptFile +) where + +import qualified Data.Map as M +import qualified Data.List as L +import Data.Function ( on ) +import Control.Monad.Reader +import Control.Monad.Except +import Utils +-- import Debug.Trace +import Builtins +import Tokenizer ( tokenize ) +import Parser ( parse ) + +type Depth = Int + +_curryCall :: Env -> [AST] -> LFunction -> LContext AST +_curryCall _ [] f = return $ (makeNonsenseAST $ ASTFunction f) +_curryCall env (arg:[]) f = f env arg +_curryCall env (arg:rest) f = do + g <- _curryCall env rest f + case astNode g of + ASTFunction f' -> f' env arg + other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function" + +curryCall :: Env -> [AST] -> LFunction -> LContext AST +curryCall env [] f = f env (makeNonsenseAST ASTUnit) +curryCall env args f = _curryCall env args f + +traverseAndReplace :: String -> AST -> AST -> AST +traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym } + | sym == param = arg + | otherwise = ast +traverseAndReplace param arg ast@AST { astNode = ASTFunctionCall body } = + ast { astNode = ASTFunctionCall $ (map (traverseAndReplace param arg) body) } +traverseAndReplace param arg ast@AST { astNode = ASTVector vec } = + ast { astNode = ASTVector $ (map (traverseAndReplace param arg) vec) } +traverseAndReplace param arg ast@AST { astNode = ASTHashMap hmap } = + ast { astNode = ASTHashMap $ M.assocs hmap + $> L.concatMap (\(a, b) -> [a, b]) + .> map (traverseAndReplace param arg) + .> asPairs .> M.fromList } +traverseAndReplace _ _ other = other + +foldSymValPairs :: [(String, AST)] -> AST -> AST +foldSymValPairs [] body = body +foldSymValPairs ((sym, val):rest) body = + let replacedRestVals = map (snd .> traverseAndReplace sym val) rest + replacedRest = zip (map fst rest) (replacedRestVals) + replacedBody = traverseAndReplace sym val body + in foldSymValPairs replacedRest replacedBody + +letArgsToSymValPairs :: Depth -> Env -> [AST] -> LContext (String, AST) +letArgsToSymValPairs d env args = + case args of + [AST { astNode = ASTSymbol symbol' }, value'] -> do + (_, evaledValue) <- evaluate d env value' + return (symbol', evaledValue) + [AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do + return (symbol', value') + other -> throwL (astPos $ head other) $ "let! called with invalid args " ++ show other + +defineUserFunction :: Depth -> AST -> [AST] -> LContext LFunction +defineUserFunction d AST { astNode = ASTSymbol param } exprs = return fn where + fn :: LFunction + fn env arg = do + let replacedExprs = map (traverseAndReplace param arg) exprs + let letExprs = take (length exprs - 1) replacedExprs + letSymValPairs <- letExprs + $> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v + ast -> throwL (astPos ast) $ "unreachable: map letExprs, ast: " ++ show ast) + .> fmap (mapM $ letArgsToSymValPairs d env) .> join + let body = head $ drop (length exprs - 1) replacedExprs + let newBody = traverseAndReplace param arg body + $> foldSymValPairs letSymValPairs + (_, ret) <- evaluate d env newBody + return ret + +defineUserFunction _ param exprs = throwL (astPos param) + $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs + +defineUserFunctionWithLetExprs :: Depth -> [AST] -> [AST] -> LContext LFunction +defineUserFunctionWithLetExprs d [] exprs = + -- the position info is nonsensical, but it should never get read anyway + defineUserFunction d (makeNonsenseAST $ ASTSymbol "unit") exprs +defineUserFunctionWithLetExprs d (param:[]) exprs = + defineUserFunction d param exprs +defineUserFunctionWithLetExprs d (AST { astNode = ASTSymbol param }:rest) exprs = return fn where + fn :: LFunction + fn _ arg = do + let newExprs = map (traverseAndReplace param arg) exprs + ret <- defineUserFunctionWithLetExprs d rest newExprs + -- the returned AST will not have the correct position info, but that's fine + -- because the info is overridden in evaluateFunctionDef anyway + return $ makeNonsenseAST $ ASTFunction $ ret +defineUserFunctionWithLetExprs _ (param:_) _ = throwL (astPos $ param) + $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param + +evaluateFunctionDef :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateFunctionDef d env asts = do + let defAst = head asts + args = tail asts + (params'', exprs) <- case args of + args' + | length args' < 2 -> + throwL (astPos defAst) $ "\\ called with " ++ show (length args) ++ " arguments" + | otherwise -> return $ (head args', tail args') + + AST { astNode = ASTVector params' } <- assertIsASTVector params'' + params <- mapM assertIsASTSymbol params' + + let shadowingParamM = L.find (astNode .> (\(ASTSymbol sym) -> sym) .> isParamNameShadowing) params + case shadowingParamM of + Just shadowingParam -> throwL (astPos shadowingParam) + $ "parameter is shadowing already defined symbol " ++ show (astNode shadowingParam) + Nothing -> return () + + let letExprs = take (length exprs - 1) exprs + let nonLetExprM = L.find (not . isLetAST) letExprs + case nonLetExprM of + Just nonLetExpr -> throwL (astPos nonLetExpr) + $ "non-let expression in function definition before body: " ++ show nonLetExpr + Nothing -> return () + + fn <- defineUserFunctionWithLetExprs d params exprs + return $ (env, defAst { astNode = ASTFunction fn }) + where + isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True + isLetAST _ = False + isParamNameShadowing name = M.member name env + +evaluateMatch :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateMatch d env asts = do + let matchAst = head asts + args = tail asts + (actualExpr, rest) <- case args of + [] -> throwL (astPos matchAst) $ "match called with no arguments" + (_:[]) -> throwL (astPos matchAst) "empty match cases" + (a:b) -> return (a, b) + + pairs <- (asPairsM rest) `catchError` + (\_ -> throwL (astPos matchAst) $ "invalid number of arguments passed to match\n" + ++ "- matching on expr: " ++ show actualExpr ++ "\n" + ++ "- arguments: " ++ show rest) + + (_, evaledActual) <- evaluate d env actualExpr + ret <- matchPairs (actualExpr, evaledActual) pairs + return (env, matchAst { astNode = astNode ret }) + where + matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST + matchPairs (actualExpr, evaledActual) [] = throwL (astPos actualExpr) + $ "matching case not found when matching on expression: " ++ show actualExpr + ++ " (actual value: " ++ show evaledActual ++ ")" + matchPairs (actualExpr, evaledActual) ((matcher, branch):restPairs) = do + (_, evaledMatcher) <- evaluate d env matcher + if evaledActual == evaledMatcher + then do + (_, ret) <- evaluate d env branch + return ret + else matchPairs (actualExpr, evaledActual) restPairs + +evaluateLet :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateLet d env asts = do + let letAst = head asts + args = tail asts + when (d > 1) $ throwL (astPos letAst) $ "let! can only be called on the top level or in a function definition" + (symbol, value) <- letArgsToSymValPairs d env args + when (M.member symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol + let newEnv = M.insert symbol value env + return $ (newEnv, letAst { astNode = ASTUnit }) + +evaluateEnv :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateEnv d env asts = do + let envAst = head asts + when (d > 1) $ throwL (astPos envAst) $ "env! can only be called on the top level" + let pairs = M.assocs env + let longestKey = L.maximumBy (compare `on` (length . fst)) pairs $> fst + let pad s = s ++ take (length longestKey + 4 - length s) (L.repeat ' ') + let rows = pairs $> map (\(k, v) -> pad k ++ show v) + liftIO $ mapM_ putStrLn rows + return (env, envAst { astNode = ASTUnit }) + +evaluateImport :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateImport d env asts = do + let importAst = head asts + args = tail asts + when (d > 1) $ throwL (astPos importAst) $ "import! can only be called on the top level" + + case args of + [AST { astNode = ASTSymbol qualifier }, AST { astNode = ASTString path }] -> do + (importedEnv, _) <- runScriptFile builtinEnv path + let nameMangled = M.mapKeys (\k -> qualifier ++ ":" ++ k) importedEnv + return (M.union env nameMangled, importAst { astNode = ASTUnit }) + [AST { astNode = ASTString path }] -> do + (importedEnv, _) <- runScriptFile builtinEnv path + return (M.union env importedEnv, importAst { astNode = ASTUnit }) + _ -> throwL (astPos importAst) $ "invalid arguments passed to import!: " ++ show args + +evaluateUserFunction :: Depth -> Env -> [AST] -> LContext (Env, AST) +evaluateUserFunction d env children = do + let fnAst = head children + args = tail children + (_, fnEvaled) <- evaluate d env fnAst + AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled + evaledArgs' <- mapM (evaluate d env) args + let evaledArgs = map snd evaledArgs' + doubleEvaledArgs' <- mapM (evaluate d env) evaledArgs + let doubleEvaledArgs = map snd doubleEvaledArgs' + result <- curryCall env (reverse doubleEvaledArgs) fn + -- maybe remove double eval here? can't remember why it was added + return (env, fnAst { astNode = astNode result }) + +evaluateSymbol :: Env -> AST -> LContext (Env, AST) +evaluateSymbol env ast@AST { astNode = ASTSymbol sym } = do + let val = M.lookup sym env + case val of + Just ast' -> return (env, ast') + Nothing -> throwL (astPos ast) $ "symbol " ++ sym ++ " not defined in environment" +evaluateSymbol _ ast = throwL (astPos ast) $ "unreachable: evaluateSymbol, ast: " ++ show ast + +evaluate :: Depth -> Env -> AST -> LContext (Env, AST) +evaluate d env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = + do config <- ask + when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc + case astNode x of + -- remember to add these as reseved keywords in Builtins! + ASTSymbol "\\" -> + evaluateFunctionDef (d + 1) env args + ASTSymbol "match" -> + evaluateMatch (d + 1) env args + ASTSymbol "let!" -> + evaluateLet (d + 1) env args + ASTSymbol "env!" -> + evaluateEnv (d + 1) env args + ASTSymbol "import!" -> + evaluateImport (d + 1) env args + _ -> + evaluateUserFunction (d + 1) env args +evaluate _ env ast@AST { astNode = (ASTSymbol _) } = + evaluateSymbol env ast +evaluate d env ast@AST { astNode = (ASTVector vec) } = + do rets <- mapM (evaluate (d + 1) env) vec + let vec' = map snd rets + return $ (env, ast { astNode = ASTVector vec' }) +evaluate _ env other = + return (env, other) + +-- LIB + +runScriptFile :: Env -> String -> LContext (Env, [AST]) +runScriptFile env fileName = do + src <- liftIO $ readFile fileName + runInlineScript fileName env src + +runInlineScript :: String -> Env -> String -> LContext (Env, [AST]) +runInlineScript fileName env src = do + tokenized <- tokenize fileName src + config <- ask + when (configVerboseMode config) $ liftIO $ putStrLn $ "tokenized:\t\t" ++ show tokenized + parsed <- parse tokenized + + when (configVerboseMode config) $ do + let output = "parsed:\t\t\t" ++ (map show parsed $> L.intercalate "\n\t\t\t") + liftIO $ putStrLn output + + (newEnv, evaluated) <- foldEvaluate env parsed + + when (configPrintEvaled config) $ do + liftIO $ mapM_ putStrLn (map show evaluated) + + return (newEnv, evaluated) + where + foldEvaluate :: Env -> [AST] -> LContext (Env, [AST]) + foldEvaluate accEnv [] = return (accEnv, []) + foldEvaluate accEnv (ast:rest) = do + (newAccEnv, newAst) <- evaluate 0 accEnv ast + (retEnv, restEvaled) <- foldEvaluate newAccEnv rest + return $ (retEnv, newAst : restEvaled) diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index 8b26a35..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -module Lib ( - runScriptFile, - runInlineScript, -) where - -import qualified Data.List as L -import Control.Monad.Except -import Control.Monad.Reader -import Utils -import Tokenizer ( tokenize ) -import Parser ( parse ) -import Evaluator ( evaluate ) - -runScriptFile :: Env -> String -> LContext (Env, [AST]) -runScriptFile env fileName = do - src <- liftIO $ readFile fileName - runInlineScript fileName env src - -runInlineScript :: String -> Env -> String -> LContext (Env, [AST]) -runInlineScript fileName env src = do - tokenized <- tokenize fileName src - config <- ask - when (configVerboseMode config) $ liftIO $ putStrLn $ "tokenized:\t\t" ++ show tokenized - parsed <- parse tokenized - - when (configVerboseMode config) $ do - let output = "parsed:\t\t\t" ++ (map show parsed $> L.intercalate "\n\t\t\t") - liftIO $ putStrLn output - - (newEnv, evaluated) <- foldEvaluate env parsed - - when (configPrintEvaled config) $ do - liftIO $ mapM_ putStrLn (map show evaluated) - - return (newEnv, evaluated) - where - foldEvaluate :: Env -> [AST] -> LContext (Env, [AST]) - foldEvaluate accEnv [] = return (accEnv, []) - foldEvaluate accEnv (ast:rest) = do - (newAccEnv, newAst) <- evaluate 0 accEnv ast - (retEnv, restEvaled) <- foldEvaluate newAccEnv rest - return $ (retEnv, newAst : restEvaled) -- cgit v1.3