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
92
93
94
95
96
97
|
module Operators (primitives) where
import Base
import Control.Monad.Except
import Error.Base (LispError (..), LispResult (..))
import qualified Data.Map as M
-- primitives :: [(String, [Expr] -> LispResult Expr)]
primitives :: M.Map String ([Expr] -> LispResult Expr)
primitives = M.fromList $ map (\(n, f) -> (n, f n))
[
("+", arithmetic (+))
, ("-", arithmetic (-))
, ("*", arithmetic (*))
, ("/", arithmetic (/))
, (">", comparator (>))
, ("<", comparator (<))
, (">=", comparator (>=))
, ("<=", comparator (<=))
, ("=" , comparator (==))
, ("!=" , comparator (/=))
, ("not", unaryBool not)
, ("or", naryBool (||))
, ("and", naryBool (&&))
, ("car", car)
, ("cdr", cdr)
, ("cons", cons)
, ("null?", isNull)
]
type FName = String
type Arithmetic = LispNumber -> LispNumber -> LispNumber
type Comparator = LispNumber -> LispNumber -> Bool
type UnaryBool = Bool -> Bool
type NaryBool = Bool -> Bool -> Bool
arithmetic :: Arithmetic -> FName -> [Expr] -> LispResult Expr
arithmetic op name args
| null args = throwError $ ArgCount name 1 args
| otherwise = do
as <- mapM unwrapNum args
return . Number $ foldl1 op as
comparator :: Comparator -> FName -> [Expr] -> LispResult Expr
comparator op name args
| length args < 2 = throwError $ ArgCount name 2 args
| otherwise = do
as <- mapM unwrapNum args
return . BoolLiteral . all (== True) $ zipWith op as (tail as)
unaryBool :: UnaryBool -> FName -> [Expr] -> LispResult Expr
unaryBool op name args
| length args /= 1 = throwError $ ArgCount name 1 args
| otherwise = BoolLiteral . op <$> unwrapBool (head args)
naryBool :: NaryBool -> FName -> [Expr] -> LispResult Expr
naryBool op name args
| length args < 2 = throwError $ ArgCount name 2 args
| otherwise = do
as <- mapM unwrapBool args
return . BoolLiteral $ foldl1 op as
unwrapNum :: Expr -> LispResult LispNumber
unwrapNum (Number x) = return x
unwrapNum x = throwError $ TypeMismatch "number" x
unwrapBool :: Expr -> LispResult Bool
unwrapBool (BoolLiteral s) = return s
unwrapBool x = throwError $ TypeMismatch "boolean" x
-- list primitives
car :: FName -> [Expr] -> LispResult Expr
car _ [List (x:xs)] = return x
car _ [DottedList (x:xs) _ ] = return x
car _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse
car fn mulArgs = throwError $ ArgCount fn 1 mulArgs
cdr :: FName -> [Expr] -> LispResult Expr
cdr _ [List (x:xs)] = return $ List xs
cdr _ [DottedList [_] tail] = return tail
cdr _ [DottedList (_:xs) t] = return $ DottedList xs t
cdr _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse
cdr fn mulArgs = throwError $ ArgCount fn 1 mulArgs
cons :: FName -> [Expr] -> LispResult Expr
cons _ [val, List []] = return $ List [val]
cons _ [val, List ls] = return $ List $ val:ls
cons _ [val, DottedList ls tail] = return $ DottedList (val:ls) tail
cons _ [v1, v2] = return $ DottedList [v1] v2
cons fn mulArgs = throwError $ ArgCount fn 2 mulArgs
isNull :: FName -> [Expr] -> LispResult Expr
isNull _ [List []] = return $ BoolLiteral True
isNull _ [List _] = return $ BoolLiteral False
isNull _ [arg] = throwError $ TypeMismatch "pair" arg
isNull fn args = throwError $ ArgCount fn 1 args
|
