Implement purity checking

4 files changed, 116 insertions, 59 deletions

diff --git a/src/Builtins.hs b/src/Builtins.hs
index 9fe8f21..e56d00d 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -54,67 +54,67 @@ argError3 fn arg1 arg2 arg3 =
     "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3
 
 reservedKeyword :: String -> (String, AST)
-reservedKeyword name = (name, makeNonsenseAST $ ASTFunction fn1) where
+reservedKeyword name = (name, makeNonsenseAST $ ASTFunction True fn1) where
     fn1 ast1 = throwL (astPos ast1) $ "unreachable: " ++ name ++ " is a reserved word"
 
 -- BUILTINS
 
 builtinAdd2 :: (String, AST)
-builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinAdd2 = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "+"
     fn1 ast1@AST { astNode = ASTInteger a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTInteger b } =
                 return $ makeNonsenseAST $ ASTInteger $ a + b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1@AST { astNode = ASTDouble a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTDouble b } =
                 return $ makeNonsenseAST $ ASTDouble $ a + b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinSubtract2 :: (String, AST)
-builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "-"
     fn1 ast1@AST { astNode = ASTInteger a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTInteger b } =
                 return $ makeNonsenseAST $ ASTInteger $ a - b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1@AST { astNode = ASTDouble a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTDouble b } =
                 return $ makeNonsenseAST $ ASTDouble $ a - b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinMultiply2 :: (String, AST)
-builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "*"
     fn1 ast1@AST { astNode = ASTInteger a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTInteger b } =
                 return $ makeNonsenseAST $ ASTInteger $ a * b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1@AST { astNode = ASTDouble a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTDouble b } =
                 return $ makeNonsenseAST $ ASTDouble $ a * b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinDivide2 :: (String, AST)
-builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinDivide2 = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "/"
     fn1 ast1@AST { astNode = ASTInteger a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 ast2@AST { astNode = ASTInteger b } =
              do when (b == 0) $ throwL (astPos ast2) $ "division by zero"
                 return $ makeNonsenseAST $ ASTInteger $ a `div` b
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1@AST { astNode = ASTDouble a } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 ast2@AST { astNode = ASTDouble b } =
              do when (b == 0) $ throwL (astPos ast2) $ "division by zero"
                 return $ makeNonsenseAST $ ASTDouble $ a / b
@@ -122,48 +122,52 @@ builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinEq2 :: (String, AST)
-builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinEq2 = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "eq?"
     fn1 ast1 =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
 
 builtinLt2 :: (String, AST)
-builtinLt2 = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinLt2 = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "lt?"
     fn1 ast1 =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2
 
 builtinFloor :: (String, AST)
-builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinFloor = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "floor"
     fn1 AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinToDouble :: (String, AST)
-builtinToDouble = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinToDouble = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "to-double"
     fn1 AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinFmt :: (String, AST)
-builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinFmt = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "fmt"
     fn1 ast1@AST { astNode = ASTString str } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTVector replacements } =
                 return $ makeNonsenseAST $ ASTString $
                     T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
+    replaceAll :: Int -> [AST] -> T.Text -> T.Text
     replaceAll _ [] text = text
     replaceAll n (x:xs) text =
-        let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
+        let xRepr = case x of
+                AST { astNode = ASTString s } -> s
+                _ -> show x
+            text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ xRepr) text
          in replaceAll (n + 1) xs text'
 
 builtinHead :: (String, AST)
-builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinHead = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "head"
     fn1 ast1@AST { astNode = ASTVector vec } =
      do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector"
@@ -171,7 +175,7 @@ builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinTail :: (String, AST)
-builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinTail = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "tail"
     fn1 ast1@AST { astNode = ASTVector vec } =
      do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector"
@@ -179,12 +183,12 @@ builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinSubstr :: (String, AST)
-builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinSubstr = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "substr"
     fn1 ast1@AST { astNode = ASTInteger at } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 ast2@AST { astNode = ASTInteger len } =
-                return $ makeNonsenseAST $ ASTFunction $ fn3 where
+                return $ makeNonsenseAST $ ASTFunction True $ fn3 where
                     fn3 AST { astNode = ASTString str } =
                         return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str
                     fn3 ast3 = throwL (astPos ast3) $ argError3 name ast1 ast2 ast3
@@ -192,16 +196,16 @@ builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinPrepend :: (String, AST)
-builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinPrepend = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "prepend"
     fn1 ast1 =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTVector vec } =
                 return $ makeNonsenseAST $ ASTVector $ ast1 : vec
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
 
 builtinPrint :: (String, AST)
-builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinPrint = (name, makeNonsenseAST $ ASTFunction False fn1) where
     name = "print!"
     fn1 AST { astNode = ASTString str } =
      do liftIO $ putStr $ str
