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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Bs.Eval (
evalText
, evalFile
, runParseTest
, safeExec
, runASTinEnv
, basicEnv
, fileToEvalForm
, textToEvalForm
, getFileContents
) where
import Control.Exception
import Control.Monad.Reader
import qualified Data.Map as Map
import Data.String
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Language.Bs.Expr
import Language.Bs.Parser
import Language.Bs.Primitives
import Protolude
import System.Directory
funcEnv :: Map.Map T.Text Expr
funcEnv = Map.fromList $ primEnv
<> [ ("read" , IFun $ IFunc $ unop readFn)
, ("parse", IFun $ IFunc $ unop parseFn)
, ("eval", IFun $ IFunc $ unop eval)
, ("show", IFun $ IFunc $ unop (return . Tape . ppexpr))
]
basicEnv :: Env
basicEnv = Env Map.empty funcEnv
readFn :: Expr -> Eval Expr
readFn (Tape txt) = lineToEvalForm txt
readFn val = throw $ TypeMismatch "read expects string, instead got:" val
parseFn :: Expr -> Eval Expr
parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt
parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val
safeExec :: IO a -> IO (Either String a)
safeExec m = do
result <- Control.Exception.try m
case result of
Left (eTop :: SomeException) ->
case fromException eTop of
Just (enclosed :: LispError) ->
return $ Left (show enclosed)
Nothing ->
return $ Left (show eTop)
Right val ->
return $ Right val
runASTinEnv :: Env -> Eval b -> IO b
runASTinEnv code action = runReaderT (unEval action) code
lineToEvalForm :: T.Text -> Eval Expr
lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input
evalFile :: FilePath -> T.Text -> IO () -- program file
evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print
fileToEvalForm :: FilePath -> T.Text -> Eval Expr
fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input
runParseTest :: T.Text -> T.Text -- for view AST
runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input
getFileContents :: FilePath -> IO T.Text
getFileContents fname = do
exists <- doesFileExist fname
if exists then TIO.readFile fname else return "File does not exist."
textToEvalForm :: T.Text -> Eval Expr
textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input
evalText :: T.Text -> IO () --REPL
evalText textExpr = do
res <- runASTinEnv basicEnv $ textToEvalForm textExpr
print res
getVar :: Expr -> Eval Expr
getVar (Atom atom) = do
Env{..} <- ask
case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions
Just x -> return x
Nothing -> throw $ UnboundVar atom
getVar n = throw $ TypeMismatch "failure to get variable: " n
ensureAtom :: Expr -> Eval Expr
ensureAtom n@(Atom _) = return n
ensureAtom n@(List _) = throw $ TypeMismatch "got list" n
ensureAtom n = throw $ TypeMismatch "expected an atomic value" n
extractVar :: Expr -> T.Text
extractVar (Atom atom) = atom
extractVar n = throw $ TypeMismatch "expected an atomic value" n
getEven :: [t] -> [t]
getEven [] = []
getEven (x:xs) = x : getOdd xs
getOdd :: [t] -> [t]
getOdd [] = []
getOdd (_:xs) = getEven xs
applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr
applyFunc expr params args = bindArgsEval params args expr
bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr
bindArgsEval params args expr = do
Env{..} <- ask
let newVars = zipWith (\a b -> (extractVar a,b)) params args
let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars
local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr
isFunc :: Expr -> Bool
isFunc (List ((Atom "lambda"):_)) = True
isFunc _ = False
eval :: Expr -> Eval Expr
eval (List [Atom "dumpEnv", x]) = do
Env{..} <- ask
liftIO $ print $ toList env
liftIO $ print $ toList fenv
eval x
eval (Numb i) = return $ Numb i
eval (Tape s) = return $ Tape s
eval (Bool b) = return $ Bool b
eval (List []) = return Nil
eval Nil = return Nil
eval n@(Atom _) = getVar n
eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest
eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest
eval (List [Atom "quote", val]) = return val
eval (List [Atom "if", pred_, then_, else_]) = do
ifRes <- eval pred_
case ifRes of
(Bool True) -> eval then_
(Bool False) -> eval else_
_ ->
throw $ BadSpecialForm "if's first arg must eval into a boolean"
eval (List ( (:) (Atom "if") _)) =
throw $ BadSpecialForm "(if <bool> <s-expr> <s-expr>)"
eval (List [Atom "begin", rest]) = evalBody rest
eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest
-- top-level define
-- TODO: how to make this eval correctly?
eval (List [Atom "define", List (name:args), body]) = do
Env{..} <- ask
_ <- eval body
bindArgsEval (name:args) [body] name
eval (List [Atom "define", name, body]) = do
Env{..} <- ask
_ <- eval body
bindArgsEval [name] [body] name
eval (List [Atom "let", List pairs, expr]) = do
Env{..} <- ask
atoms <- mapM ensureAtom $ getEven pairs
vals <- mapM eval $ getOdd pairs
bindArgsEval atoms vals expr
eval (List (Atom "let":_) ) =
throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let <pairs> <s-expr>)"
eval (List [Atom "lambda", List params, expr]) = do
ctx <- ask
return $ Func (IFunc $ applyFunc expr params) ctx
eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda <params> <s-expr>)"
-- needed to get cadr, etc to work
eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) =
return $ List xs
eval (List [Atom "cdr", arg@(List (x:xs))]) =
case x of
-- proxy for if the list can be evaluated
Atom _ -> do
val <- eval arg
eval $ List [Atom "cdr", val]
_ -> return $ List xs
eval (List [Atom "car", List [Atom "quote", List (x:_)]]) =
return $ x
eval (List [Atom "car", arg@(List (x:_))]) =
case x of
Atom _ -> do
val <- eval arg
eval $ List [Atom "car", val]
_ -> return $ x
eval (List ((:) x xs)) = do
Env{..} <- ask
funVar <- eval x
xVal <- mapM eval xs
case funVar of
(IFun (IFunc internalFn)) ->
internalFn xVal
(Func (IFunc definedFn) (Env benv _)) ->
local (const $ Env benv fenv) $ definedFn xVal
_ ->
throw $ NotFunction funVar
updateEnv :: T.Text -> Expr -> Env -> Env
updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv
updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv
updateEnv var e Env{..} = Env (Map.insert var e env) fenv
evalBody :: Expr -> Eval Expr
evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do
evalVal <- eval defExpr
ctx <- ask
local (const $ updateEnv var evalVal ctx) $ eval rest
evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do
evalVal <- eval defExpr
ctx <- ask
local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest
evalBody x = eval x
|
