Fix purity issue

8 files changed, 46 insertions, 30 deletions

diff --git a/TODO.txt b/TODO.txt
index 808a4aa..72f656f 100644
--- a/TODO.txt
+++ b/TODO.txt
@@ -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