aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Error/Base.hs7
-rw-r--r--src/Operators.hs53
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
13data LispError = Parse ParseError 13data 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
22instance Show LispError where 22instance 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 (..))
7import Parser 7import Parser
8 8
9primitives :: [(String, [Expr] -> LispResult Expr)] 9primitives :: [(String, [Expr] -> LispResult Expr)]
10primitives = 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 ] 25 ]
26 26
27data LispNumber = I Integer 27data 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
49type FName = String
49type Arithmetic = LispNumber -> LispNumber -> LispNumber 50type Arithmetic = LispNumber -> LispNumber -> LispNumber
50type Comparator = LispNumber -> LispNumber -> Bool 51type Comparator = LispNumber -> LispNumber -> Bool
51type UnaryBool = Bool -> Bool 52type UnaryBool = Bool -> Bool
52type NaryBool = Bool -> Bool -> Bool 53type NaryBool = Bool -> Bool -> Bool
53 54
54arithmetic :: Arithmetic -> [Expr] -> LispResult Expr 55arithmetic :: Arithmetic -> FName -> [Expr] -> LispResult Expr
55arithmetic op args 56arithmetic 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
61comparator :: Comparator -> [Expr] -> LispResult Expr 62comparator :: Comparator -> FName -> [Expr] -> LispResult Expr
62comparator op args 63comparator 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
68unaryBool :: UnaryBool -> [Expr] -> LispResult Expr 69unaryBool :: UnaryBool -> FName -> [Expr] -> LispResult Expr
69unaryBool op args 70unaryBool 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
73naryBool :: NaryBool -> [Expr] -> LispResult Expr 74naryBool :: NaryBool -> FName -> [Expr] -> LispResult Expr
74naryBool op args 75naryBool 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