From 367cefd18ba6c96c9753e69a19db84ce50f34abf Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Mon, 26 Sep 2022 15:37:04 +0300 Subject: Refactor builtins --- src/Builtins.hs | 194 ++++++++++++++++++++++++++++++-------------------------- 1 file changed, 105 insertions(+), 89 deletions(-) (limited to 'src/Builtins.hs') diff --git a/src/Builtins.hs b/src/Builtins.hs index 32986e6..60fef75 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -7,15 +7,15 @@ import Utils builtinEnv :: Env builtinEnv = M.fromList [ - ("+", builtinAdd2), - ("-", builtinSubtract2), - ("*", builtinMultiply2), - ("/", builtinDivide2), - ("head", builtinHead), - ("tail", builtinTail), - ("prepend", builtinPrepend), - ("print!", builtinPrint), - ("string-concat", builtinStringConcat2) + builtinAdd2, + builtinSubtract2, + builtinMultiply2, + builtinDivide2, + builtinHead, + builtinTail, + builtinPrepend, + builtinPrint, + builtinConcat ] argError1 :: Show a => String -> a -> String @@ -26,91 +26,107 @@ argError2 fn arg1 arg2 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ " -- BUILTINS -builtinAdd2 :: AST -builtinAdd2 = - let outer _ ast1@(ASTInteger a) = do - let inner _ (ASTInteger b) = - return $ ASTInteger $ a + b - inner _ ast2 = throwL $ argError2 "+" ast1 ast2 - return $ ASTFunction $ inner - outer _ ast1@(ASTDouble a) = do - let inner _ (ASTDouble b) = - return $ ASTDouble $ a + b - inner _ ast2 = throwL $ argError2 "+" ast1 ast2 - return $ ASTFunction $ inner - outer _ ast1 = throwL $ argError1 "+" ast1 - in ASTFunction outer +builtinAdd2 :: (String, AST) +builtinAdd2 = (name, ASTFunction outer) where + name = "+" + outer _ ast1@(ASTInteger a) = + return $ ASTFunction $ inner where + inner _ (ASTInteger b) = + return $ ASTInteger $ a + b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1@(ASTDouble a) = + return $ ASTFunction $ inner where + inner _ (ASTDouble b) = + return $ ASTDouble $ a + b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1 = throwL $ argError1 name ast1 -builtinSubtract2 :: AST -builtinSubtract2 = - let outer _ ast1 = do - (ASTInteger a) <- assertIsASTInteger ast1 - let inner _ ast2 = do - (ASTInteger b) <- assertIsASTInteger ast2 - return $ ASTInteger $ a - b - return $ ASTFunction $ inner - in ASTFunction outer +builtinSubtract2 :: (String, AST) +builtinSubtract2 = (name, ASTFunction outer) where + name = "-" + outer _ ast1@(ASTInteger a) = + return $ ASTFunction $ inner where + inner _ (ASTInteger b) = + return $ ASTInteger $ a - b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1@(ASTDouble a) = + return $ ASTFunction $ inner where + inner _ (ASTDouble b) = + return $ ASTDouble $ a - b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1 = throwL $ argError1 name ast1 -builtinMultiply2 :: AST -builtinMultiply2 = - let outer _ ast1 = do - (ASTInteger a) <- assertIsASTInteger ast1 - let inner _ ast2 = do - (ASTInteger b) <- assertIsASTInteger ast2 - return $ ASTInteger $ a * b - return $ ASTFunction $ inner - in ASTFunction outer +builtinMultiply2 :: (String, AST) +builtinMultiply2 = (name, ASTFunction outer) where + name = "*" + outer _ ast1@(ASTInteger a) = + return $ ASTFunction $ inner where + inner _ (ASTInteger b) = + return $ ASTInteger $ a * b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1@(ASTDouble a) = + return $ ASTFunction $ inner where + inner _ (ASTDouble b) = + return $ ASTDouble $ a * b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1 = throwL $ argError1 name ast1 -builtinDivide2 :: AST -builtinDivide2 = - let outer _ ast1 = do - (ASTInteger a) <- assertIsASTInteger ast1 - let inner _ ast2 = do - (ASTInteger b) <- assertIsASTInteger ast2 - when (b == 0) $ throwL $ "division by zero" - return $ ASTInteger $ a `div` b - return $ ASTFunction $ inner - in ASTFunction outer +builtinDivide2 :: (String, AST) +builtinDivide2 = (name, ASTFunction outer) where + name = "/" + outer _ ast1@(ASTInteger a) = + return $ ASTFunction $ inner where + inner _ (ASTInteger b) = + do when (b == 0) $ throwL $ "division by zero" + return $ ASTInteger $ a `div` b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1@(ASTDouble a) = + return $ ASTFunction $ inner where + inner _ (ASTDouble b) = + do when (b == 0) $ throwL $ "division by zero" + return $ ASTDouble $ a / b + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1 = throwL $ argError1 name ast1 -builtinHead :: AST -builtinHead = - let outer _ ast = do - (ASTVector vec) <- assertIsASTVector ast - when (length vec == 0) $ throwL $ "head of empty vector" - return $ head vec - in ASTFunction outer +builtinHead :: (String, AST) +builtinHead = (name, ASTFunction outer) where + name = "head" + outer _ (ASTVector vec) = + do when (length vec == 0) $ throwL $ name ++ " of empty vector" + return $ head vec + outer _ ast = throwL $ argError1 name ast -builtinTail :: AST -builtinTail = - let outer _ ast = do - (ASTVector vec) <- assertIsASTVector ast - when (length vec == 0) $ throwL $ "tail of empty vector" - return $ ASTVector $ tail vec - in ASTFunction outer +builtinTail :: (String, AST) +builtinTail = (name, ASTFunction outer) where + name = "tail" + outer _ (ASTVector vec) = + do when (length vec == 0) $ throwL $ name ++ " of empty vector" + return $ ASTVector $ tail vec + outer _ ast = throwL $ argError1 name ast -builtinPrepend :: AST -builtinPrepend = - let outer _ ast1 = do - let inner _ ast2 = do - (ASTVector vec) <- assertIsASTVector ast2 - return $ ASTVector $ ast1 : vec - return $ ASTFunction $ inner - in ASTFunction outer +builtinPrepend :: (String, AST) +builtinPrepend = (name, ASTFunction outer) where + name = "prepend" + outer _ ast1 = + return $ ASTFunction $ inner where + inner _ (ASTVector vec) = + return $ ASTVector $ ast1 : vec + inner _ ast2 = throwL $ argError2 name ast1 ast2 -builtinPrint :: AST -builtinPrint = - let outer _ ast = - do (ASTString str) <- assertIsASTString ast - liftIO $ putStr $ str - return ASTUnit - in ASTFunction outer +builtinPrint :: (String, AST) +builtinPrint = (name, ASTFunction outer) where + name = "print!" + outer _ (ASTString str) = + do liftIO $ putStr $ str + return ASTUnit + outer _ ast = throwL $ argError1 name ast -builtinStringConcat2 :: AST -builtinStringConcat2 = - let outer _ ast1 = do - (ASTString str1) <- assertIsASTString ast1 - let inner _ ast2 = do - (ASTString str2) <- assertIsASTString ast2 - return $ ASTString $ str1 ++ str2 - return $ ASTFunction $ inner - in ASTFunction outer +builtinConcat :: (String, AST) +builtinConcat = (name, ASTFunction outer) where + name = "concat" + outer _ ast1@(ASTString str1) = + return $ ASTFunction $ inner where + inner _ (ASTString str2) = + return $ ASTString $ str1 ++ str2 + inner _ ast2 = throwL $ argError2 name ast1 ast2 + outer _ ast1 = throwL $ argError1 name ast1 -- cgit v1.3