diff options
-rw-r--r-- | src/Operators.hs | 58 | ||||
-rw-r--r-- | tests/Properties.hs | 4 |
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 | |||
9 | primitives :: [(String, [Expr] -> LispResult Expr)] | 9 | primitives :: [(String, [Expr] -> LispResult Expr)] |
10 | primitives = map (\(n, f) -> (n, f n)) | 10 | primitives = 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 | ||
27 | data LispNumber = I Integer | 31 | data LispNumber = I Integer |
@@ -90,3 +94,31 @@ wrapNum (F n) = FloatLiteral n | |||
90 | unwrapBool :: Expr -> LispResult Bool | 94 | unwrapBool :: Expr -> LispResult Bool |
91 | unwrapBool (BoolLiteral s) = return s | 95 | unwrapBool (BoolLiteral s) = return s |
92 | unwrapBool x = throwError $ TypeMismatch "boolean" x | 96 | unwrapBool x = throwError $ TypeMismatch "boolean" x |
97 | |||
98 | -- list primitives | ||
99 | |||
100 | car :: FName -> [Expr] -> LispResult Expr | ||
101 | car _ [List (x:xs)] = return x | ||
102 | car _ [DottedList (x:xs) _ ] = return x | ||
103 | car _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse | ||
104 | car fn mulArgs = throwError $ ArgCount fn 1 mulArgs | ||
105 | |||
106 | cdr :: FName -> [Expr] -> LispResult Expr | ||
107 | cdr _ [List (x:xs)] = return $ List xs | ||
108 | cdr _ [DottedList [_] tail] = return tail | ||
109 | cdr _ [DottedList (_:xs) t] = return $ DottedList xs t | ||
110 | cdr _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse | ||
111 | cdr fn mulArgs = throwError $ ArgCount fn 1 mulArgs | ||
112 | |||
113 | cons :: FName -> [Expr] -> LispResult Expr | ||
114 | cons _ [val, List []] = return $ List [val] | ||
115 | cons _ [val, List ls] = return $ List $ val:ls | ||
116 | cons _ [val, DottedList ls tail] = return $ DottedList (val:ls) tail | ||
117 | cons _ [v1, v2] = return $ DottedList [v1] v2 | ||
118 | cons fn mulArgs = throwError $ ArgCount fn 2 mulArgs | ||
119 | |||
120 | isNull :: FName -> [Expr] -> LispResult Expr | ||
121 | isNull _ [List []] = return $ BoolLiteral True | ||
122 | isNull _ [List _] = return $ BoolLiteral False | ||
123 | isNull _ [arg] = throwError $ TypeMismatch "pair" arg | ||
124 | isNull 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) | |||
10 | import Parser (Expr (..), parseLispValue, parseQuote) | 10 | import Parser (Expr (..), parseLispValue, parseQuote) |
11 | import Test.QuickCheck | 11 | import Test.QuickCheck |
12 | 12 | ||
13 | addition = fromJust $ lookup "+" primitives | ||
14 | multiplication = fromJust $ lookup "*" primitives | ||
15 | 13 | ||
16 | prop_commutativeAdd :: [Integer] -> Property | 14 | prop_commutativeAdd :: [Integer] -> Property |
17 | prop_commutativeAdd xs = | 15 | prop_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 | ||
23 | prop_commutativeMul :: [Integer] -> Property | 22 | prop_commutativeMul :: [Integer] -> Property |
24 | prop_commutativeMul xs = | 23 | prop_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 | ||
30 | return [] | 30 | return [] |
31 | runTests = $quickCheckAll | 31 | runTests = $quickCheckAll |