mirror of
https://github.com/kanaka/mal.git
synced 2024-08-17 01:30:26 +03:00
feat: purescript step8
This commit is contained in:
parent
16ca69b275
commit
eac997e1ca
@ -12,3 +12,4 @@ step4_if_fn_do.purs = Mal.Step4
|
|||||||
step5_tco.purs = Mal.Step5
|
step5_tco.purs = Mal.Step5
|
||||||
step6_file.purs = Mal.Step6
|
step6_file.purs = Mal.Step6
|
||||||
step7_quote.purs = Mal.Step7
|
step7_quote.purs = Mal.Step7
|
||||||
|
step8_macros.purs = Mal.Step8
|
||||||
|
@ -7,11 +7,10 @@ import Control.Monad.Free.Trans (FreeT, runFreeT)
|
|||||||
import Control.Monad.Rec.Class (class MonadRec)
|
import Control.Monad.Rec.Class (class MonadRec)
|
||||||
import Core as Core
|
import Core as Core
|
||||||
import Data.Either (Either(..))
|
import Data.Either (Either(..))
|
||||||
import Data.Foldable (traverse_)
|
|
||||||
import Data.Identity (Identity(..))
|
import Data.Identity (Identity(..))
|
||||||
import Data.List (List(..), foldM, (:))
|
import Data.List (List(..), foldM, (:))
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Maybe (Maybe(..))
|
||||||
import Data.Traversable (traverse)
|
import Data.Traversable (traverse, traverse_)
|
||||||
import Data.Tuple (Tuple(..))
|
import Data.Tuple (Tuple(..))
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Effect.Class (class MonadEffect, liftEffect)
|
import Effect.Class (class MonadEffect, liftEffect)
|
||||||
@ -48,7 +47,7 @@ eval _ ast@(MalList _ Nil) = pure ast
|
|||||||
eval env (MalList _ ast) = case ast of
|
eval env (MalList _ ast) = case ast of
|
||||||
MalSymbol "def!" : es -> evalDef env es
|
MalSymbol "def!" : es -> evalDef env es
|
||||||
MalSymbol "let*" : es -> evalLet env es
|
MalSymbol "let*" : es -> evalLet env es
|
||||||
MalSymbol "if" : es -> evalIf env es >>= eval env
|
MalSymbol "if" : es -> evalIf env es
|
||||||
MalSymbol "do" : es -> evalDo env es
|
MalSymbol "do" : es -> evalDo env es
|
||||||
MalSymbol "fn*" : es -> evalFnMatch env es
|
MalSymbol "fn*" : es -> evalFnMatch env es
|
||||||
_ -> do
|
_ -> do
|
||||||
@ -68,7 +67,7 @@ evalAst env (MalSymbol s) = do
|
|||||||
result <- liftEffect $ Env.get env s
|
result <- liftEffect $ Env.get env s
|
||||||
case result of
|
case result of
|
||||||
Just k -> pure k
|
Just k -> pure k
|
||||||
Nothing -> liftEffect $ throw $ "'" <> s <> "'" <> " not found"
|
Nothing -> throw $ "'" <> s <> "'" <> " not found"
|
||||||
evalAst env ast@(MalList _ _) = eval env ast
|
evalAst env ast@(MalList _ _) = eval env ast
|
||||||
evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs
|
evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs
|
||||||
evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs
|
evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs
|
||||||
@ -108,13 +107,13 @@ letBind _ _ = throw "invalid let*"
|
|||||||
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
|
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
evalIf env (b:t:e:Nil) = do
|
evalIf env (b:t:e:Nil) = do
|
||||||
cond <- evalAst env b
|
cond <- evalAst env b
|
||||||
pure case cond of
|
evalAst env case cond of
|
||||||
MalNil -> e
|
MalNil -> e
|
||||||
MalBoolean false -> e
|
MalBoolean false -> e
|
||||||
_ -> t
|
_ -> t
|
||||||
evalIf env (b:t:Nil) = do
|
evalIf env (b:t:Nil) = do
|
||||||
cond <- evalAst env b
|
cond <- evalAst env b
|
||||||
pure case cond of
|
evalAst env case cond of
|
||||||
MalNil -> MalNil
|
MalNil -> MalNil
|
||||||
MalBoolean false -> MalNil
|
MalBoolean false -> MalNil
|
||||||
_ -> t
|
_ -> t
|
||||||
@ -220,5 +219,5 @@ runIdentity :: ∀ a. Identity a -> a
|
|||||||
runIdentity (Identity a) = a
|
runIdentity (Identity a) = a
|
||||||
|
|
||||||
|
|
||||||
throw :: forall m a. MonadEffect m => String -> m a
|
throw :: ∀ m a. MonadEffect m => String -> m a
|
||||||
throw = liftEffect <<< Ex.throw
|
throw = liftEffect <<< Ex.throw
|
@ -99,7 +99,7 @@ eval _ ast@(MalList _ Nil) = pure ast
|
|||||||
eval env (MalList _ ast) = case ast of
|
eval env (MalList _ ast) = case ast of
|
||||||
MalSymbol "def!" : es -> evalDef env es
|
MalSymbol "def!" : es -> evalDef env es
|
||||||
MalSymbol "let*" : es -> evalLet env es
|
MalSymbol "let*" : es -> evalLet env es
|
||||||
MalSymbol "if" : es -> evalIf env es >>= eval env
|
MalSymbol "if" : es -> evalIf env es
|
||||||
MalSymbol "do" : es -> evalDo env es
|
MalSymbol "do" : es -> evalDo env es
|
||||||
MalSymbol "fn*" : es -> evalFnMatch env es
|
MalSymbol "fn*" : es -> evalFnMatch env es
|
||||||
_ -> do
|
_ -> do
|
||||||
@ -119,7 +119,7 @@ evalAst env (MalSymbol s) = do
|
|||||||
result <- liftEffect $ Env.get env s
|
result <- liftEffect $ Env.get env s
|
||||||
case result of
|
case result of
|
||||||
Just k -> pure k
|
Just k -> pure k
|
||||||
Nothing -> liftEffect $ throw $ "'" <> s <> "'" <> " not found"
|
Nothing -> throw $ "'" <> s <> "'" <> " not found"
|
||||||
evalAst env ast@(MalList _ _) = eval env ast
|
evalAst env ast@(MalList _ _) = eval env ast
|
||||||
evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs
|
evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs
|
||||||
evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs
|
evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs
|
||||||
@ -159,13 +159,13 @@ letBind _ _ = throw "invalid let*"
|
|||||||
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
|
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
evalIf env (b:t:e:Nil) = do
|
evalIf env (b:t:e:Nil) = do
|
||||||
cond <- evalAst env b
|
cond <- evalAst env b
|
||||||
pure case cond of
|
evalAst env case cond of
|
||||||
MalNil -> e
|
MalNil -> e
|
||||||
MalBoolean false -> e
|
MalBoolean false -> e
|
||||||
_ -> t
|
_ -> t
|
||||||
evalIf env (b:t:Nil) = do
|
evalIf env (b:t:Nil) = do
|
||||||
cond <- evalAst env b
|
cond <- evalAst env b
|
||||||
pure case cond of
|
evalAst env case cond of
|
||||||
MalNil -> MalNil
|
MalNil -> MalNil
|
||||||
MalBoolean false -> MalNil
|
MalBoolean false -> MalNil
|
||||||
_ -> t
|
_ -> t
|
||||||
@ -232,5 +232,5 @@ runIdentity :: ∀ a. Identity a -> a
|
|||||||
runIdentity (Identity a) = a
|
runIdentity (Identity a) = a
|
||||||
|
|
||||||
|
|
||||||
throw :: forall m a. MonadEffect m => String -> m a
|
throw :: ∀ m a. MonadEffect m => String -> m a
|
||||||
throw = liftEffect <<< Ex.throw
|
throw = liftEffect <<< Ex.throw
|
@ -98,7 +98,7 @@ eval _ ast@(MalList _ Nil) = pure ast
|
|||||||
eval env (MalList _ ast) = case ast of
|
eval env (MalList _ ast) = case ast of
|
||||||
MalSymbol "def!" : es -> evalDef env es
|
MalSymbol "def!" : es -> evalDef env es
|
||||||
MalSymbol "let*" : es -> evalLet env es
|
MalSymbol "let*" : es -> evalLet env es
|
||||||
MalSymbol "if" : es -> evalIf env es >>= eval env
|
MalSymbol "if" : es -> evalIf env es
|
||||||
MalSymbol "do" : es -> evalDo env es
|
MalSymbol "do" : es -> evalDo env es
|
||||||
MalSymbol "fn*" : es -> evalFnMatch env es
|
MalSymbol "fn*" : es -> evalFnMatch env es
|
||||||
MalSymbol "quote" : es -> evalQuote env es
|
MalSymbol "quote" : es -> evalQuote env es
|
||||||
@ -112,7 +112,7 @@ eval env (MalList _ ast) = case ast of
|
|||||||
newEnv <- liftEffect $ Env.newEnv env'
|
newEnv <- liftEffect $ Env.newEnv env'
|
||||||
_ <- liftEffect $ Env.sets newEnv params' args
|
_ <- liftEffect $ Env.sets newEnv params' args
|
||||||
eval newEnv ast'
|
eval newEnv ast'
|
||||||
_ -> throw "invalid function"
|
_ -> throw "invalid function"
|
||||||
eval env ast = evalAst env ast
|
eval env ast = evalAst env ast
|
||||||
|
|
||||||
|
|
||||||
@ -160,13 +160,13 @@ letBind _ _ = throw "invalid let*"
|
|||||||
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
|
evalIf :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
evalIf env (b:t:e:Nil) = do
|
evalIf env (b:t:e:Nil) = do
|
||||||
cond <- evalAst env b
|
cond <- evalAst env b
|
||||||
pure case cond of
|
evalAst env case cond of
|
||||||
MalNil -> e
|
MalNil -> e
|
||||||
MalBoolean false -> e
|
MalBoolean false -> e
|
||||||
_ -> t
|
_ -> t
|
||||||
evalIf env (b:t:Nil) = do
|
evalIf env (b:t:Nil) = do
|
||||||
cond <- evalAst env b
|
cond <- evalAst env b
|
||||||
pure case cond of
|
evalAst env case cond of
|
||||||
MalNil -> MalNil
|
MalNil -> MalNil
|
||||||
MalBoolean false -> MalNil
|
MalBoolean false -> MalNil
|
||||||
_ -> t
|
_ -> t
|
||||||
@ -268,5 +268,5 @@ runIdentity :: ∀ a. Identity a -> a
|
|||||||
runIdentity (Identity a) = a
|
runIdentity (Identity a) = a
|
||||||
|
|
||||||
|
|
||||||
throw :: forall m a. MonadEffect m => String -> m a
|
throw :: ∀ m a. MonadEffect m => String -> m a
|
||||||
throw = liftEffect <<< Ex.throw
|
throw = liftEffect <<< Ex.throw
|
329
impls/purs/src/step8_macros.purs
Normal file
329
impls/purs/src/step8_macros.purs
Normal file
@ -0,0 +1,329 @@
|
|||||||
|
module Mal.Step8 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.Identity (Identity(..))
|
||||||
|
import Data.List (List(..), foldM, (:))
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
import Data.Traversable (traverse, 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 (args, readLine)
|
||||||
|
import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector)
|
||||||
|
|
||||||
|
|
||||||
|
-- TYPES
|
||||||
|
|
||||||
|
type Eval a = FreeT Identity Effect a
|
||||||
|
|
||||||
|
|
||||||
|
-- MAIN
|
||||||
|
|
||||||
|
main :: Effect Unit
|
||||||
|
main = do
|
||||||
|
env <- Env.newEnv Nil
|
||||||
|
traverse_ (setFn env) Core.ns
|
||||||
|
setFn env (Tuple "eval" $ setEval env)
|
||||||
|
rep_ env "(def! not (fn* (a) (if a false true)))"
|
||||||
|
rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"
|
||||||
|
rep_ env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
|
||||||
|
case args of
|
||||||
|
Nil -> do
|
||||||
|
Env.set env "*ARGV*" $ toList Nil
|
||||||
|
loop env
|
||||||
|
script:scriptArgs -> do
|
||||||
|
Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs
|
||||||
|
rep_ env $ "(load-file \"" <> script <> "\")"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- 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 =<< (runEval $ evalAst 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
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
setEval :: RefEnv -> MalFn
|
||||||
|
setEval env (ast:Nil) = runEval $ eval env ast
|
||||||
|
setEval _ _ = throw "illegal call of eval"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- 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
|
||||||
|
MalSymbol "do" : es -> evalDo env es
|
||||||
|
MalSymbol "fn*" : es -> evalFnMatch env es
|
||||||
|
|
||||||
|
MalSymbol "quote" : es -> evalQuote env es
|
||||||
|
MalSymbol "quasiquote" : es -> evalQuasiquote env es
|
||||||
|
MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es
|
||||||
|
|
||||||
|
MalSymbol "defmacro!" : es -> evalDefmacro env es
|
||||||
|
MalSymbol "macroexpand" : es -> evalMacroexpand 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
|
||||||
|
newEnv <- liftEffect $ Env.newEnv env'
|
||||||
|
_ <- liftEffect $ Env.sets newEnv params' args
|
||||||
|
eval newEnv ast'
|
||||||
|
_ -> throw "invalid function"
|
||||||
|
eval env ast = evalAst env ast
|
||||||
|
|
||||||
|
|
||||||
|
evalAst :: RefEnv -> MalExpr -> Eval MalExpr
|
||||||
|
evalAst env ast = do
|
||||||
|
newAst <- macroexpand env ast
|
||||||
|
case newAst of
|
||||||
|
MalSymbol s -> do
|
||||||
|
result <- liftEffect $ Env.get env s
|
||||||
|
case result of
|
||||||
|
Just k -> pure k
|
||||||
|
Nothing -> throw $ "'" <> s <> "'" <> " not found"
|
||||||
|
l@(MalList _ _ ) -> eval env l
|
||||||
|
MalVector _ es -> toVector <$> traverse (evalAst env) es
|
||||||
|
MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es
|
||||||
|
_ -> pure newAst
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- DEF
|
||||||
|
|
||||||
|
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!"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- LET
|
||||||
|
|
||||||
|
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*"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- IF
|
||||||
|
|
||||||
|
evalIf :: RefEnv -> List MalExpr -> Eval 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"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- DO
|
||||||
|
|
||||||
|
evalDo :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalDo env es = foldM (const $ evalAst env) MalNil es
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- FUNCTION
|
||||||
|
|
||||||
|
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 runEval $ 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"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- QUOTE
|
||||||
|
|
||||||
|
evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalQuote _ (e:Nil) = pure e
|
||||||
|
evalQuote _ _ = throw "invalid quote"
|
||||||
|
|
||||||
|
|
||||||
|
evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e
|
||||||
|
evalQuasiquote _ _ = throw "invalid quasiquote"
|
||||||
|
|
||||||
|
|
||||||
|
evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr
|
||||||
|
evalQuasiquoteexpand (e:Nil) = quasiquote e
|
||||||
|
evalQuasiquoteexpand _ = throw "invalid quasiquote"
|
||||||
|
|
||||||
|
|
||||||
|
quasiquote :: MalExpr -> Eval MalExpr
|
||||||
|
quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x
|
||||||
|
quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote"
|
||||||
|
quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs
|
||||||
|
quasiquote (MalVector _ xs) = do
|
||||||
|
lst <- foldrM qqIter (toList Nil) xs
|
||||||
|
pure $ toList $ MalSymbol "vec" : lst : Nil
|
||||||
|
quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil
|
||||||
|
quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil
|
||||||
|
quasiquote ast = pure ast
|
||||||
|
|
||||||
|
|
||||||
|
qqIter :: MalExpr -> MalExpr -> Eval MalExpr
|
||||||
|
qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil
|
||||||
|
qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote"
|
||||||
|
qqIter elt acc = do
|
||||||
|
qqted <- quasiquote elt
|
||||||
|
pure $ toList $ MalSymbol "cons" : qqted : acc : Nil
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- MACRO
|
||||||
|
|
||||||
|
evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalDefmacro env (MalSymbol a : b : Nil) = do
|
||||||
|
f <- evalAst env b
|
||||||
|
case f of
|
||||||
|
MalFunction fn@{macro:false} -> do
|
||||||
|
let m = MalFunction $ fn {macro = true}
|
||||||
|
liftEffect $ Env.set env a m
|
||||||
|
pure m
|
||||||
|
_ -> throw "defmacro! on non-function"
|
||||||
|
evalDefmacro _ _ = throw "invalid defmacro!"
|
||||||
|
|
||||||
|
|
||||||
|
evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr
|
||||||
|
evalMacroexpand env (a:Nil) = macroexpand env a
|
||||||
|
evalMacroexpand _ _ = throw "invalid macroexpand"
|
||||||
|
|
||||||
|
|
||||||
|
macroexpand :: RefEnv -> MalExpr -> Eval MalExpr
|
||||||
|
macroexpand env ast@(MalList _ (MalSymbol a : args)) = do
|
||||||
|
maybeMacro <- liftEffect $ Env.get env a
|
||||||
|
case maybeMacro of
|
||||||
|
Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args)
|
||||||
|
_ -> pure ast
|
||||||
|
macroexpand _ ast = pure ast
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- READ
|
||||||
|
|
||||||
|
read :: String -> Either String MalExpr
|
||||||
|
read = readStr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- PRINT
|
||||||
|
|
||||||
|
print :: MalExpr -> Effect String
|
||||||
|
print = printStr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- Utils
|
||||||
|
|
||||||
|
runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a
|
||||||
|
runEval = runFreeT $ pure <<< runIdentity
|
||||||
|
|
||||||
|
|
||||||
|
runIdentity :: ∀ a. Identity a -> a
|
||||||
|
runIdentity (Identity a) = a
|
||||||
|
|
||||||
|
|
||||||
|
throw :: ∀ m a. MonadEffect m => String -> m a
|
||||||
|
throw = liftEffect <<< Ex.throw
|
Loading…
Reference in New Issue
Block a user