diff options
| -rw-r--r-- | TODO.txt | 1 | ||||
| -rw-r--r-- | core/common.milch | 7 | ||||
| -rw-r--r-- | core/result.milch | 7 | ||||
| -rw-r--r-- | examples/impure-concept.milch | 2 | ||||
| -rw-r--r-- | examples/try.milch | 11 | ||||
| -rw-r--r-- | src/Builtins.hs | 12 | ||||
| -rw-r--r-- | src/Interpreter.hs | 34 | ||||
| -rw-r--r-- | src/Utils.hs | 2 |
8 files changed, 46 insertions, 30 deletions
@@ -1,4 +1,3 @@ -fix impure context issues add a `do` builtin that runs given exprs and returns the result of the last one add an atom/cell/box data type for storing mutable state write tests diff --git a/core/common.milch b/core/common.milch index cddf02f..2dc6698 100644 --- a/core/common.milch +++ b/core/common.milch @@ -1,8 +1,11 @@ ;; Control flow ;;;;;;;;;;;;;;;;;;;;;;;;; -(let . (\[f g] - (\[x] (f (g x))))) +; function composition +(let . (\[f g x] (f (g x)))) + +; impure version of . +(let .! (\![f g x] (f (g x)))) (let flow (\[fs] (foldr . id (reverse fs)))) diff --git a/core/result.milch b/core/result.milch index f122ee6..903ca38 100644 --- a/core/result.milch +++ b/core/result.milch @@ -1,3 +1,5 @@ +(import "core/common") + (record Result/Ok value) (record Result/Ex value) @@ -23,3 +25,8 @@ (match (kind m) :Result/Ok (Result/Ok/get-value m) :Result/Ex (catch-f (Result/Ex/get-value m))))) + +; converts the given impure function that can throw a fatal error +; to an impure function that returns a Result +(let Result/safe! (\![fn! arg] + (try! Result/ex (.! Result/ok fn!) arg))) diff --git a/examples/impure-concept.milch b/examples/impure-concept.milch index 0a9af05..bf4f63b 100644 --- a/examples/impure-concept.milch +++ b/examples/impure-concept.milch @@ -24,4 +24,4 @@ ; error: cannot call impure function in pure context ; when calling function g! at examples/impure-concept.milch:21:14 ; in a function definition at examples/impure-concept.milch:21:11 -; when calling function h at examples/impure-concept.milch:23:1
\ No newline at end of file +; when calling function h at examples/impure-concept.milch:23:1 diff --git a/examples/try.milch b/examples/try.milch index 68d6cc2..561e716 100644 --- a/examples/try.milch +++ b/examples/try.milch @@ -1,6 +1,15 @@ (import "core/common") (import "core/result") +(let safe-read-file! (Result/safe! read-file!)) + ; calls read-file! and wraps the result in a Result/ok on success ; in case of error, calls Result/ex on the error string -(try! Result/ex (. Result/ok read-file!) "does-not-exist.txt") +(safe-read-file! "does-not-exist.txt") +(try! Result/ex (.! Result/ok read-file!) "examples/aoc22_1.txt") + +(let pure-fn (\[x] + (concat "foo" x))) + +(print! (pure-fn "bar\n")) +(print! "nice\n") 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 |