diff options
| -rw-r--r-- | src/Builtins.hs | 3 | ||||
| -rw-r--r-- | src/Interpreter.hs | 60 | ||||
| -rw-r--r-- | src/Utils.hs | 15 |
3 files changed, 68 insertions, 10 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index e56d00d..dc80db4 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -38,7 +38,8 @@ builtinEnv = M.fromList [ reservedKeyword "\\", reservedKeyword "let!", reservedKeyword "match", - reservedKeyword "env!" + reservedKeyword "env!", + reservedKeyword "record!" ] argError1 :: String -> AST -> String diff --git a/src/Interpreter.hs b/src/Interpreter.hs index aefd816..9f56220 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -18,15 +18,6 @@ import Builtins import Tokenizer ( tokenize' ) import Parser ( parse ) --- _curryCall :: [AST] -> ASTNode -> LContext AST --- _curryCall (arg:[]) f = f arg --- _curryCall (arg:rest) f = do --- g <- _curryCall rest f --- case astNode g of --- ASTFunction fIsPure f' -> f' arg --- other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function" --- _curryCall _ astFn = throwL "" $ "unreachable: _curryCall, astFn: " ++ show astFn - curryCall :: [AST] -> ASTNode -> LContext AST curryCall [] (ASTFunction fIsPure f) = do checkPurity fIsPure @@ -239,6 +230,55 @@ evaluateImport asts = do _ -> throwL (astPos importAst) $ "invalid arguments passed to import!: " ++ show args +evaluateRecord :: [AST] -> LContext AST +evaluateRecord asts = do + let recordAst = head asts + args = tail asts + + d <- getDepth + 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 + let nonSymFields = L.find (not . isSymbolAST) rest + case nonSymFields of + Just invalid -> throwL (astPos invalid) + $ "non-symbol field in record definition: " ++ show invalid + Nothing -> return () + + let fields = extractRows rest + + let fnCreateName = ns ++ "/create" + let makeFnCreate :: [String] -> [(String, AST)] -> LFunction + makeFnCreate (param:[]) argsAcc = fn where + fn arg = do + let record = M.fromList $ (param, arg) : argsAcc + return $ makeNonsenseAST $ ASTRecord ns record + makeFnCreate (param:restParams) argsAcc = fn where + fn :: LFunction + fn arg = return $ makeNonsenseAST $ ASTFunction True $ + makeFnCreate restParams ((param, arg):argsAcc) + + makeFnCreate _ _ = error $ "unreachable: makeFnCreate " ++ fnCreateName + + let namespacedFields = map (\name -> ns ++ "/" ++ name) fields + let createFn = makeFnCreate fields [] + + insertThisEnv fnCreateName $ recordAst { astNode = ASTFunction True createFn } + return $ recordAst { astNode = ASTUnit } + + _ -> throwL (astPos recordAst) $ "invalid arguments passed to import!: " ++ show args + + where + isSymbolAST AST { astNode = ASTSymbol _ } = True + isSymbolAST _ = False + extractRows (AST { astNode = ASTSymbol sym }:rest) = sym : extractRows rest + extractRows _ = [] + processField ns field = + let fnGetName = ns ++ "/" ++ "get-" ++ field + fnSetName = ns ++ "/" ++ "set-" ++ field + in () -- todo + evaluateUserFunction :: [AST] -> LContext AST evaluateUserFunction children = do let fnAst = head children @@ -297,6 +337,8 @@ evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = evaluateEnv args ASTSymbol "import!" -> evaluateImport args + ASTSymbol "record!" -> + evaluateRecord args _ -> evaluateUserFunction args diff --git a/src/Utils.hs b/src/Utils.hs index b68de18..bcac58e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -6,6 +6,7 @@ import Control.Monad.State import qualified Data.Map as M import qualified Data.List as L import qualified Data.Char as C +import qualified Data.Text as T -- TYPES @@ -130,6 +131,8 @@ instance (Show Token) where type Purity = Bool type LFunction = AST -> LContext AST +type LRecord = M.Map String AST + data ASTNode = ASTInteger Int | ASTDouble Double @@ -140,6 +143,7 @@ data ASTNode | ASTFunctionCall [AST] | ASTHashMap (M.Map AST AST) | ASTFunction Purity LFunction + | ASTRecord String LRecord | ASTUnit | ASTHole @@ -167,6 +171,9 @@ instance (Show ASTNode) where show (ASTFunction isPure _) = case isPure of True -> "<pure fn>" False -> "<impure fn>" + show (ASTRecord identifier record) = + let assocsStrList = map (\(k, v) -> k ++ ":" ++ show v) (M.assocs record) + in "(" ++ identifier ++ " " ++ L.intercalate " " assocsStrList ++ ")" show ASTUnit = "<unit>" show ASTHole = "<hole>" @@ -286,3 +293,11 @@ astPos AST { astRow = r, astColumn = c, astFileName = f } = f ++ ":" ++ show r + tokenPos :: Token -> String tokenPos Token { tokenRow = r, tokenColumn = c, tokenFileName = f } = f ++ ":" ++ show r ++ ":" ++ show c + +separateNsIdPart :: String -> (String, String) +separateNsIdPart identifier = + let t = T.pack identifier + parts = T.splitOn (T.pack "/") t + nsPartText = T.concat $ L.init parts + idPartText = L.last parts + in (T.unpack nsPartText, T.unpack idPartText) |