1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Builtins where
import qualified Data.Map as M
import Control.Monad.Except
import Utils
builtinEnv :: Env
builtinEnv = M.fromList [
builtinAdd2,
builtinSubtract2,
builtinMultiply2,
builtinDivide2,
builtinHead,
builtinTail,
builtinPrepend,
builtinPrint,
builtinConcat
]
argError1 :: Show a => String -> a -> String
argError1 fn 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
-- BUILTINS
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 :: (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 :: (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 :: (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 :: (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 :: (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 :: (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 :: (String, AST)
builtinPrint = (name, ASTFunction outer) where
name = "print!"
outer _ (ASTString str) =
do liftIO $ putStr $ str
return ASTUnit
outer _ ast = throwL $ argError1 name ast
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
|
