aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Operators.hs58
-rw-r--r--tests/Properties.hs4
2 files changed, 47 insertions, 15 deletions
diff --git a/src/Operators.hs b/src/Operators.hs
index 051655a..c5812ea 100644
--- a/src/Operators.hs
+++ b/src/Operators.hs
@@ -9,19 +9,23 @@ import Parser
9primitives :: [(String, [Expr] -> LispResult Expr)] 9primitives :: [(String, [Expr] -> LispResult Expr)]
10primitives = map (\(n, f) -> (n, f n)) 10primitives = map (\(n, f) -> (n, f n))
11 [ 11 [
12 ("+" , arithmetic (+)) 12 ("+", arithmetic (+))
13 , ("-" , arithmetic (-)) 13 , ("-", arithmetic (-))
14 , ("*" , arithmetic (*)) 14 , ("*", arithmetic (*))
15 , ("/" , arithmetic (/)) 15 , ("/", arithmetic (/))
16 , (">" , comparator (>)) 16 , (">", comparator (>))
17 , ("<" , comparator (<)) 17 , ("<", comparator (<))
18 , (">=" , comparator (>=)) 18 , (">=", comparator (>=))
19 , ("<=" , comparator (<=)) 19 , ("<=", comparator (<=))
20 , ("=" , comparator (==)) 20 , ("=" , comparator (==))
21 , ("!=" , comparator (/=)) 21 , ("!=" , comparator (/=))
22 , ("not" , unaryBool not) 22 , ("not", unaryBool not)
23 , ("or" , naryBool (||)) 23 , ("or", naryBool (||))
24 , ("and" , naryBool (&&)) 24 , ("and", naryBool (&&))
25 , ("car", car)
26 , ("cdr", cdr)
27 , ("cons", cons)
28 , ("null?", isNull)
25 ] 29 ]
26 30
27data LispNumber = I Integer 31data LispNumber = I Integer
@@ -90,3 +94,31 @@ wrapNum (F n) = FloatLiteral n
90unwrapBool :: Expr -> LispResult Bool 94unwrapBool :: Expr -> LispResult Bool
91unwrapBool (BoolLiteral s) = return s 95unwrapBool (BoolLiteral s) = return s
92unwrapBool x = throwError $ TypeMismatch "boolean" x 96unwrapBool x = throwError $ TypeMismatch "boolean" x
97
98-- list primitives
99
100car :: FName -> [Expr] -> LispResult Expr
101car _ [List (x:xs)] = return x
102car _ [DottedList (x:xs) _ ] = return x
103car _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse
104car fn mulArgs = throwError $ ArgCount fn 1 mulArgs
105
106cdr :: FName -> [Expr] -> LispResult Expr
107cdr _ [List (x:xs)] = return $ List xs
108cdr _ [DottedList [_] tail] = return tail
109cdr _ [DottedList (_:xs) t] = return $ DottedList xs t
110cdr _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse
111cdr fn mulArgs = throwError $ ArgCount fn 1 mulArgs
112
113cons :: FName -> [Expr] -> LispResult Expr
114cons _ [val, List []] = return $ List [val]
115cons _ [val, List ls] = return $ List $ val:ls
116cons _ [val, DottedList ls tail] = return $ DottedList (val:ls) tail
117cons _ [v1, v2] = return $ DottedList [v1] v2
118cons fn mulArgs = throwError $ ArgCount fn 2 mulArgs
119
120isNull :: FName -> [Expr] -> LispResult Expr
121isNull _ [List []] = return $ BoolLiteral True
122isNull _ [List _] = return $ BoolLiteral False
123isNull _ [arg] = throwError $ TypeMismatch "pair" arg
124isNull fn args = throwError $ ArgCount fn 1 args
diff --git a/tests/Properties.hs b/tests/Properties.hs
index b9550c0..03a7e9a 100644
--- a/tests/Properties.hs
+++ b/tests/Properties.hs
@@ -10,8 +10,6 @@ import Operators (primitives)
10import Parser (Expr (..), parseLispValue, parseQuote) 10import Parser (Expr (..), parseLispValue, parseQuote)
11import Test.QuickCheck 11import Test.QuickCheck
12 12
13addition = fromJust $ lookup "+" primitives
14multiplication = fromJust $ lookup "*" primitives
15 13
16prop_commutativeAdd :: [Integer] -> Property 14prop_commutativeAdd :: [Integer] -> Property
17prop_commutativeAdd xs = 15prop_commutativeAdd xs =
@@ -19,6 +17,7 @@ prop_commutativeAdd xs =
19 where rhs = (unwrap . addition) exprs 17 where rhs = (unwrap . addition) exprs
20 lhs = (unwrap . addition . reverse) exprs 18 lhs = (unwrap . addition . reverse) exprs
21 exprs = map IntLiteral xs 19 exprs = map IntLiteral xs
20 addition = fromJust $ lookup "+" primitives
22 21
23prop_commutativeMul :: [Integer] -> Property 22prop_commutativeMul :: [Integer] -> Property
24prop_commutativeMul xs = 23prop_commutativeMul xs =
@@ -26,6 +25,7 @@ prop_commutativeMul xs =
26 where rhs = (unwrap . multiplication) exprs 25 where rhs = (unwrap . multiplication) exprs
27 lhs = (unwrap . multiplication . reverse) exprs 26 lhs = (unwrap . multiplication . reverse) exprs
28 exprs = map IntLiteral xs 27 exprs = map IntLiteral xs
28 multiplication = fromJust $ lookup "*" primitives
29 29
30return [] 30return []
31runTests = $quickCheckAll 31runTests = $quickCheckAll