hisp/Hisp.hs at master · apg/hisp · GitHub

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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
import qualified Data.Map as Map
import Text.ParserCombinators.Parsec

data Val = Num Int
         | Sym String
         | List [Val]
         | Closure [String] Val Env
         | Prim String  deriving (Eq, Ord, Show)

type Env = [Map.Map String Val]

-- env
emptyEnv = [Map.empty] :: Env
extendEnv es = (Map.empty):es
lookupEnv n [] = Nothing
lookupEnv n (e:es) = if Map.member n e then Map.lookup n e else lookupEnv n es
insertEnv n v (e:es) = (Map.insert n v e):es
updateEnv [] [] env = env
updateEnv (p:ps) (v:vs) env = insertEnv p v (updateEnv ps vs env)
updateEnv _ _ _ = error "not enough params or values in updateEnv"

isNum (Num _) = True
isNum _ = False

isSym (Sym _) = True
isSym _ = False

isList (List (x:_)) = True
isList _ = False

isNil (List []) = True
isNil _ = False

isClosure (Closure _ _ _) = True
isClosure _ = False

evalIf code env = case code of
                    (cond:cons:alt:[]) -> if test (eval cond env) then
                                             eval cons env
                                          else
                                             eval alt env
                    (cond:cons:[]) -> if test (eval cond env) then
                                         eval cons env
                                      else
                                         (List [])
    where test = not . isNil

eval :: Val -> Env -> Val
eval (Sym x) env = case lookupEnv x env of
                      Just x -> x
                      Nothing -> error $ "unbound variable '" ++ x ++ "'"
eval (List ((Sym "lambda"):(List params):(List code):[])) env = Closure (map (\(Sym x) -> x) params) (List code) env
eval (List ((Sym "if"):rest)) env = evalIf rest env
eval (List ((Sym "quote"):x:[])) env = x
eval (List (op:rands)) env = apply (eval op env) $ map (flip eval $ env) rands
eval x env = x

apply :: Val -> [Val] -> Val
apply (Closure params code env) args = eval code (updateEnv params args (extendEnv env))
apply (Prim "cons") (a:(List d):[]) = List (a:d)
apply (Prim "cons") (a:b:[]) = List [a, b]
apply (Prim "cons") _ = error "invalid arguments to cons"
apply (Prim "car") ((List []):[]) = error "can't take the car of an empty list"
apply (Prim "car") ((List (a:_)):[]) = a
apply (Prim "cdr") ((List []):[]) = error "can't take the cdr of an empty list"
apply (Prim "cdr") ((List (_:d)):[]) = List d
apply (Prim "not") ((List []):[]) = Num 1
apply (Prim "not") (_:[]) = List []
apply (Prim "not") _ = error "too many args to not"
apply (Prim "+") (Num x:Num y:[]) = Num (x + y)
apply (Prim "+") _ = error "invalid arguments to +"
apply (Prim "-") (Num x:[]) = Num (- x)
apply (Prim "-") (Num x:Num y:[]) = Num (x - y)
apply (Prim "-") _ = error "invalid arguments to -"
apply (Prim "*") (Num x:Num y:[]) = Num (x * y)
apply (Prim "*") _ = error "invalid arguments to *"
apply (Prim "/") (Num x:Num 0:[]) = error "attempt to divide by 0"
apply (Prim "/") (Num x:Num y:[]) = Num (x `div` y)
apply (Prim "/") _ = error "invalid arguments to /"
apply (Prim "=") (a:b:[]) = if a == b then Num 1 else List []
apply (Prim _) _ = error "unknown primitive"


apply _ _ = error "don't know how to apply that"

-- List [List [Sym "lambda", List [Sym "x"], List [Sym "if", Sym "x", Num 1, Num 3]], Num 3)

initialEnv = [Map.fromList [ ("cons", Prim "cons")
                           , ("car", Prim "car")
                           , ("cdr", Prim "cdr")
                           , ("not", Prim "not")
                           , ("+", Prim "+")
                           , ("-", Prim "-")
                           , ("*", Prim "*")
                           , ("/", Prim "/")
                           , ("=", Prim "=")
                           ]]

p_value = p_num
      <|> p_sym
      <|> p_list
      <|> p_quoted
p_num = do d <- (many1 digit)
           return (Num (read d :: Int))
s_initial = oneOf "+-*/.%^|=><" <|> letter
s_subsequent = s_initial <|> letter <|> digit <|> oneOf "!?"
p_sym = do s <- s_initial
           se <- many s_subsequent
           return (Sym (s : se))
p_list = do es <- between (char '(') (char ')') p_list_elts
            return (List es)
p_quoted = do v <- char '\'' >> p_value
              return (List [Sym "quote", v])
p_list_elts = sepBy p_value spaces

readVal :: String -> Val
readVal input = case parse p_value "(read error)" input of
                   Right val -> val
                   Left x -> error $ "uh oh, couldn't parse that:\n" ++ (show x)