diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 26 | ||||
| -rw-r--r-- | src/Interpreter.hs | 31 |
2 files changed, 37 insertions, 20 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index b731e66..7ad966a 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -4,6 +4,7 @@ module Builtins where import qualified Data.Map as M import qualified Data.Text as T import qualified Text.Read as TR +import qualified Data.List as L import Control.Monad.Except import Utils @@ -26,6 +27,7 @@ builtinEnv = M.fromList [ builtinHead, builtinTail, builtinPrepend, + builtinSortByFirst, -- string operations builtinSubstr, builtinStrToVec, @@ -45,10 +47,10 @@ builtinEnv = M.fromList [ builtinKind, -- reserved keywords reservedKeyword "\\", - reservedKeyword "let!", + reservedKeyword "let", reservedKeyword "match", - reservedKeyword "env!", - reservedKeyword "record!" + reservedKeyword "Debug/env", + reservedKeyword "record" ] argError1 :: String -> AST -> String @@ -308,3 +310,21 @@ builtinAppendFile = (name, makeNonsenseAST $ ASTFunction False fn1) where Nothing -> throwL (astPos ast1) $ "failed to append to file: " ++ filePath fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + +builtinSortByFirst :: (String, AST) +builtinSortByFirst = (name, makeNonsenseAST $ ASTFunction True fn1) where + name = "sort-by-first" + fn1 ast1@AST { astNode = ASTVector elems } = do + pairs <- mapM elemToPair elems + let sorted = L.sortBy (\(a, _) (b, _) -> compare a b) pairs + let sortedASTS = map (\(k, v) -> makeNonsenseAST $ + ASTVector [makeNonsenseAST $ ASTInteger k, v]) sorted + return $ makeNonsenseAST $ ASTVector sortedASTS where + itemsToPair [AST { astNode = ASTInteger k }, v] = + return $ (k, v) + itemsToPair items = throwL (astPos ast1) $ + "invalid element in vector supplied to sort-by-first: " ++ show items + elemToPair AST { astNode = ASTVector items } = + itemsToPair items + elemToPair ast2 = throwL (astPos ast2) $ argError1 name ast1 + fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6e9e770..de77fc9 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -65,7 +65,7 @@ letArgsToSymValPairs args = 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 + other -> throwL (astPos $ head other) $ "let called with invalid args " ++ show other defineUserFunction :: AST -> [AST] -> LContext LFunction defineUserFunction paramAst@AST { astNode = ASTSymbol param } exprs = return fn where @@ -139,7 +139,7 @@ evaluateFunctionDef isPure asts = do fn <- defineUserFunctionWithLetExprs params exprs return $ defAst { astNode = ASTFunction isPure fn } where - isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True + isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let" }:_) } = True isLetAST _ = False asSymbol AST { astNode = ASTSymbol sym } = sym asSymbol ast = error $ "unreachable: evaluateFunctionDef asSymbol, ast: " ++ show ast @@ -179,7 +179,7 @@ evaluateLet asts = do args = tail asts d <- getDepth - when (d > 1) $ throwL (astPos letAst) $ "let! can only be called on the top level or in a function definition, current depth: " ++ show d + when (d > 1) $ throwL (astPos letAst) $ "let can only be called on the top level or in a function definition, current depth: " ++ show d (symbol, value) <- letArgsToSymValPairs args env <- getEnv @@ -187,13 +187,10 @@ evaluateLet asts = do insertThisEnv symbol value return $ letAst { astNode = ASTUnit } -evaluateEnv :: [AST] -> LContext AST -evaluateEnv asts = do +evaluateDebugEnv :: [AST] -> LContext AST +evaluateDebugEnv asts = do let envAst = head asts - d <- getDepth - when (d > 1) $ throwL (astPos envAst) $ "env! can only be called on the top level, current depth: " ++ show d - env <- getEnv let pairs = M.assocs (M.union (envThis env) (envImported env)) let longestKey = L.maximumBy (compare `on` (length . fst)) pairs $> fst @@ -208,7 +205,7 @@ evaluateImport asts = do args = tail asts d <- getDepth - when (d > 1) $ throwL (astPos importAst) $ "import! can only be called on the top level, current depth: " ++ show d + when (d > 1) $ throwL (astPos importAst) $ "import can only be called on the top level, current depth: " ++ show d config <- getConfig let initialState = LState { @@ -228,7 +225,7 @@ evaluateImport asts = do putImportedEnv $ M.union importedEnv exportedEnvMap return $ importAst { astNode = ASTUnit } - _ -> throwL (astPos importAst) $ "invalid arguments passed to import!: " ++ show args + _ -> throwL (astPos importAst) $ "invalid arguments passed to import: " ++ show args evaluateRecord :: [AST] -> LContext AST evaluateRecord asts = do @@ -236,7 +233,7 @@ evaluateRecord asts = do args = tail asts d <- getDepth - when (d > 1) $ throwL (astPos recordAst) $ "record! can only be called on the top level, current depth: " ++ show d + when (d > 1) $ throwL (astPos recordAst) $ "record can only be called on the top level, current depth: " ++ show d case args of (AST { astNode = ASTSymbol ns }:rest) -> do @@ -286,7 +283,7 @@ evaluateRecord asts = do return $ recordAst { astNode = ASTUnit } - _ -> throwL (astPos recordAst) $ "invalid arguments passed to import!: " ++ show args + _ -> throwL (astPos recordAst) $ "invalid arguments passed to import: " ++ show args where isSymbolAST AST { astNode = ASTSymbol _ } = True @@ -365,13 +362,13 @@ evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = evaluateFunctionDef False args ASTSymbol "match" -> evaluateMatch args - ASTSymbol "let!" -> + ASTSymbol "let" -> evaluateLet args - ASTSymbol "env!" -> - evaluateEnv args - ASTSymbol "import!" -> + ASTSymbol "Debug/env" -> + evaluateDebugEnv args + ASTSymbol "import" -> evaluateImport args - ASTSymbol "record!" -> + ASTSymbol "record" -> evaluateRecord args _ -> evaluateUserFunction args |