aboutsummaryrefslogtreecommitdiffstats
path: root/src/Builtins.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Builtins.hs')
-rw-r--r--src/Builtins.hs165
1 files changed, 83 insertions, 82 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs
index 2dac829..f8d1567 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -30,14 +30,14 @@ builtinEnv = M.fromList [
builtinConcat,
-- special
builtinPrint,
- ("unit", ASTUnit),
- ("_", ASTHole),
- ("otherwise", ASTHole),
+ ("unit", makeNonsenseAST ASTUnit),
+ ("_", makeNonsenseAST ASTHole),
+ ("otherwise", makeNonsenseAST ASTHole),
builtinFatal
]
-argError1 :: Show a => String -> a -> String
-argError1 fn arg = "invalid argument to " ++ fn ++ ": " ++ show arg
+argError1 :: String -> AST -> String
+argError1 fn arg = pos arg ++ ": invalid argument to " ++ fn ++ ": " ++ show arg
argError2 :: (Show a1, Show a2) => String -> a1 -> a2 -> String
argError2 fn arg1 arg2 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2
@@ -48,100 +48,101 @@ argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1
-- BUILTINS
builtinAdd2 :: (String, AST)
-builtinAdd2 = (name, ASTFunction fn1) where
+builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "+"
- fn1 _ ast1@(ASTInteger a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTInteger b) =
- return $ ASTInteger $ a + b
+ fn1 _ ast1@AST { astNode = ASTInteger a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTInteger b } =
+ return $ makeNonsenseAST $ ASTInteger $ a + b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
- fn1 _ ast1@(ASTDouble a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTDouble b) =
- return $ ASTDouble $ a + b
+ fn1 _ ast1@AST { astNode = ASTDouble a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTDouble b } =
+ return $ makeNonsenseAST $ ASTDouble $ a + b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
builtinSubtract2 :: (String, AST)
-builtinSubtract2 = (name, ASTFunction fn1) where
+builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "-"
- fn1 _ ast1@(ASTInteger a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTInteger b) =
- return $ ASTInteger $ a - b
+ fn1 _ ast1@AST { astNode = ASTInteger a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTInteger b } =
+ return $ makeNonsenseAST $ ASTInteger $ a - b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
- fn1 _ ast1@(ASTDouble a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTDouble b) =
- return $ ASTDouble $ a - b
+ fn1 _ ast1@AST { astNode = ASTDouble a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTDouble b } =
+ return $ makeNonsenseAST $ ASTDouble $ a - b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
builtinMultiply2 :: (String, AST)
-builtinMultiply2 = (name, ASTFunction fn1) where
+builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "*"
- fn1 _ ast1@(ASTInteger a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTInteger b) =
- return $ ASTInteger $ a * b
+ fn1 _ ast1@AST { astNode = ASTInteger a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTInteger b } =
+ return $ makeNonsenseAST $ ASTInteger $ a * b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
- fn1 _ ast1@(ASTDouble a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTDouble b) =
- return $ ASTDouble $ a * b
+ fn1 _ ast1@AST { astNode = ASTDouble a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTDouble b } =
+ return $ makeNonsenseAST $ ASTDouble $ a * b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
builtinDivide2 :: (String, AST)
-builtinDivide2 = (name, ASTFunction fn1) where
+builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "/"
- fn1 _ ast1@(ASTInteger a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTInteger b) =
+ fn1 _ ast1@AST { astNode = ASTInteger a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTInteger b } =
do when (b == 0) $ throwL $ "division by zero"
- return $ ASTInteger $ a `div` b
+ return $ makeNonsenseAST $ ASTInteger $ a `div` b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
- fn1 _ ast1@(ASTDouble a) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTDouble b) =
+ fn1 _ ast1@AST { astNode = ASTDouble a } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTDouble b } =
do when (b == 0) $ throwL $ "division by zero"
- return $ ASTDouble $ a / b
+ return $ makeNonsenseAST $ ASTDouble $ a / b
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
builtinEq2 :: (String, AST)
-builtinEq2 = (name, ASTFunction fn1) where
+builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "eq?"
fn1 _ ast1 =
- return $ ASTFunction $ fn2 where
- fn2 _ ast2 = return $ ASTBoolean $ ast1 == ast2
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
builtinLt2 :: (String, AST)
-builtinLt2 = (name, ASTFunction fn1) where
+builtinLt2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "lt?"
fn1 _ ast1 =
- return $ ASTFunction $ fn2 where
- fn2 _ ast2 = return $ ASTBoolean $ ast1 <= ast2
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2
builtinFloor :: (String, AST)
-builtinFloor = (name, ASTFunction fn1) where
+builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "floor"
- fn1 _ (ASTDouble dbl) = return $ ASTInteger $ floor dbl
+ fn1 _ AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
fn1 _ ast = throwL $ argError1 name ast
builtinToDouble :: (String, AST)
-builtinToDouble = (name, ASTFunction fn1) where
+builtinToDouble = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "to-double"
- fn1 _ (ASTInteger int) = return $ ASTDouble $ fromIntegral int
+ fn1 _ AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
fn1 _ ast = throwL $ argError1 name ast
builtinFmt :: (String, AST)
-builtinFmt = (name, ASTFunction fn1) where
+builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "fmt"
- fn1 _ ast1@(ASTString str) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTVector replacements) =
- return $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
+ fn1 _ ast1@AST { astNode = ASTString str } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTVector replacements } =
+ return $ makeNonsenseAST $ ASTString $
+ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
replaceAll _ [] text = text
@@ -150,65 +151,65 @@ builtinFmt = (name, ASTFunction fn1) where
in replaceAll (n + 1) xs text'
builtinHead :: (String, AST)
-builtinHead = (name, ASTFunction fn1) where
+builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "head"
- fn1 _ (ASTVector vec) =
+ fn1 _ AST { astNode = ASTVector vec } =
do when (length vec == 0) $ throwL $ name ++ " of empty vector"
return $ head vec
fn1 _ ast = throwL $ argError1 name ast
builtinTail :: (String, AST)
-builtinTail = (name, ASTFunction fn1) where
+builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "tail"
- fn1 _ (ASTVector vec) =
+ fn1 _ AST { astNode = ASTVector vec } =
do when (length vec == 0) $ throwL $ name ++ " of empty vector"
- return $ ASTVector $ tail vec
+ return $ makeNonsenseAST $ ASTVector $ tail vec
fn1 _ ast = throwL $ argError1 name ast
builtinSubstr :: (String, AST)
-builtinSubstr = (name, ASTFunction fn1) where
+builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "substr"
- fn1 _ ast1@(ASTInteger at) =
- return $ ASTFunction $ fn2 where
- fn2 _ ast2@(ASTInteger len) =
- return $ ASTFunction $ fn3 where
- fn3 _ (ASTString str) =
- return $ ASTString $ drop at .> take len $ str
+ fn1 _ ast1@AST { astNode = ASTInteger at } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ ast2@AST { astNode = ASTInteger len } =
+ return $ makeNonsenseAST $ ASTFunction $ fn3 where
+ fn3 _ AST { astNode = ASTString str } =
+ return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str
fn3 _ ast3 = throwL $ argError3 name ast1 ast2 ast3
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
builtinPrepend :: (String, AST)
-builtinPrepend = (name, ASTFunction fn1) where
+builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "prepend"
fn1 _ ast1 =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTVector vec) =
- return $ ASTVector $ ast1 : vec
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTVector vec } =
+ return $ makeNonsenseAST $ ASTVector $ ast1 : vec
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
builtinPrint :: (String, AST)
-builtinPrint = (name, ASTFunction fn1) where
+builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "print!"
- fn1 _ (ASTString str) =
+ fn1 _ AST { astNode = ASTString str } =
do liftIO $ putStr $ str
- return ASTUnit
+ return $ makeNonsenseAST ASTUnit
fn1 _ ast = throwL $ argError1 name ast
builtinConcat :: (String, AST)
-builtinConcat = (name, ASTFunction fn1) where
+builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "concat"
- fn1 _ ast1@(ASTString str1) =
- return $ ASTFunction $ fn2 where
- fn2 _ (ASTString str2) =
- return $ ASTString $ str1 ++ str2
+ fn1 _ ast1@AST { astNode = ASTString str1 } =
+ return $ makeNonsenseAST $ ASTFunction $ fn2 where
+ fn2 _ AST { astNode = ASTString str2 } =
+ return $ makeNonsenseAST $ ASTString $ str1 ++ str2
fn2 _ ast2 = throwL $ argError2 name ast1 ast2
fn1 _ ast1 = throwL $ argError1 name ast1
builtinFatal :: (String, AST)
-builtinFatal = (name, ASTFunction fn1) where
+builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "fatal"
- fn1 _ (ASTString str) =
+ fn1 _ AST { astNode = ASTString str } =
throwL $ str
fn1 _ ast =
throwL $ argError1 name ast

Want to contribute? Host your changes somewhere and send me the link: jan (at) sydanviita.fi. Also, check out my website.


forge.jan.systems — powered by cgit