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
|
module Operators (
primitives
) where
import Control.Monad.Except
import Error.Base (LispError (..), LispResult (..))
import Parser
primitives :: [(String, [Expr] -> LispResult Expr)]
primitives =
[
("+", arithmetic (+))
, ("-", arithmetic (-))
, ("*", arithmetic (*))
, ("/", arithmetic (/))
, (">", comparator (>))
, ("<", comparator (<))
, (">=", comparator (>=))
, ("<=", comparator (<=))
, ("=", comparator (==))
, ("!=", comparator (/=))
, ("not", unaryBool not)
, ("or", naryBool (||))
, ("and", naryBool (&&))
]
data LispNumber = I Integer
| F Double
deriving (Eq, Ord)
instance Num LispNumber where
-- TODO:
-- float op anything = float
-- int op int = int
-- int op float = float
(I a) + (I b) = I $ a + b
(F a) + (F b) = F $ a + b
(I a) - (I b) = I $ a - b
(F a) - (F b) = F $ a - b
(I a) * (I b) = I $ a * b
(F a) * (F b) = F $ a * b
instance Fractional LispNumber where
(I a) / (I b) = F $ fromIntegral a / fromIntegral b
(F a) / (I b) = F $ a / fromIntegral b
(I a) / (F b) = F $ fromIntegral a / b
(F a) / (F b) = F $ a / b
type Arithmetic = LispNumber -> LispNumber -> LispNumber
type Comparator = LispNumber -> LispNumber -> Bool
type UnaryBool = Bool -> Bool
type NaryBool = Bool -> Bool -> Bool
arithmetic :: Arithmetic -> [Expr] -> LispResult Expr
arithmetic op args
| null args = throwError $ ArgCount 1 args
| otherwise = do
as <- mapM unwrapNum args
return . wrapNum $ foldl1 op as
comparator :: Comparator -> [Expr] -> LispResult Expr
comparator op args
| length args < 2 = throwError $ ArgCount 2 args
| otherwise = do
as <- mapM unwrapNum args
return . BoolLiteral . all (== True) $ zipWith op as (tail as)
unaryBool :: UnaryBool -> [Expr] -> LispResult Expr
unaryBool op args
| length args /= 1 = throwError $ ArgCount 1 args
| otherwise = BoolLiteral . op <$> unwrapBool (head args)
naryBool :: NaryBool -> [Expr] -> LispResult Expr
naryBool op args
| length args < 2 = throwError $ ArgCount 2 args
| otherwise = do
as <- mapM unwrapBool args
return . BoolLiteral $ foldl1 op as
unwrapNum :: Expr -> LispResult LispNumber
unwrapNum (IntLiteral n) = return $ I n
unwrapNum (FloatLiteral n) = return $ F n
unwrapNum x = throwError $ TypeMismatch "number" x
wrapNum :: LispNumber -> Expr
wrapNum (I n) = IntLiteral n
wrapNum (F n) = FloatLiteral n
unwrapBool :: Expr -> LispResult Bool
unwrapBool (BoolLiteral s) = return s
unwrapBool x = throwError $ TypeMismatch "boolean" x
|
