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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | bs primitives
--
-- I would like to reduce the number of primitives in the language to some
-- minimal number, like SKI combinator or Nock instructions. I'm not sure what
-- the minimal number is. The idea is to move primitives from here into core.scm
-- over time.
module Language.Bs.Primitives where
import Control.Exception hiding (handle)
import Control.Monad.Except
import Data.Text as T
import Data.Text.IO as TIO
import Language.Bs.Expr
import Network.HTTP
import Protolude
import System.Directory
import System.IO
type Prim = [(T.Text, Expr)]
type Unary = Expr -> Eval Expr
type Binary = Expr -> Expr -> Eval Expr
mkF :: ([Expr] -> Eval Expr) -> Expr
mkF = IFun . IFunc
primEnv :: Prim
primEnv = [
("+" , mkF $ binopFold (numOp (+)) (Numb 0) )
, ("*" , mkF $ binopFold (numOp (*)) (Numb 1) )
, ("string-append", mkF $ binopFold (strOp (<>)) (Tape "") )
, ("-" , 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 $ Language.Bs.Primitives.cons)
, ("cdr" , mkF $ Language.Bs.Primitives.cdr)
, ("car" , mkF $ Language.Bs.Primitives.car)
, ("quote" , mkF $ quote)
, ("file?" , mkF $ unop fileExists)
, ("slurp" , mkF $ unop slurp)
, ("wslurp" , mkF $ unop wSlurp)
, ("put" , mkF $ binop put_)
]
unop :: Unary -> [Expr] -> Eval Expr
unop op [x] = op x
unop _ args = throw $ NumArgs 1 args
binop :: Binary -> [Expr] -> Eval Expr
binop op [x,y] = op x y
binop _ args = throw $ NumArgs 2 args
fileExists :: Expr -> Eval Expr
fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt)
fileExists val = throw $ TypeMismatch "read expects string, instead got: " val
slurp :: Expr -> Eval Expr
slurp (Tape txt) = liftIO $ wFileSlurp txt
slurp val = throw $ TypeMismatch "read expects string, instead got: " val
wFileSlurp :: T.Text -> IO Expr
wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go
where go = readTextFile fileName
openURL :: T.Text -> IO Expr
openURL x = do
req <- simpleHTTP (getRequest $ T.unpack x)
body <- getResponseBody req
return $ Tape $ T.pack body
wSlurp :: Expr -> Eval Expr
wSlurp (Tape txt) = liftIO $ openURL txt
wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val
readTextFile :: T.Text -> Handle -> IO Expr
readTextFile fileName handle = do
exists <- doesFileExist $ T.unpack fileName
if exists
then (TIO.hGetContents handle) >>= (return . Tape)
else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
put_ :: Expr -> Expr -> Eval Expr
put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg
put_ (Tape _) 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 Expr
wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go
where go = putTextFile fileName msg
putTextFile :: T.Text -> T.Text -> Handle -> IO Expr
putTextFile fileName msg handle = do
canWrite <- hIsWritable handle
if canWrite
then (TIO.hPutStr handle msg) >> (return $ Tape msg)
else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
binopFold :: Binary -> Expr -> [Expr] -> Eval Expr
binopFold op farg args = case args of
[]-> throw $ NumArgs 2 args
[a,b] -> op a b
_ -> foldM op farg args
numBool :: (Integer -> Bool) -> Expr -> Eval Expr
numBool op (Numb x) = return $ Bool $ op x
numBool _ x = throw $ TypeMismatch "numeric op " x
numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr
numOp op (Numb x) (Numb y) = return $ Numb $ op x y
numOp _ Nil (Numb y) = return $ Numb y
numOp _ (Numb x) Nil = return $ Numb x
numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
numOp _ x _ = throw $ TypeMismatch "numeric op" x
strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr
strOp op (Tape x) (Tape y) = return $ Tape $ op x y
strOp _ Nil (Tape y) = return $ Tape y
strOp _ (Tape x) Nil = return $ Tape x
strOp _ x (Tape _) = throw $ TypeMismatch "string op" x
strOp _ (Tape _) y = throw $ TypeMismatch "string op" y
strOp _ x _ = throw $ TypeMismatch "string op" x
eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr
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) -> Expr -> Expr -> Eval Expr
numCmp op (Numb x) (Numb y) = return . Bool $ op x y
numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
numCmp _ x _ = throw $ TypeMismatch "numeric op" x
notOp :: Expr -> Eval Expr
notOp (Bool True) = return $ Bool False
notOp (Bool False) = return $ Bool True
notOp x = throw $ TypeMismatch " not expects Bool" x
eqCmd :: Expr -> Expr -> Eval Expr
eqCmd (Atom x) (Atom y) = return . Bool $ x == y
eqCmd (Numb x) (Numb y) = return . Bool $ x == y
eqCmd (Tape x) (Tape 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 :: [Expr] -> Eval Expr
cons [x,(List ys)] = return $ List $ x:ys
cons [x,y] = return $ List [x,y]
cons _ = throw $ ExpectedList "cons, in second argument"
car :: [Expr] -> Eval Expr
car [List [] ] = return Nil
car [List (x:_)] = return x
car [] = return Nil
car _ = throw $ ExpectedList "car"
cdr :: [Expr] -> Eval Expr
cdr [List (_:xs)] = return $ List xs
cdr [List []] = return Nil
cdr [] = return Nil
cdr _ = throw $ ExpectedList "cdr"
quote :: [Expr] -> Eval Expr
quote [List xs] = return $ List $ Atom "quote" : xs
quote [expr] = return $ List $ Atom "quote" : [expr]
quote args = throw $ NumArgs 1 args
|
