-
Notifications
You must be signed in to change notification settings - Fork 117
/
Copy pathPrim.hs
186 lines (154 loc) · 7.1 KB
/
Prim.hs
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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
{-# LANGUAGE OverloadedStrings #-}
module Prim ( primEnv, unop ) where
import LispVal
( LispException(NumArgs, IOError, TypeMismatch, ExpectedList),
IFunc(IFunc),
LispVal(Atom, Fun, Number, String, Bool, Nil, List),
Eval )
import Data.Functor ((<&>))
import Data.Text as T ( Text, concat, pack, unpack )
import Data.Text.IO as TIO ( hGetContents, hPutStr )
import System.Directory ( doesFileExist )
import System.IO
( Handle, hIsWritable, withFile, IOMode(WriteMode, ReadMode) )
import Network.HTTP ( getRequest, getResponseBody, simpleHTTP )
import Control.Monad.Except ( foldM, MonadIO(liftIO) )
import Control.Exception ( throw )
type Prim = [(T.Text, LispVal)]
type Unary = LispVal -> Eval LispVal
type Binary = LispVal -> LispVal -> Eval LispVal
mkF :: ([LispVal] -> Eval LispVal) -> LispVal
mkF = Fun . IFunc
primEnv :: Prim
primEnv = [
("+" , mkF $ binopFold (numOp (+)) (Number 0) )
, ("*" , mkF $ binopFold (numOp (*)) (Number 1) )
, ("string-append", mkF $ binopFold (strOp (<>)) (String "") )
, ("-" , mkF $ binop $ numOp (-))
, ("<" , mkF $ binop $ numCmp (<))
, ("<=" , mkF $ binop $ numCmp (<=))
, (">" , mkF $ binop $ numCmp (>))
, (">=" , mkF $ binop $ numCmp (>=))
, ("==" , mkF $ binop $ numCmp (==))
, ("even?" , mkF $ unop $ numBool even)
, ("odd?" , mkF $ unop $ numBool odd)
, ("neg?" , mkF $ unop $ numBool (< 0))
, ("pos?" , mkF $ unop $ numBool (> 0))
, ("eq?" , mkF $ binop eqCmd )
, ("null?" , mkF $ unop (eqCmd Nil) )
, ("bl-eq?", mkF $ binop $ eqOp (==))
, ("and" , mkF $ binopFold (eqOp (&&)) (Bool True))
, ("or" , mkF $ binopFold (eqOp (||)) (Bool False))
, ("not" , mkF $ unop notOp)
, ("cons" , mkF Prim.cons)
, ("cdr" , mkF Prim.cdr)
, ("car" , mkF Prim.car)
, ("quote" , mkF quote)
, ("file?" , mkF $ unop fileExists)
, ("slurp" , mkF $ unop slurp)
, ("wslurp", mkF $ unop wSlurp)
, ("put" , mkF $ binop put)
]
unop :: Unary -> [LispVal] -> Eval LispVal
unop op [x] = op x
unop _ args = throw $ NumArgs 1 args
binop :: Binary -> [LispVal] -> Eval LispVal
binop op [x,y] = op x y
binop _ args = throw $ NumArgs 2 args
fileExists :: LispVal -> Eval LispVal
fileExists (String txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt)
fileExists val = throw $ TypeMismatch "read expects string, instead got: " val
slurp :: LispVal -> Eval LispVal
slurp (String txt) = liftIO $ wFileSlurp txt
slurp val = throw $ TypeMismatch "read expects string, instead got: " val
wFileSlurp :: T.Text -> IO LispVal
wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go
where go = readTextFile fileName
openURL :: T.Text -> IO LispVal
openURL x = do
req <- simpleHTTP (getRequest $ T.unpack x)
body <- getResponseBody req
return $ String $ T.pack body
wSlurp :: LispVal -> Eval LispVal
wSlurp (String txt) = liftIO $ openURL txt
wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val
readTextFile :: T.Text -> Handle -> IO LispVal
readTextFile fileName handle = do
exists <- doesFileExist $ T.unpack fileName
if exists
then TIO.hGetContents handle <&> String
else throw $ IOError $ T.concat [" file does not exits: ", fileName]
put :: LispVal -> LispVal -> Eval LispVal
put (String file) (String msg) = liftIO $ wFilePut file msg
put (String _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val
put val _ = throw $ TypeMismatch "put expects string, instead got: " val
wFilePut :: T.Text -> T.Text -> IO LispVal
wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go
where go = putTextFile fileName msg
putTextFile :: T.Text -> T.Text -> Handle -> IO LispVal
putTextFile fileName msg handle = do
canWrite <- hIsWritable handle
if canWrite
then TIO.hPutStr handle msg >> return (String msg)
else throw $ IOError $ T.concat [" file does not exits: ", fileName]
binopFold :: Binary -> LispVal -> [LispVal] -> Eval LispVal
binopFold op farg args = case args of
[a,b] -> op a b
(_a:_as) -> foldM op farg args
[]-> throw $ NumArgs 2 args
numBool :: (Integer -> Bool) -> LispVal -> Eval LispVal
numBool op (Number x) = return $ Bool $ op x
numBool _ x = throw $ TypeMismatch "numeric op " x
numOp :: (Integer -> Integer -> Integer) -> LispVal -> LispVal -> Eval LispVal
numOp op (Number x) (Number y) = return $ Number $ op x y
numOp _ Nil (Number y) = return $ Number y
numOp _ (Number x) Nil = return $ Number x
numOp _ x (Number _) = throw $ TypeMismatch "numeric op " x
numOp _ (Number _) y = throw $ TypeMismatch "numeric op " y
numOp _ x _ = throw $ TypeMismatch "numeric op " x
strOp :: (T.Text -> T.Text -> T.Text) -> LispVal -> LispVal -> Eval LispVal
strOp op (String x) (String y) = return $ String $ op x y
strOp _ Nil (String y) = return $ String y
strOp _ (String x) Nil = return $ String x
strOp _ x (String _) = throw $ TypeMismatch "string op " x
strOp _ (String _) y = throw $ TypeMismatch "string op " y
strOp _ x _ = throw $ TypeMismatch "string op " x
eqOp :: (Bool -> Bool -> Bool) -> LispVal -> LispVal -> Eval LispVal
eqOp op (Bool x) (Bool y) = return $ Bool $ op x y
eqOp _ x (Bool _) = throw $ TypeMismatch "bool op " x
eqOp _ (Bool _) y = throw $ TypeMismatch "bool op " y
eqOp _ x _ = throw $ TypeMismatch "bool op " x
numCmp :: (Integer -> Integer -> Bool) -> LispVal -> LispVal -> Eval LispVal
numCmp op (Number x) (Number y) = return . Bool $ op x y
numCmp _ x (Number _) = throw $ TypeMismatch "numeric op " x
numCmp _ (Number _) y = throw $ TypeMismatch "numeric op " y
numCmp _ x _ = throw $ TypeMismatch "numeric op " x
notOp :: LispVal -> Eval LispVal
notOp (Bool True) = return $ Bool False
notOp (Bool False) = return $ Bool True
notOp x = throw $ TypeMismatch " not expects Bool" x
eqCmd :: LispVal -> LispVal -> Eval LispVal
eqCmd (Atom x) (Atom y) = return . Bool $ x == y
eqCmd (Number x) (Number y) = return . Bool $ x == y
eqCmd (String x) (String y) = return . Bool $ x == y
eqCmd (Bool x) (Bool y) = return . Bool $ x == y
eqCmd Nil Nil = return $ Bool True
eqCmd _ _ = return $ Bool False
cons :: [LispVal] -> Eval LispVal
cons [x,List yList] = return $ List $ x:yList
cons [x,y] = return $ List [x,y]
cons _ = throw $ ExpectedList "cons, in second argumnet"
car :: [LispVal] -> Eval LispVal
car [List [] ] = return Nil
car [List (x:_)] = return x
car [] = return Nil
car _ = throw $ ExpectedList "car"
cdr :: [LispVal] -> Eval LispVal
cdr [List (_:xs)] = return $ List xs
cdr [List []] = return Nil
cdr [] = return Nil
cdr _ = throw $ ExpectedList "cdr"
quote :: [LispVal] -> Eval LispVal
quote [List xs] = return $ List $ Atom "quote" : xs
quote [expr] = return $ List $ Atom "quote" : [expr]
quote args = throw $ NumArgs 1 args