@@ -209,17 +213,17 @@ builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinConcat :: (String, AST)
-builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinConcat = (name, makeNonsenseAST $ ASTFunction True fn1) where
     name = "concat"
     fn1 ast1@AST { astNode = ASTString str1 } =
-        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+        return $ makeNonsenseAST $ ASTFunction True $ fn2 where
             fn2 AST { astNode = ASTString str2 } =
                 return $ makeNonsenseAST $ ASTString $ str1 ++ str2
             fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
     fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
 
 builtinFatal :: (String, AST)
-builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where
+builtinFatal = (name, makeNonsenseAST $ ASTFunction False fn1) where
     name = "fatal!"
     fn1 ast1@AST { astNode = ASTString str } =
         throwL (astPos ast1) $ str
diff --git a/src/Interpreter.hs b/src/Interpreter.hs
index ce68270..aefd816 100644
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@@ -18,18 +18,30 @@ import Builtins
 import Tokenizer ( tokenize' )
 import Parser ( parse )
 
-_curryCall :: [AST] -> LFunction -> LContext AST
-_curryCall [] f = return $ (makeNonsenseAST $ ASTFunction f)
-_curryCall (arg:[]) f = f arg
-_curryCall (arg:rest) f = do
-    g <- _curryCall rest f
+-- _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
+    f (makeNonsenseAST ASTUnit)
+curryCall (arg:[]) (ASTFunction fIsPure f) = do
+    checkPurity fIsPure
+    f arg
+curryCall (arg:rest) f = do
+    g <- curryCall rest f
     case astNode g of
-        ASTFunction f' -> f' arg
+        ASTFunction fIsPure f' -> do
+            checkPurity fIsPure
+            f' arg
         other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function"
-
-curryCall :: [AST] -> LFunction -> LContext AST
-curryCall [] f = f (makeNonsenseAST ASTUnit)
-curryCall args f = _curryCall args f
+curryCall _ astFn = throwL "" $ "unreachable: curryCall, astFn: " ++ show astFn
 
 traverseAndReplace :: String -> AST -> AST -> AST
 traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym }
@@ -96,20 +108,22 @@ defineUserFunctionWithLetExprs (AST { astNode = ASTSymbol param }:rest) exprs =
     fn arg = do
         let newExprs = map (traverseAndReplace param arg) exprs
         ret <- defineUserFunctionWithLetExprs rest newExprs
-        -- the returned AST will not have the correct position info, but that's fine
-        -- because the info is overridden in evaluateFunctionDef anyway
-        return $ makeNonsenseAST $ ASTFunction $ ret
+        -- The returned AST will not have the correct position info, but that's fine
+        -- because the info is overridden in evaluateFunctionDef anyway.
+        -- Also, functions are naively considered pure here, but that's also fine
+        -- because purity too is overridden in evaluateFunctionDef.
+        return $ makeNonsenseAST $ ASTFunction True ret
 defineUserFunctionWithLetExprs (param:_) _ = throwL (astPos $ param)
     $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param
 
-evaluateFunctionDef :: [AST] -> LContext AST
-evaluateFunctionDef asts = do
+evaluateFunctionDef :: Bool -> [AST] -> LContext AST
+evaluateFunctionDef isPure asts = do
     let defAst = head asts
         args = tail asts
     (params'', exprs) <- case args of
         args'
             | length args' < 2 ->
-                throwL (astPos defAst) $ "\\ called with " ++ show (length args) ++ " arguments"
+                throwL (astPos defAst) $ "\\ or \\! called with " ++ show (length args) ++ " arguments"
             | otherwise -> return $ (head args', tail args')
 
     AST { astNode = ASTVector params' } <- assertIsASTVector params''
@@ -132,7 +146,7 @@ evaluateFunctionDef asts = do
         Nothing -> return ()
 
     fn <- defineUserFunctionWithLetExprs params exprs
-    return $ defAst { astNode = ASTFunction fn }
+    return $ defAst { astNode = ASTFunction isPure fn }
     where
         isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True
         isLetAST _ = False
@@ -209,7 +223,8 @@ evaluateImport asts = do
     let initialState = LState {
         stateConfig = config,
         stateDepth = 0,
-        stateEnv = emptyEnv { envImported = builtinEnv }
+        stateEnv = emptyEnv { envImported = builtinEnv },
+        statePure = False
     }
     case args of
         -- non-qualified import
@@ -229,11 +244,15 @@ evaluateUserFunction children = do
     let fnAst = head children
         args = tail children
     fnEvaled <- evaluate fnAst
-    AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled
+    AST { astNode = astFn@(ASTFunction fIsPure _) } <- assertIsASTFunction fnEvaled
+
+    checkPurity fIsPure
+    updatePurity fIsPure
+
     evaledArgs <- mapM evaluate args
     doubleEvaledArgs <- mapM evaluate evaledArgs
 
-    result <- curryCall (reverse doubleEvaledArgs) fn
+    result <- curryCall (reverse doubleEvaledArgs) astFn
 
     -- todo: maybe remove double eval here? can't remember why it was added
     return $ fnAst { astNode = astNode result }
@@ -261,10 +280,15 @@ evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } =
      do config <- getConfig
         when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc
         incrementDepth
