diff options
-rw-r--r-- | src/Error/Base.hs | 7 | ||||
-rw-r--r-- | src/Operators.hs | 53 |
2 files changed, 32 insertions, 28 deletions
diff --git a/src/Error/Base.hs b/src/Error/Base.hs index 509377b..d7b685c 100644 --- a/src/Error/Base.hs +++ b/src/Error/Base.hs | |||
@@ -12,7 +12,7 @@ import Text.ParserCombinators.Parsec | |||
12 | 12 | ||
13 | data LispError = Parse ParseError | 13 | data LispError = Parse ParseError |
14 | | BadForm String Expr | 14 | | BadForm String Expr |
15 | | ArgCount Int [Expr] | 15 | | ArgCount String Int [Expr] |
16 | | UnknownFunction String | 16 | | UnknownFunction String |
17 | | TypeMismatch String Expr | 17 | | TypeMismatch String Expr |
18 | 18 | ||
@@ -22,7 +22,10 @@ unwordsList = unwords . map show | |||
22 | instance Show LispError where | 22 | instance Show LispError where |
23 | show (Parse e) = "Parser Error: " ++ show e | 23 | show (Parse e) = "Parser Error: " ++ show e |
24 | show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr | 24 | show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr |
25 | show (ArgCount n es) = "Invalid arity, expected " ++ show n ++ ", got value(s): " ++ unwordsList es | 25 | -- TODO: clean this up |
26 | show (ArgCount fn n es) | ||
27 | | null es = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s)!" | ||
28 | | otherwise = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s), got value(s): " ++ unwordsList es | ||
26 | show (UnknownFunction fn) = "Cannot apply function: " ++ fn | 29 | show (UnknownFunction fn) = "Cannot apply function: " ++ fn |
27 | show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got | 30 | show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got |
28 | 31 | ||
diff --git a/src/Operators.hs b/src/Operators.hs index 27488f3..051655a 100644 --- a/src/Operators.hs +++ b/src/Operators.hs | |||
@@ -7,21 +7,21 @@ import Error.Base (LispError (..), LispResult (..)) | |||
7 | import Parser | 7 | import Parser |
8 | 8 | ||
9 | primitives :: [(String, [Expr] -> LispResult Expr)] | 9 | primitives :: [(String, [Expr] -> LispResult Expr)] |
10 | primitives = | 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 | ] | 25 | ] |
26 | 26 | ||
27 | data LispNumber = I Integer | 27 | data LispNumber = I Integer |
@@ -46,33 +46,34 @@ instance Fractional LispNumber where | |||
46 | (I a) / (F b) = F $ fromIntegral a / b | 46 | (I a) / (F b) = F $ fromIntegral a / b |
47 | (F a) / (F b) = F $ a / b | 47 | (F a) / (F b) = F $ a / b |
48 | 48 | ||
49 | type FName = String | ||
49 | type Arithmetic = LispNumber -> LispNumber -> LispNumber | 50 | type Arithmetic = LispNumber -> LispNumber -> LispNumber |
50 | type Comparator = LispNumber -> LispNumber -> Bool | 51 | type Comparator = LispNumber -> LispNumber -> Bool |
51 | type UnaryBool = Bool -> Bool | 52 | type UnaryBool = Bool -> Bool |
52 | type NaryBool = Bool -> Bool -> Bool | 53 | type NaryBool = Bool -> Bool -> Bool |
53 | 54 | ||
54 | arithmetic :: Arithmetic -> [Expr] -> LispResult Expr | 55 | arithmetic :: Arithmetic -> FName -> [Expr] -> LispResult Expr |
55 | arithmetic op args | 56 | arithmetic op name args |
56 | | null args = throwError $ ArgCount 1 args | 57 | | null args = throwError $ ArgCount name 1 args |
57 | | otherwise = do | 58 | | otherwise = do |
58 | as <- mapM unwrapNum args | 59 | as <- mapM unwrapNum args |
59 | return . wrapNum $ foldl1 op as | 60 | return . wrapNum $ foldl1 op as |
60 | 61 | ||
61 | comparator :: Comparator -> [Expr] -> LispResult Expr | 62 | comparator :: Comparator -> FName -> [Expr] -> LispResult Expr |
62 | comparator op args | 63 | comparator op name args |
63 | | length args < 2 = throwError $ ArgCount 2 args | 64 | | length args < 2 = throwError $ ArgCount name 2 args |
64 | | otherwise = do | 65 | | otherwise = do |
65 | as <- mapM unwrapNum args | 66 | as <- mapM unwrapNum args |
66 | return . BoolLiteral . all (== True) $ zipWith op as (tail as) | 67 | return . BoolLiteral . all (== True) $ zipWith op as (tail as) |
67 | 68 | ||
68 | unaryBool :: UnaryBool -> [Expr] -> LispResult Expr | 69 | unaryBool :: UnaryBool -> FName -> [Expr] -> LispResult Expr |
69 | unaryBool op args | 70 | unaryBool op name args |
70 | | length args /= 1 = throwError $ ArgCount 1 args | 71 | | length args /= 1 = throwError $ ArgCount name 1 args |
71 | | otherwise = BoolLiteral . op <$> unwrapBool (head args) | 72 | | otherwise = BoolLiteral . op <$> unwrapBool (head args) |
72 | 73 | ||
73 | naryBool :: NaryBool -> [Expr] -> LispResult Expr | 74 | naryBool :: NaryBool -> FName -> [Expr] -> LispResult Expr |
74 | naryBool op args | 75 | naryBool op name args |
75 | | length args < 2 = throwError $ ArgCount 2 args | 76 | | length args < 2 = throwError $ ArgCount name 2 args |
76 | | otherwise = do | 77 | | otherwise = do |
77 | as <- mapM unwrapBool args | 78 | as <- mapM unwrapBool args |
78 | return . BoolLiteral $ foldl1 op as | 79 | return . BoolLiteral $ foldl1 op as |