mirror of
https://github.com/kanaka/mal.git
synced 2024-08-17 09:40:21 +03:00
feat: purescript step5
This commit is contained in:
parent
adf25c9cf7
commit
511e0febaf
@ -9,3 +9,4 @@ step1_read_print.purs = Mal.Step1
|
|||||||
step2_eval.purs = Mal.Step2
|
step2_eval.purs = Mal.Step2
|
||||||
step3_env.purs = Mal.Step3
|
step3_env.purs = Mal.Step3
|
||||||
step4_if_fn_do.purs = Mal.Step4
|
step4_if_fn_do.purs = Mal.Step4
|
||||||
|
step5_tco.purs = Mal.Step5
|
||||||
|
@ -20,6 +20,8 @@ to generate this file without the comments in this block.
|
|||||||
, "either"
|
, "either"
|
||||||
, "exceptions"
|
, "exceptions"
|
||||||
, "foldable-traversable"
|
, "foldable-traversable"
|
||||||
|
, "freet"
|
||||||
|
, "identity"
|
||||||
, "integers"
|
, "integers"
|
||||||
, "lists"
|
, "lists"
|
||||||
, "maybe"
|
, "maybe"
|
||||||
@ -32,6 +34,7 @@ to generate this file without the comments in this block.
|
|||||||
, "psci-support"
|
, "psci-support"
|
||||||
, "refs"
|
, "refs"
|
||||||
, "strings"
|
, "strings"
|
||||||
|
, "tailrec"
|
||||||
, "transformers"
|
, "transformers"
|
||||||
, "tuples"
|
, "tuples"
|
||||||
]
|
]
|
||||||
|
@ -28,12 +28,15 @@ data MalExpr
|
|||||||
| MalList Meta (List MalExpr)
|
| MalList Meta (List MalExpr)
|
||||||
| MalVector Meta (List MalExpr)
|
| MalVector Meta (List MalExpr)
|
||||||
| MalHashMap Meta (Map Key MalExpr)
|
| MalHashMap Meta (Map Key MalExpr)
|
||||||
| MalFunction { fn :: MalFn
|
| MalFunction { fn :: MalFn
|
||||||
|
, ast :: MalExpr
|
||||||
|
, env :: RefEnv
|
||||||
, params :: List String
|
, params :: List String
|
||||||
, macro :: Boolean
|
, macro :: Boolean
|
||||||
, meta :: MalExpr
|
, meta :: MalExpr
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
instance Eq MalExpr where
|
instance Eq MalExpr where
|
||||||
eq MalNil MalNil = true
|
eq MalNil MalNil = true
|
||||||
eq (MalBoolean a) (MalBoolean b) = a == b
|
eq (MalBoolean a) (MalBoolean b) = a == b
|
||||||
|
@ -6,11 +6,25 @@ import Effect.Console (log)
|
|||||||
import Readline (readLine)
|
import Readline (readLine)
|
||||||
|
|
||||||
|
|
||||||
|
-- MAIN
|
||||||
|
|
||||||
main :: Effect Unit
|
main :: Effect Unit
|
||||||
main = loop
|
main = loop
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- EVAL
|
||||||
|
|
||||||
|
eval :: String -> String
|
||||||
|
eval s = s
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- REPL
|
||||||
|
|
||||||
|
rep :: String -> String
|
||||||
|
rep = read >>> eval >>> print
|
||||||
|
|
||||||
loop :: Effect Unit
|
loop :: Effect Unit
|
||||||
loop = do
|
loop = do
|
||||||
line <- readLine "user> "
|
line <- readLine "user> "
|
||||||
@ -22,17 +36,16 @@ loop = do
|
|||||||
loop
|
loop
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- READ
|
||||||
|
|
||||||
read :: String -> String
|
read :: String -> String
|
||||||
read s = s
|
read s = s
|
||||||
|
|
||||||
|
|
||||||
eval :: String -> String
|
|
||||||
eval s = s
|
|
||||||
|
|
||||||
|
-- PRINT
|
||||||
|
|
||||||
print :: String -> String
|
print :: String -> String
|
||||||
print s = s
|
print s = s
|
||||||
|
|
||||||
|
|
||||||
rep :: String -> String
|
|
||||||
rep = read >>> eval >>> print
|
|
@ -11,10 +11,10 @@ import Readline (readLine)
|
|||||||
import Types (MalExpr)
|
import Types (MalExpr)
|
||||||
|
|
||||||
|
|
||||||
-- READ
|
-- MAIN
|
||||||
|
|
||||||
read :: String -> Either String MalExpr
|
main :: Effect Unit
|
||||||
read = readStr
|
main = loop
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -25,13 +25,6 @@ eval s = s
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- PRINT
|
|
||||||
|
|
||||||
print :: MalExpr -> Effect String
|
|
||||||
print = printStr
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- REPL
|
-- REPL
|
||||||
|
|
||||||
rep :: String -> Effect Unit
|
rep :: String -> Effect Unit
|
||||||
@ -52,7 +45,14 @@ loop = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
--
|
-- READ
|
||||||
|
|
||||||
main :: Effect Unit
|
read :: String -> Either String MalExpr
|
||||||
main = loop
|
read = readStr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- PRINT
|
||||||
|
|
||||||
|
print :: MalExpr -> Effect String
|
||||||
|
print = printStr
|
@ -12,17 +12,17 @@ import Data.Tuple (Tuple(..))
|
|||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Effect.Console (error, log)
|
import Effect.Console (error, log)
|
||||||
import Effect.Exception (throw, try)
|
import Effect.Exception (throw, try)
|
||||||
|
import Env as Env
|
||||||
import Reader (readStr)
|
import Reader (readStr)
|
||||||
import Printer (printStr)
|
import Printer (printStr)
|
||||||
import Readline (readLine)
|
import Readline (readLine)
|
||||||
import Types (MalExpr(..), MalFn, toHashMap, toList, toVector)
|
import Types (MalExpr(..), MalFn, toHashMap, toList, toVector)
|
||||||
|
|
||||||
|
|
||||||
|
-- MAIN
|
||||||
|
|
||||||
-- READ
|
main :: Effect Unit
|
||||||
|
main = loop
|
||||||
read :: String -> Either String MalExpr
|
|
||||||
read = readStr
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -49,28 +49,38 @@ evalAst _ ast = pure ast
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- PRINT
|
|
||||||
|
|
||||||
print :: MalExpr -> Effect String
|
|
||||||
print = printStr
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- ENV
|
-- ENV
|
||||||
|
|
||||||
type ReplEnv = Map String MalExpr
|
type ReplEnv = Map String MalExpr
|
||||||
|
|
||||||
replEnv :: ReplEnv
|
|
||||||
replEnv = Map.fromFoldable
|
|
||||||
[ (Tuple "+" (fn (+)))
|
|
||||||
, (Tuple "-" (fn (-)))
|
|
||||||
, (Tuple "*" (fn (*)))
|
|
||||||
, (Tuple "/" (fn (/)))
|
|
||||||
]
|
|
||||||
|
|
||||||
fn :: (Int -> Int -> Int) -> MalExpr
|
replEnv :: Effect ReplEnv
|
||||||
fn op = MalFunction $ { fn : g op, params:Nil, macro:false, meta:MalNil }
|
replEnv = do
|
||||||
|
add <- fn (+)
|
||||||
|
sub <- fn (-)
|
||||||
|
mul <- fn (*)
|
||||||
|
div <- fn (/)
|
||||||
|
pure $ Map.fromFoldable
|
||||||
|
[ Tuple "+" add
|
||||||
|
, Tuple "-" sub
|
||||||
|
, Tuple "*" mul
|
||||||
|
, Tuple "/" div
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
fn :: (Int -> Int -> Int) -> Effect MalExpr
|
||||||
|
fn op = do
|
||||||
|
newEnv <- Env.newEnv Nil
|
||||||
|
pure $ MalFunction
|
||||||
|
{ fn : g op
|
||||||
|
, ast : MalNil
|
||||||
|
, env : newEnv
|
||||||
|
, params : Nil
|
||||||
|
, macro : false
|
||||||
|
, meta : MalNil
|
||||||
|
}
|
||||||
where
|
where
|
||||||
|
|
||||||
g :: (Int -> Int -> Int) -> MalFn
|
g :: (Int -> Int -> Int) -> MalFn
|
||||||
g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2
|
g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2
|
||||||
g _ _ = throw "invalid operator"
|
g _ _ = throw "invalid operator"
|
||||||
@ -81,9 +91,10 @@ fn op = MalFunction $ { fn : g op, params:Nil, macro:false, meta:MalNil }
|
|||||||
|
|
||||||
rep :: String -> Effect Unit
|
rep :: String -> Effect Unit
|
||||||
rep str = case read str of
|
rep str = case read str of
|
||||||
Left _ -> error "EOF"
|
Left _ -> error "EOF"
|
||||||
Right ast -> do
|
Right ast -> do
|
||||||
result <- try $ eval replEnv ast
|
env <- replEnv
|
||||||
|
result <- try $ eval env ast
|
||||||
case result of
|
case result of
|
||||||
Right exp -> print exp >>= log
|
Right exp -> print exp >>= log
|
||||||
Left err -> error $ show err
|
Left err -> error $ show err
|
||||||
@ -101,7 +112,14 @@ loop = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
--
|
-- READ
|
||||||
|
|
||||||
main :: Effect Unit
|
read :: String -> Either String MalExpr
|
||||||
main = loop
|
read = readStr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- PRINT
|
||||||
|
|
||||||
|
print :: MalExpr -> Effect String
|
||||||
|
print = printStr
|
@ -17,11 +17,13 @@ import Readline (readLine)
|
|||||||
import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector)
|
import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector)
|
||||||
|
|
||||||
|
|
||||||
|
-- MAIN
|
||||||
|
|
||||||
-- READ
|
main :: Effect Unit
|
||||||
|
main = do
|
||||||
read :: String -> Either String MalExpr
|
re <- Env.newEnv Nil
|
||||||
read = readStr
|
setArithOp re
|
||||||
|
loop re
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -35,8 +37,8 @@ eval env (MalList _ ast) = case ast of
|
|||||||
_ -> do
|
_ -> do
|
||||||
es <- traverse (evalAst env) ast
|
es <- traverse (evalAst env) ast
|
||||||
case es of
|
case es of
|
||||||
(MalFunction {fn:f} : args) -> f args
|
MalFunction {fn:f} : args -> f args
|
||||||
_ -> throw "invalid function"
|
_ -> throw "invalid function"
|
||||||
eval env ast = evalAst env ast
|
eval env ast = evalAst env ast
|
||||||
|
|
||||||
|
|
||||||
@ -81,13 +83,6 @@ letBind _ _ = throw "invalid let*"
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- PRINT
|
|
||||||
|
|
||||||
print :: MalExpr -> Effect String
|
|
||||||
print = printStr
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- REPL
|
-- REPL
|
||||||
|
|
||||||
rep :: RefEnv -> String -> Effect String
|
rep :: RefEnv -> String -> Effect String
|
||||||
@ -111,25 +106,39 @@ loop env = do
|
|||||||
|
|
||||||
setArithOp :: RefEnv -> Effect Unit
|
setArithOp :: RefEnv -> Effect Unit
|
||||||
setArithOp env = do
|
setArithOp env = do
|
||||||
Env.set env "+" $ fn (+)
|
Env.set env "+" =<< fn (+)
|
||||||
Env.set env "-" $ fn (-)
|
Env.set env "-" =<< fn (-)
|
||||||
Env.set env "*" $ fn (*)
|
Env.set env "*" =<< fn (*)
|
||||||
Env.set env "/" $ fn (/)
|
Env.set env "/" =<< fn (/)
|
||||||
|
|
||||||
|
|
||||||
fn :: (Int -> Int -> Int) -> MalExpr
|
fn :: (Int -> Int -> Int) -> Effect MalExpr
|
||||||
fn op = MalFunction $ { fn : g op, params:Nil, macro:false, meta:MalNil }
|
fn op = do
|
||||||
|
newEnv <- Env.newEnv Nil
|
||||||
|
pure $ MalFunction
|
||||||
|
{ fn : g op
|
||||||
|
, ast : MalNil
|
||||||
|
, env : newEnv
|
||||||
|
, params : Nil
|
||||||
|
, macro : false
|
||||||
|
, meta : MalNil
|
||||||
|
}
|
||||||
where
|
where
|
||||||
|
|
||||||
g :: (Int -> Int -> Int) -> MalFn
|
g :: (Int -> Int -> Int) -> MalFn
|
||||||
g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2
|
g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2
|
||||||
g _ _ = throw "invalid operator"
|
g _ _ = throw "invalid operator"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
--
|
-- READ
|
||||||
|
|
||||||
main :: Effect Unit
|
read :: String -> Either String MalExpr
|
||||||
main = do
|
read = readStr
|
||||||
re <- Env.newEnv Nil
|
|
||||||
setArithOp re
|
|
||||||
loop re
|
|
||||||
|
-- PRINT
|
||||||
|
|
||||||
|
print :: MalExpr -> Effect String
|
||||||
|
print = printStr
|
@ -20,10 +20,14 @@ import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector)
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- READ
|
-- MAIN
|
||||||
|
|
||||||
read :: String -> Either String MalExpr
|
main :: Effect Unit
|
||||||
read = readStr
|
main = do
|
||||||
|
re <- Env.newEnv Nil
|
||||||
|
_ <- traverse (setFn re) Core.ns
|
||||||
|
_ <- rep re "(def! not (fn* (a) (if a false true)))"
|
||||||
|
loop re
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -115,7 +119,13 @@ evalFnMatch _ _ = throw "invalid fn*"
|
|||||||
evalFn :: RefEnv -> List MalExpr -> MalExpr -> Effect MalExpr
|
evalFn :: RefEnv -> List MalExpr -> MalExpr -> Effect MalExpr
|
||||||
evalFn env params body = do
|
evalFn env params body = do
|
||||||
paramsStr <- traverse unwrapSymbol params
|
paramsStr <- traverse unwrapSymbol params
|
||||||
pure $ MalFunction { fn : fn paramsStr body, params:paramsStr, macro:false, meta:MalNil }
|
pure $ MalFunction { fn : fn paramsStr body
|
||||||
|
, ast : body
|
||||||
|
, env : env
|
||||||
|
, params : paramsStr
|
||||||
|
, macro : false
|
||||||
|
, meta : MalNil
|
||||||
|
}
|
||||||
where
|
where
|
||||||
|
|
||||||
fn :: List String -> MalExpr -> MalFn
|
fn :: List String -> MalExpr -> MalFn
|
||||||
@ -132,13 +142,6 @@ evalFn env params body = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- PRINT
|
|
||||||
|
|
||||||
print :: MalExpr -> Effect String
|
|
||||||
print = printStr
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- REPL
|
-- REPL
|
||||||
|
|
||||||
rep :: RefEnv -> String -> Effect String
|
rep :: RefEnv -> String -> Effect String
|
||||||
@ -161,15 +164,27 @@ loop env = do
|
|||||||
|
|
||||||
|
|
||||||
setFn :: RefEnv -> Tuple String MalFn -> Effect Unit
|
setFn :: RefEnv -> Tuple String MalFn -> Effect Unit
|
||||||
setFn env (Tuple sym f) = Env.set env sym $ MalFunction { fn:f, params:Nil, macro:false, meta:MalNil }
|
setFn env (Tuple sym f) = do
|
||||||
|
newEnv <- Env.newEnv Nil
|
||||||
|
Env.set env sym $ MalFunction
|
||||||
|
{ fn : f
|
||||||
|
, ast : MalNil
|
||||||
|
, env : newEnv
|
||||||
|
, params : Nil
|
||||||
|
, macro : false
|
||||||
|
, meta : MalNil
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
--
|
-- READ
|
||||||
|
|
||||||
main :: Effect Unit
|
read :: String -> Either String MalExpr
|
||||||
main = do
|
read = readStr
|
||||||
re <- Env.newEnv Nil
|
|
||||||
_ <- traverse (setFn re) Core.ns
|
|
||||||
_ <- rep re "(def! not (fn* (a) (if a false true)))"
|
|
||||||
loop re
|
-- PRINT
|
||||||
|
|
||||||
|
print :: MalExpr -> Effect String
|
||||||
|
print = printStr
|
224
impls/purs/src/step5_tco.purs
Normal file
224
impls/purs/src/step5_tco.purs
Normal file
@ -0,0 +1,224 @@
|
|||||||
|
module Mal.Step5 where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Control.Monad.Error.Class (try)
|
||||||
|
import Control.Monad.Free.Trans (FreeT, runFreeT)
|
||||||
|
import Control.Monad.Rec.Class (class MonadRec)
|
||||||
|
import Core as Core
|
||||||
|
import Data.Either (Either(..))
|
||||||
|
import Data.Foldable (traverse_)
|
||||||
|
import Data.Identity (Identity(..))
|
||||||
|
import Data.List (List(..), foldM, (:))
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
import Data.Traversable (traverse)
|
||||||
|
import Data.Tuple (Tuple(..))
|
||||||
|
import Effect (Effect)
|
||||||
|
import Effect.Class (class MonadEffect, liftEffect)
|
||||||
|
import Effect.Console (error, log)
|
||||||
|
import Effect.Exception as Ex
|
||||||
|
import Env as Env
|
||||||
|
import Printer (printStr)
|
||||||
|
import Reader (readStr)
|
||||||
|
import Readline (readLine)
|
||||||
|
import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector)
|
||||||
|
|
||||||
|
|
||||||
|
-- TYPES
|
||||||
|
|
||||||
|
type Eval a = SafeT Effect a
|
||||||
|
type SafeT = FreeT Identity
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- MAIN
|
||||||
|
|
||||||
|
main :: Effect Unit
|
||||||
|
main = do
|
||||||
|
re <- Env.newEnv Nil
|
||||||
|
traverse_ (setFn re) Core.ns
|
||||||
|
rep_ re "(def! not (fn* (a) (if a false true)))"
|
||||||
|
loop re
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- EVAL
|
||||||
|
|
||||||
|
eval :: RefEnv -> MalExpr -> Eval MalExpr
|
||||||
|
eval _ ast@(MalList _ Nil) = pure ast
|
||||||
|
eval env (MalList _ ast) = case ast of
|
||||||
|
MalSymbol "def!" : es -> evalDef env es
|
||||||
|
MalSymbol "let*" : es -> evalLet env es
|
||||||
|
MalSymbol "if" : es -> evalIf env es >>= eval env
|
||||||
|
MalSymbol "do" : es -> evalDo env es
|
||||||
|
MalSymbol "fn*" : es -> evalFnMatch env es
|
||||||
|
_ -> do
|
||||||
|
es <- traverse (evalAst env) ast
|
||||||
|
case es of
|
||||||
|
MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args
|
||||||
|
MalFunction {ast:ast', params:params', env:env'} : args -> do
|
||||||
|
_ <- liftEffect $ Env.sets env' params' args
|
||||||
|
eval env' ast'
|
||||||
|
_ -> throw "invalid function"
|
||||||
|
eval env ast = evalAst env ast
|
||||||
|
|
||||||
|
|
||||||
|
evalAst :: RefEnv -> MalExpr -> SafeT Effect MalExpr
|
||||||
|
evalAst env (MalSymbol s) = do
|
||||||
|
result <- liftEffect $ Env.get env s
|
||||||
|
case result of
|
||||||
|
Just k -> pure k
|
||||||
|
Nothing -> liftEffect $ throw $ "'" <> s <> "'" <> " not found"
|
||||||
|
evalAst env ast@(MalList _ _) = eval env ast
|
||||||
|
evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs
|
||||||
|
evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs
|
||||||
|
evalAst _ ast = pure ast
|
||||||
|
|
||||||
|
|
||||||
|
evalDef :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalDef env (MalSymbol v : e : Nil) = do
|
||||||
|
evd <- evalAst env e
|
||||||
|
liftEffect $ Env.set env v evd
|
||||||
|
pure evd
|
||||||
|
evalDef _ _ = throw "invalid def!"
|
||||||
|
|
||||||
|
|
||||||
|
evalLet :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalLet env (MalList _ ps : e : Nil) = do
|
||||||
|
letEnv <- liftEffect $ Env.newEnv env
|
||||||
|
letBind letEnv ps
|
||||||
|
evalAst letEnv e
|
||||||
|
evalLet env (MalVector _ ps : e : Nil) = do
|
||||||
|
letEnv <- liftEffect $ Env.newEnv env
|
||||||
|
letBind letEnv ps
|
||||||
|
evalAst letEnv e
|
||||||
|
evalLet _ _ = throw "invalid let*"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
letBind :: RefEnv -> List MalExpr -> Eval Unit
|
||||||
|
letBind _ Nil = pure unit
|
||||||
|
letBind env (MalSymbol ky : e : es) = do
|
||||||
|
ex <- evalAst env e
|
||||||
|
liftEffect $ Env.set env ky ex
|
||||||
|
letBind env es
|
||||||
|
letBind _ _ = throw "invalid let*"
|
||||||
|
|
||||||
|
|
||||||
|
evalIf :: RefEnv -> List MalExpr -> SafeT Effect MalExpr
|
||||||
|
evalIf env (b:t:e:Nil) = do
|
||||||
|
cond <- evalAst env b
|
||||||
|
evalAst env case cond of
|
||||||
|
MalNil -> e
|
||||||
|
MalBoolean false -> e
|
||||||
|
_ -> t
|
||||||
|
evalIf env (b:t:Nil) = do
|
||||||
|
cond <- evalAst env b
|
||||||
|
evalAst env case cond of
|
||||||
|
MalNil -> MalNil
|
||||||
|
MalBoolean false -> MalNil
|
||||||
|
_ -> t
|
||||||
|
evalIf _ _ = throw "invalid if"
|
||||||
|
|
||||||
|
|
||||||
|
evalDo :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalDo env es = foldM (const $ evalAst env) MalNil es
|
||||||
|
|
||||||
|
|
||||||
|
evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body
|
||||||
|
evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body
|
||||||
|
evalFnMatch _ _ = throw "invalid fn*"
|
||||||
|
|
||||||
|
|
||||||
|
evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr
|
||||||
|
evalFn env params body = do
|
||||||
|
paramsStr <- traverse unwrapSymbol params
|
||||||
|
pure $ MalFunction { fn : fn paramsStr body
|
||||||
|
, ast : body
|
||||||
|
, env : env
|
||||||
|
, params : paramsStr
|
||||||
|
, macro : false
|
||||||
|
, meta : MalNil
|
||||||
|
}
|
||||||
|
where
|
||||||
|
|
||||||
|
fn :: List String -> MalExpr -> MalFn
|
||||||
|
fn params' body' = \args -> do
|
||||||
|
fnEnv <- Env.newEnv env
|
||||||
|
ok <- Env.sets fnEnv params' args
|
||||||
|
if ok
|
||||||
|
then runSafeT $ evalAst fnEnv body'
|
||||||
|
else throw "actual parameters do not match signature "
|
||||||
|
|
||||||
|
unwrapSymbol :: MalExpr -> Eval String
|
||||||
|
unwrapSymbol (MalSymbol s) = pure s
|
||||||
|
unwrapSymbol _ = throw "fn* parameter must be symbols"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- REPL
|
||||||
|
|
||||||
|
rep_ :: RefEnv -> String -> Effect Unit
|
||||||
|
rep_ env str = rep env str *> pure unit
|
||||||
|
|
||||||
|
|
||||||
|
rep :: RefEnv -> String -> Effect String
|
||||||
|
rep env str = case read str of
|
||||||
|
Left _ -> throw "EOF"
|
||||||
|
Right ast -> print =<< (runSafeT $ eval env ast)
|
||||||
|
|
||||||
|
|
||||||
|
loop :: RefEnv -> Effect Unit
|
||||||
|
loop env = do
|
||||||
|
line <- readLine "user> "
|
||||||
|
case line of
|
||||||
|
":q" -> pure unit
|
||||||
|
_ -> do
|
||||||
|
result <- try $ rep env line
|
||||||
|
case result of
|
||||||
|
Right exp -> log exp
|
||||||
|
Left err -> error $ show err
|
||||||
|
loop env
|
||||||
|
|
||||||
|
|
||||||
|
setFn :: RefEnv -> Tuple String MalFn -> Effect Unit
|
||||||
|
setFn env (Tuple sym f) = do
|
||||||
|
newEnv <- Env.newEnv Nil
|
||||||
|
Env.set env sym $ MalFunction
|
||||||
|
{ fn : f
|
||||||
|
, ast : MalNil
|
||||||
|
, env : newEnv
|
||||||
|
, params : Nil
|
||||||
|
, macro : false
|
||||||
|
, meta : MalNil
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- READ
|
||||||
|
|
||||||
|
read :: String -> Either String MalExpr
|
||||||
|
read = readStr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- PRINT
|
||||||
|
|
||||||
|
print :: MalExpr -> Effect String
|
||||||
|
print = printStr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- Utils
|
||||||
|
|
||||||
|
runSafeT :: ∀ m a. MonadRec m => SafeT m a -> m a
|
||||||
|
runSafeT = runFreeT $ pure <<< runIdentity
|
||||||
|
|
||||||
|
|
||||||
|
runIdentity :: ∀ a. Identity a -> a
|
||||||
|
runIdentity (Identity a) = a
|
||||||
|
|
||||||
|
|
||||||
|
throw :: forall m a. MonadEffect m => String -> m a
|
||||||
|
throw = liftEffect <<< Ex.throw
|
Loading…
Reference in New Issue
Block a user