+
+        currentPurity <- getPurity
+
         let task = case astNode x of
             -- remember to add these as reseved keywords in Builtins!
                 ASTSymbol "\\" ->
-                    evaluateFunctionDef args
+                    evaluateFunctionDef True args
+                ASTSymbol "\\!" ->
+                    evaluateFunctionDef False args
                 ASTSymbol "match" ->
                     evaluateMatch args
                 ASTSymbol "let!" ->
@@ -278,7 +302,10 @@ evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } =
 
         ret <- task `catchError`
             appendError ("when calling function " ++ show x ++ " at " ++ astPos ast)
+
         decrementDepth
+        updatePurity currentPurity
+
         return ret
 evaluate ast@AST { astNode = (ASTSymbol _) } =
     evaluateSymbol ast
diff --git a/src/Tokenizer.hs b/src/Tokenizer.hs
index b38e568..96a1c5a 100644
--- a/src/Tokenizer.hs
+++ b/src/Tokenizer.hs
@@ -65,7 +65,7 @@ _tokenize fileName acc current (x:xs)
                 tokenColumn = tColumn $ head cur,
                 tokenFileName = fileName }
          in _tokenize fileName (token : acc) [] xs
-    | tChar x `elem` ['(', ')', '[', ']', '{', '}', '\\'] =
+    | tChar x `elem` ['(', ')', '[', ']', '{', '}'] =
         let cur = reverse current
             token1 = Token {
                 tokenContent = [tChar x],
diff --git a/src/Utils.hs b/src/Utils.hs
index c215b2e..0cc17bd 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -38,7 +38,8 @@ emptyEnv = Env {
 data LState = LState {
     stateConfig :: Config,
     stateEnv :: Env,
-    stateDepth :: Int
+    stateDepth :: Int,
+    statePure :: LIsPure
 }
 
 type LineNo = Int
@@ -91,6 +92,28 @@ getDepth = do
     s <- get
     return $ stateDepth s
 
+getPurity :: LContext LIsPure
+getPurity = do
+    s <- get
+    return $ statePure s
+
+isAllowedPurity :: LIsPure -> LContext Bool
+isAllowedPurity purity = do
+    s <- get
+    let currentPurity = statePure s
+    return $ case currentPurity of
+        False -> True -- if currently in impure context (false), all calls are ok
+        True -> purity == True -- but if in pure context (true), only pure calls are ok
+
+updatePurity :: LIsPure -> LContext ()
+updatePurity purity = do
+    modify (\s -> s { statePure = purity })
+
+checkPurity :: LIsPure -> LContext ()
+checkPurity purity = do
+    purityOk <- isAllowedPurity purity
+    when (not purityOk) $ throwL "" $ "cannot call impure function in pure context"
+
 data Token = Token {
     tokenContent :: String,
     tokenRow :: Int,
@@ -104,6 +127,7 @@ instance (Eq Token) where
 instance (Show Token) where
     show token = show $ tokenContent token
 
+type LIsPure = Bool
 type LFunction = AST -> LContext AST
 
 data ASTNode
@@ -115,7 +139,7 @@ data ASTNode
     | ASTVector [AST]
     | ASTFunctionCall [AST]
     | ASTHashMap (M.Map AST AST)
-    | ASTFunction LFunction
+    | ASTFunction LIsPure LFunction
     | ASTUnit
     | ASTHole
 
@@ -140,7 +164,9 @@ instance (Show ASTNode) where
     show (ASTHashMap m) =
         let flattenMap = M.assocs .> L.concatMap (\(k, v) -> [k, v])
          in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}"
-    show (ASTFunction _) = "<fn>"
+    show (ASTFunction isPure _) = case isPure of
+        True -> "<pure fn>"
+        False -> "<impure fn>"
     show ASTUnit = "<unit>"
     show ASTHole = "<hole>"
 
@@ -180,7 +206,7 @@ instance (Ord ASTNode) where
 
 assertIsASTFunction :: AST -> LContext AST
 assertIsASTFunction ast@(AST { astNode = node }) = case node of
-    (ASTFunction _) -> return ast
+    (ASTFunction _ _) -> return ast
     _ -> throwL (astPos ast) $ show node ++ " is not a function"
 
 assertIsASTInteger :: AST -> LContext AST