diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 8 | ||||
| -rw-r--r-- | src/Interpreter.hs | 22 |
2 files changed, 29 insertions, 1 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index dc80db4..843faa7 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -34,6 +34,7 @@ builtinEnv = M.fromList [ ("_", makeNonsenseAST ASTHole), ("otherwise", makeNonsenseAST ASTHole), builtinFatal, + builtinKind, -- reserved keywords reservedKeyword "\\", reservedKeyword "let!", @@ -230,3 +231,10 @@ builtinFatal = (name, makeNonsenseAST $ ASTFunction False fn1) where throwL (astPos ast1) $ str fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + +builtinKind :: (String, AST) +builtinKind = (name, makeNonsenseAST $ ASTFunction True fn1) where + name = "kind" + fn1 AST { astNode = ASTRecord identifier _} = + return $ makeNonsenseAST $ ASTString identifier + fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 8c9178d..6e9e770 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -261,7 +261,6 @@ evaluateRecord asts = do makeFnCreate _ _ = error $ "unreachable: makeFnCreate " ++ fnCreateName - let namespacedFields = map (\name -> ns ++ "/" ++ name) fields let createFn = makeFnCreate fields [] insertThisEnv fnCreateName $ recordAst { astNode = ASTFunction True createFn } @@ -274,6 +273,17 @@ evaluateRecord asts = do makeGetFns restParams makeGetFns fields + + let makeSetFns [] = return $ () + makeSetFns (param:restParams) = do + let fnSetName = ns ++ "/" ++ "set-" ++ param + let fn = setFn fnSetName + let fnAST = makeNonsenseAST $ ASTFunction True $ fn + insertThisEnv fnSetName fnAST + makeSetFns restParams + + makeSetFns fields + return $ recordAst { astNode = ASTUnit } _ -> throwL (astPos recordAst) $ "invalid arguments passed to import!: " ++ show args @@ -292,6 +302,16 @@ evaluateRecord asts = do Just value -> return $ value Nothing -> error $ "unreachable: getFn " ++ fnName getFn fnName ast = throwL (astPos ast) $ "invalid argument passed to " ++ fnName ++ ": " ++ (show ast) + setFn fnName ast1 = do + return $ makeNonsenseAST $ ASTFunction True $ fn where + fn ast2@AST { astNode = ASTRecord identifier record } = do + when (not $ identifier `L.isPrefixOf` fnName) $ + throwL (astPos ast2) $ "invalid argument: " ++ fnName ++ " cannot operate on record " ++ identifier + let (_, fnId) = separateNsIdPart fnName + let fieldId = drop 4 fnId + let newRecord = M.insert fieldId ast1 record + return $ makeNonsenseAST $ ASTRecord identifier newRecord + fn ast2 = throwL (astPos ast2) $ "invalid argument passed to " ++ fnName ++ ": " ++ (show ast2) evaluateUserFunction :: [AST] -> LContext AST evaluateUserFunction children = do |