From bba047ae945ae7d7899d6e2c1610923bcedb0442 Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Mon, 5 Dec 2022 12:42:21 +0200 Subject: Implement purity checking --- src/Builtins.hs | 70 ++++++++++++++++++++++++++++++--------------------------- 1 file changed, 37 insertions(+), 33 deletions(-) (limited to 'src/Builtins.hs') 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 -- cgit v1.3