diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 12 | ||||
| -rw-r--r-- | src/Lib.hs | 52 | ||||
| -rw-r--r-- | src/Types.hs | 4 |
3 files changed, 51 insertions, 17 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index 71401d8..1c1dd1b 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -9,7 +9,8 @@ builtinEnv = M.fromList [ ("+", builtinAdd2), ("-", builtinSubtract2), ("head", builtinHead), - ("tail", builtinTail) + ("tail", builtinTail), + ("prepend", builtinPrepend) ] builtinAdd2 :: AST @@ -46,4 +47,13 @@ builtinTail = (ASTVector vec) <- assertIsASTVector ast when (length vec == 0) $ throwError $ LException $ "tail of empty vector" return $ ASTVector $ tail vec + in ASTFunction outer + +builtinPrepend :: AST +builtinPrepend = + let outer ast1 = do + let inner ast2 = do + (ASTVector vec) <- assertIsASTVector ast2 + return $ ASTVector $ ast1 : vec + return $ ASTFunction $ inner in ASTFunction outer
\ No newline at end of file @@ -158,7 +158,8 @@ makeUserDefFn env (ASTSymbol param) body = let fn :: AST -> LContext AST fn arg = do let newBody = traverseAndReplace param arg body - evaluate env newBody + (_, ret) <- evaluate env newBody + return ret in fn makeUserDefFn _ _ _ = error $ "unreachable: makeUserDefFn" @@ -174,7 +175,7 @@ curriedMakeUserDefFn env ((ASTSymbol param):rest) body = in fn curriedMakeUserDefFn _ _ _ = error $ "unreachable: curriedMakeUserDefFn" -evaluate :: Env -> AST -> LContext AST +evaluate :: Env -> AST -> LContext (Env, AST) evaluate env (ASTFunctionCall (first:args)) | first == ASTSymbol "\\" = do (arg1, arg2) <- case args of @@ -185,7 +186,7 @@ evaluate env (ASTFunctionCall (first:args)) -- when (length params == 0) $ throwError $ LException $ "Function must have > 0 parameters" body <- assertIsASTFunctionCall arg2 let fn = curriedMakeUserDefFn env params body - return $ ASTFunction fn + return $ (env, ASTFunction fn) | first == ASTSymbol "match" = do (cond, rest) <- case args of [] -> throwError $ LException $ "match called with no arguments" @@ -209,26 +210,48 @@ evaluate env (ASTFunctionCall (first:args)) case M.lookup evaledCond caseMap of Just branch -> evaluate env branch Nothing -> evaluate env defaultBranch + | first == ASTSymbol "let" = do + (symbol, value) <- case args of + [ASTSymbol symbol', value'] -> do + (_, evaledValue) <- evaluate env value' + return (symbol', evaledValue) + [ASTSymbol "lazy", ASTSymbol symbol', value'] -> do + return (symbol', value') + other -> throwError $ LException $ "let called with invalid args " ++ show other + when (M.member symbol env) $ throwError $ LException $ "symbol already defined: " ++ symbol + let newEnv = M.insert symbol value env + return $ (newEnv, ASTUnit) + | first == ASTSymbol "env" = do + liftIO $ putStrLn $ show env + return (env, ASTUnit) | otherwise = do - fnEvaled <- evaluate env first + (_, fnEvaled) <- evaluate env first (ASTFunction fn) <- assertIsASTFunction fnEvaled - evaledArgs <- mapM (evaluate env) args + evaledArgs' <- mapM (evaluate env) args + let evaledArgs = map (\(_, a) -> a) evaledArgs' result <- curryCall (reverse evaledArgs) fn - return result + return (env, result) evaluate env (ASTSymbol sym) = do let val = M.lookup sym env case val of - Just ast -> return ast + Just ast -> return (env, ast) Nothing -> throwError $ LException $ "Symbol " ++ sym ++ " not defined in environment" -evaluate _ ast = return ast +evaluate env ast = return (env, ast) -runScriptFile :: String -> LContext () -runScriptFile fileName = do +runScriptFile :: Env -> String -> LContext Env +runScriptFile env fileName = do src <- liftIO $ readFile fileName - runInlineScript src + runInlineScript env src -runInlineScript :: String -> LContext () -runInlineScript src = do +evalParsed :: Env -> [AST] -> LContext (Env, [AST]) +evalParsed env [] = return (env, []) +evalParsed env (ast:rest) = do + (newEnv, newAst) <- evaluate env ast + (retEnv, restEvaled) <- evalParsed newEnv rest + return $ (retEnv, newAst : restEvaled) + +runInlineScript :: Env -> String -> LContext Env +runInlineScript env src = do tokenized <- tokenize src config <- ask when (configVerboseMode config) $ liftIO $ putStrLn $ "tokenized:\t\t" ++ show tokenized @@ -236,5 +259,6 @@ runInlineScript src = do when (configVerboseMode config) $ do let output = "parsed:\t\t\t" ++ (map show parsed $> L.intercalate "\n\t\t\t") liftIO $ putStrLn output - evaluated <- mapM (evaluate builtinEnv) parsed + (newEnv, evaluated) <- evalParsed env parsed liftIO $ mapM_ putStrLn (map show evaluated) + return newEnv diff --git a/src/Types.hs b/src/Types.hs index 9953882..515910b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -16,6 +16,8 @@ data Config = Config { type LContext a = ReaderT Config (ExceptT LException IO) a +type Env = M.Map String AST + data AST = ASTInteger Int | ASTDouble Double @@ -87,5 +89,3 @@ assertIsASTFunctionCall :: AST -> LContext AST assertIsASTFunctionCall ast = case ast of (ASTFunctionCall _) -> return ast _ -> throwError $ LException $ show ast ++ " is not a function call or body" - -type Env = M.Map String AST |