Skip to content

Commit af80bc1

Browse files
mrsekutkanaka
mrsekut
authored and
kanaka
committed
feat: purescript step6
1 parent 511e0fe commit af80bc1

File tree

3 files changed

+250
-12
lines changed

3 files changed

+250
-12
lines changed

‎impls/purs/Makefile‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,3 +10,4 @@ step2_eval.purs = Mal.Step2
1010
step3_env.purs = Mal.Step3
1111
step4_if_fn_do.purs = Mal.Step4
1212
step5_tco.purs = Mal.Step5
13+
step6_file.purs = Mal.Step6

‎impls/purs/src/step5_tco.purs‎

Lines changed: 12 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -26,8 +26,7 @@ import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector)
2626

2727
-- TYPES
2828

29-
type Eval a = SafeT Effect a
30-
type SafeT = FreeT Identity
29+
type Eval a = FreeT Identity Effect a
3130

3231

3332

@@ -57,13 +56,14 @@ eval env (MalList _ ast) = case ast of
5756
case es of
5857
MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args
5958
MalFunction {ast:ast', params:params', env:env'} : args -> do
60-
_ <- liftEffect $ Env.sets env' params' args
61-
eval env' ast'
59+
newEnv <- liftEffect $ Env.newEnv env'
60+
_ <- liftEffect $ Env.sets newEnv params' args
61+
eval newEnv ast'
6262
_ -> throw "invalid function"
6363
eval env ast = evalAst env ast
6464

6565

66-
evalAst :: RefEnv -> MalExpr -> SafeT Effect MalExpr
66+
evalAst :: RefEnv -> MalExpr -> Eval MalExpr
6767
evalAst env (MalSymbol s) = do
6868
result <- liftEffect $ Env.get env s
6969
case result of
@@ -105,16 +105,16 @@ letBind env (MalSymbol ky : e : es) = do
105105
letBind _ _ = throw "invalid let*"
106106

107107

108-
evalIf :: RefEnv -> List MalExpr -> SafeT Effect MalExpr
108+
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
109109
evalIf env (b:t:e:Nil) = do
110110
cond <- evalAst env b
111-
evalAst env case cond of
111+
pure case cond of
112112
MalNil -> e
113113
MalBoolean false -> e
114114
_ -> t
115115
evalIf env (b:t:Nil) = do
116116
cond <- evalAst env b
117-
evalAst env case cond of
117+
pure case cond of
118118
MalNil -> MalNil
119119
MalBoolean false -> MalNil
120120
_ -> t
@@ -148,7 +148,7 @@ evalFn env params body = do
148148
fnEnv <- Env.newEnv env
149149
ok <- Env.sets fnEnv params' args
150150
if ok
151-
then runSafeT $ evalAst fnEnv body'
151+
then runEval $ evalAst fnEnv body'
152152
else throw "actual parameters do not match signature "
153153

154154
unwrapSymbol :: MalExpr -> Eval String
@@ -166,7 +166,7 @@ rep_ env str = rep env str *> pure unit
166166
rep :: RefEnv -> String -> Effect String
167167
rep env str = case read str of
168168
Left _ -> throw "EOF"
169-
Right ast -> print =<< (runSafeT $ eval env ast)
169+
Right ast -> print =<< (runEval $ eval env ast)
170170

171171

172172
loop :: RefEnv -> Effect Unit
@@ -212,8 +212,8 @@ print = printStr
212212

213213
-- Utils
214214

215-
runSafeT :: ∀ m a. MonadRec m => SafeT m a -> m a
216-
runSafeT = runFreeT $ pure <<< runIdentity
215+
runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a
216+
runEval = runFreeT $ pure <<< runIdentity
217217

218218

219219
runIdentity :: ∀ a. Identity a -> a

‎impls/purs/src/step6_file.purs‎

Lines changed: 237 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,237 @@
1+
module Mal.Step6 where
2+
3+
import Prelude
4+
5+
import Control.Monad.Error.Class (try)
6+
import Control.Monad.Free.Trans (FreeT, runFreeT)
7+
import Control.Monad.Rec.Class (class MonadRec)
8+
import Core as Core
9+
import Data.Either (Either(..))
10+
import Data.Identity (Identity(..))
11+
import Data.List (List(..), foldM, (:))
12+
import Data.Maybe (Maybe(..))
13+
import Data.Traversable (traverse, traverse_)
14+
import Data.Tuple (Tuple(..))
15+
import Effect (Effect)
16+
import Effect.Class (class MonadEffect, liftEffect)
17+
import Effect.Console (error, log)
18+
import Effect.Exception as Ex
19+
import Env as Env
20+
import Printer (printStr)
21+
import Reader (readStr)
22+
import Readline (args, readLine)
23+
import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toList, toVector)
24+
25+
26+
-- TYPES
27+
28+
type Eval a = FreeT Identity Effect a
29+
30+
31+
32+
-- MAIN
33+
34+
main :: Effect Unit
35+
main = do
36+
let as = args
37+
env <- Env.newEnv Nil
38+
traverse_ (setFn env) Core.ns
39+
setFn env (Tuple "eval" $ setEval env)
40+
rep_ env "(def! not (fn* (a) (if a false true)))"
41+
rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"
42+
case as of
43+
Nil -> do
44+
Env.set env "*ARGV*" $ toList Nil
45+
loop env
46+
script:args -> do
47+
Env.set env "*ARGV*" $ toList $ MalString <$> args
48+
rep_ env $ "(load-file \"" <> script <> "\")"
49+
50+
51+
52+
-- REPL
53+
54+
rep_ :: RefEnv -> String -> Effect Unit
55+
rep_ env str = rep env str *> pure unit
56+
57+
58+
rep :: RefEnv -> String -> Effect String
59+
rep env str = case read str of
60+
Left _ -> throw "EOF"
61+
Right ast -> print =<< (runEval $ eval env ast)
62+
63+
64+
loop :: RefEnv -> Effect Unit
65+
loop env = do
66+
line <- readLine "user> "
67+
case line of
68+
":q" -> pure unit
69+
_ -> do
70+
result <- try $ rep env line
71+
case result of
72+
Right exp -> log exp
73+
Left err -> error $ show err
74+
loop env
75+
76+
77+
setFn :: RefEnv -> Tuple String MalFn -> Effect Unit
78+
setFn env (Tuple sym f) = do
79+
newEnv <- Env.newEnv Nil
80+
Env.set env sym $ MalFunction
81+
{ fn : f
82+
, ast : MalNil
83+
, env : newEnv
84+
, params : Nil
85+
, macro : false
86+
, meta : MalNil
87+
}
88+
89+
90+
setEval :: RefEnv -> MalFn
91+
setEval env (ast:Nil) = runEval $ eval env ast
92+
setEval _ _ = throw "illegal call of eval"
93+
94+
95+
96+
-- EVAL
97+
98+
eval :: RefEnv -> MalExpr -> Eval MalExpr
99+
eval _ ast@(MalList _ Nil) = pure ast
100+
eval env (MalList _ ast) = case ast of
101+
MalSymbol "def!" : es -> evalDef env es
102+
MalSymbol "let*" : es -> evalLet env es
103+
MalSymbol "if" : es -> evalIf env es >>= eval env
104+
MalSymbol "do" : es -> evalDo env es
105+
MalSymbol "fn*" : es -> evalFnMatch env es
106+
_ -> do
107+
es <- traverse (evalAst env) ast
108+
case es of
109+
MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args
110+
MalFunction {ast:ast', params:params', env:env'} : args -> do
111+
newEnv <- liftEffect $ Env.newEnv env'
112+
_ <- liftEffect $ Env.sets newEnv params' args
113+
eval newEnv ast'
114+
_ -> throw "invalid function"
115+
eval env ast = evalAst env ast
116+
117+
118+
evalAst :: RefEnv -> MalExpr -> Eval MalExpr
119+
evalAst env (MalSymbol s) = do
120+
result <- liftEffect $ Env.get env s
121+
case result of
122+
Just k -> pure k
123+
Nothing -> liftEffect $ throw $ "'" <> s <> "'" <> " not found"
124+
evalAst env ast@(MalList _ _) = eval env ast
125+
evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs
126+
evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs
127+
evalAst _ ast = pure ast
128+
129+
130+
evalDef :: RefEnv -> List MalExpr -> Eval MalExpr
131+
evalDef env (MalSymbol v : e : Nil) = do
132+
evd <- evalAst env e
133+
liftEffect $ Env.set env v evd
134+
pure evd
135+
evalDef _ _ = throw "invalid def!"
136+
137+
138+
evalLet :: RefEnv -> List MalExpr -> Eval MalExpr
139+
evalLet env (MalList _ ps : e : Nil) = do
140+
letEnv <- liftEffect $ Env.newEnv env
141+
letBind letEnv ps
142+
evalAst letEnv e
143+
evalLet env (MalVector _ ps : e : Nil) = do
144+
letEnv <- liftEffect $ Env.newEnv env
145+
letBind letEnv ps
146+
evalAst letEnv e
147+
evalLet _ _ = throw "invalid let*"
148+
149+
150+
151+
letBind :: RefEnv -> List MalExpr -> Eval Unit
152+
letBind _ Nil = pure unit
153+
letBind env (MalSymbol ky : e : es) = do
154+
ex <- evalAst env e
155+
liftEffect $ Env.set env ky ex
156+
letBind env es
157+
letBind _ _ = throw "invalid let*"
158+
159+
160+
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
161+
evalIf env (b:t:e:Nil) = do
162+
cond <- evalAst env b
163+
pure case cond of
164+
MalNil -> e
165+
MalBoolean false -> e
166+
_ -> t
167+
evalIf env (b:t:Nil) = do
168+
cond <- evalAst env b
169+
pure case cond of
170+
MalNil -> MalNil
171+
MalBoolean false -> MalNil
172+
_ -> t
173+
evalIf _ _ = throw "invalid if"
174+
175+
176+
evalDo :: RefEnv -> List MalExpr -> Eval MalExpr
177+
evalDo env es = foldM (const $ evalAst env) MalNil es
178+
179+
180+
evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr
181+
evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body
182+
evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body
183+
evalFnMatch _ _ = throw "invalid fn*"
184+
185+
186+
evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr
187+
evalFn env params body = do
188+
paramsStr <- traverse unwrapSymbol params
189+
pure $ MalFunction { fn : fn paramsStr body
190+
, ast : body
191+
, env : env
192+
, params : paramsStr
193+
, macro : false
194+
, meta : MalNil
195+
}
196+
where
197+
198+
fn :: List String -> MalExpr -> MalFn
199+
fn params' body' = \args -> do
200+
fnEnv <- Env.newEnv env
201+
ok <- Env.sets fnEnv params' args
202+
if ok
203+
then runEval $ evalAst fnEnv body'
204+
else throw "actual parameters do not match signature "
205+
206+
unwrapSymbol :: MalExpr -> Eval String
207+
unwrapSymbol (MalSymbol s) = pure s
208+
unwrapSymbol _ = throw "fn* parameter must be symbols"
209+
210+
211+
212+
-- READ
213+
214+
read :: String -> Either String MalExpr
215+
read = readStr
216+
217+
218+
219+
-- PRINT
220+
221+
print :: MalExpr -> Effect String
222+
print = printStr
223+
224+
225+
226+
-- Utils
227+
228+
runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a
229+
runEval = runFreeT $ pure <<< runIdentity
230+
231+
232+
runIdentity :: ∀ a. Identity a -> a
233+
runIdentity (Identity a) = a
234+
235+
236+
throw :: forall m a. MonadEffect m => String -> m a
237+
throw = liftEffect <<< Ex.throw

0 commit comments

Comments
 (0)