diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 12 | ||||
| -rw-r--r-- | src/Interpreter.hs | 34 | ||||
| -rw-r--r-- | src/Utils.hs | 2 |
3 files changed, 23 insertions, 25 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index ec70956..fb8ad7d 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -290,10 +290,10 @@ builtinReadFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where fn1 ast1 = throwL (astPos ast1, argError1 name ast1) builtinWriteFile :: (String, AST) -builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where +builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "write-file!" fn1 ast1@AST { an = ASTString filePath } = - return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where + return $ makeNonsenseAST $ ASTFunction Impure $ fn2 where fn2 AST { an = ASTString content } = do resultM <- liftIO $ safeWriteFile filePath content case resultM of @@ -303,10 +303,10 @@ builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where fn1 ast1 = throwL (astPos ast1, argError1 name ast1) builtinAppendFile :: (String, AST) -builtinAppendFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where +builtinAppendFile = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "append-file!" fn1 ast1@AST { an = ASTString filePath } = - return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where + return $ makeNonsenseAST $ ASTFunction Impure $ fn2 where fn2 AST { an = ASTString content } = do resultM <- liftIO $ safeAppendFile filePath content case resultM of @@ -334,11 +334,11 @@ builtinSortByFirst = (name, makeNonsenseAST $ ASTFunction Pure fn1) where fn1 ast1 = throwL (astPos ast1, argError1 name ast1) builtinTry :: (String, AST) -builtinTry = (name, makeNonsenseAST $ ASTFunction Impure fn1) where +builtinTry = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "try!" fn1 :: LFunction fn1 ast1@AST { an = ASTFunction Pure catchFn } = - return $ makeNonsenseAST $ ASTFunction Impure $ fn2 where + return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where fn2 ast2@AST { an = ASTFunction _ tryFn } = return $ makeNonsenseAST $ ASTFunction Impure $ fn3 where fn3 ast3 = do diff --git a/src/Interpreter.hs b/src/Interpreter.hs index b9c6a1c..9395ec1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -63,8 +63,8 @@ processLetExpr scope letExpr = do return $ (sym, val) : scope -foldUserFunctionLetExprs :: Scope -> AST -> [AST] -> LContext LFunction -foldUserFunctionLetExprs scope paramAst@AST { an = ASTSymbol param } exprs = return fn where +foldUserFunctionLetExprs :: Purity -> Scope -> AST -> [AST] -> LContext LFunction +foldUserFunctionLetExprs callingCtxPurity scope paramAst@AST { an = ASTSymbol param } exprs = return fn where fn :: LFunction fn arg = ret `catchError` appendError (astPos paramAst, "in a function definition") where ret = do @@ -76,33 +76,33 @@ foldUserFunctionLetExprs scope paramAst@AST { an = ASTSymbol param } exprs = ret let body = last exprs let newBody = foldScope localScope body - -- updatePurity callingCtxPurity + updatePurity callingCtxPurity evaluate newBody -foldUserFunctionLetExprs _ param exprs = throwL (astPos param, +foldUserFunctionLetExprs _ _ param exprs = throwL (astPos param, "unreachable: foldUserFunctionLetExprs, param: " ++ show param ++ ", exprs: " ++ show exprs) -foldUserFunctionParams :: Scope -> [AST] -> [AST] -> LContext LFunction -foldUserFunctionParams _ [] _ = +foldUserFunctionParams :: Purity -> Scope -> [AST] -> [AST] -> LContext LFunction +foldUserFunctionParams _ _ [] _ = throwL $ ("", "cannot define a function with zero parameters") -foldUserFunctionParams scope (param:[]) exprs = - foldUserFunctionLetExprs scope param exprs -foldUserFunctionParams scope (AST { an = ASTSymbol param }:rest) exprs = return fn where +foldUserFunctionParams callingCtxPurity scope (param:[]) exprs = + foldUserFunctionLetExprs callingCtxPurity scope param exprs +foldUserFunctionParams callingCtxPurity scope (AST { an = ASTSymbol param }:rest) exprs = return fn where fn :: LFunction fn arg = do let scopeWithCurrentArg = (param, arg) : scope - ret <- foldUserFunctionParams scopeWithCurrentArg rest exprs + ret <- foldUserFunctionParams callingCtxPurity scopeWithCurrentArg rest exprs -- The returned function AST will not have the correct position info or purity, but that's fine -- because the info is overridden in evaluateFunctionDef anyway. return $ makeNonsenseAST $ ASTFunction Pure ret -foldUserFunctionParams _ (param:_) _ = throwL (astPos $ param, +foldUserFunctionParams _ _ (param:_) _ = throwL (astPos $ param, "unreachable: foldUserFunctionParams, param: " ++ show param) -defineUserFunction :: [AST] -> [AST] -> LContext LFunction -defineUserFunction = foldUserFunctionParams [] +defineUserFunction :: Purity -> [AST] -> [AST] -> LContext LFunction +defineUserFunction callingCtxPurity = foldUserFunctionParams callingCtxPurity [] evaluateFunctionDef :: Purity -> [AST] -> LContext AST -evaluateFunctionDef isPure asts = do +evaluateFunctionDef fPurity asts = do let defAst = head asts args = tail asts (params'', exprs) <- case args of @@ -130,8 +130,8 @@ evaluateFunctionDef isPure asts = do "non-let expression in function definition before body: " ++ show nonLetExpr) Nothing -> return () - fn <- defineUserFunction params exprs - return $ defAst { an = ASTFunction isPure fn } + fn <- defineUserFunction fPurity params exprs + return $ defAst { an = ASTFunction fPurity fn } where isLetAST AST { an = ASTFunctionCall (AST { an = ASTSymbol "let" }:_) } = True isLetAST _ = False @@ -355,7 +355,6 @@ evaluateFunctionCall children = do AST { an = astFn@(ASTFunction fPurity _) } <- assertIsASTFunction evaledBound checkPurity fPurity - updatePurity fPurity evaledArgs <- mapM evaluate args result <- curryCall (reverse evaledArgs) astFn @@ -372,7 +371,6 @@ evaluateFunctionCall children = do AST { an = astFn@(ASTFunction fPurity _) } <- assertIsASTFunction evaledBound checkPurity fPurity - updatePurity fPurity result <- curryCall (reverse evaledArgs) astFn diff --git a/src/Utils.hs b/src/Utils.hs index 2561969..379740d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -123,7 +123,7 @@ instance (Eq Token) where instance (Show Token) where show token = show $ tokenContent token -data Purity = Pure | Impure deriving Eq +data Purity = Pure | Impure deriving (Eq, Show) type LFunction = AST -> LContext AST type LRecord = M.Map String AST |