Implement purity checking

1 files changed, 37 insertions, 33 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