mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 10:07:45 +03:00
10708752f6
Most changes are variable renamings because elm does not allow masking a visible name anymore. Deal with changes in the standard library, especially in the Parser interface. Source files must now start with a capital letter. Dockerfile: remove unneeded dependencies, install nodejs from debs. Remove the redundant Maybe from the return value of readstring. Stop embedding the colon in keyword represenation.
239 lines
5.1 KiB
Elm
239 lines
5.1 KiB
Elm
module Eval exposing (..)
|
|
|
|
import Types exposing (..)
|
|
import IO exposing (IO)
|
|
import Env
|
|
|
|
|
|
apply : Eval a -> Env -> EvalContext a
|
|
apply f env =
|
|
f env
|
|
|
|
|
|
run : Env -> Eval a -> EvalContext a
|
|
run env e =
|
|
apply e env
|
|
|
|
|
|
withEnv : (Env -> Eval a) -> Eval a
|
|
withEnv f env =
|
|
apply (f env) env
|
|
|
|
|
|
setEnv : Env -> Eval ()
|
|
setEnv env _ =
|
|
apply (succeed ()) env
|
|
|
|
|
|
modifyEnv : (Env -> Env) -> Eval ()
|
|
modifyEnv f env =
|
|
apply (succeed ()) (f env)
|
|
|
|
|
|
succeed : a -> Eval a
|
|
succeed res env =
|
|
( env, EvalOk res )
|
|
|
|
|
|
io : Cmd Msg -> (IO -> Eval a) -> Eval a
|
|
io cmd cont env =
|
|
( env, EvalIO cmd cont )
|
|
|
|
|
|
map : (a -> b) -> Eval a -> Eval b
|
|
map f e env0 =
|
|
case apply e env0 of
|
|
( env, EvalOk res ) ->
|
|
( env, EvalOk (f res) )
|
|
|
|
( env, EvalErr msg ) ->
|
|
( env, EvalErr msg )
|
|
|
|
( env, EvalIO cmd cont ) ->
|
|
( env, EvalIO cmd (cont >> map f) )
|
|
|
|
|
|
{-| Chain two Eval's together. The function f takes the result from
|
|
the left eval and generates a new Eval.
|
|
-}
|
|
andThen : (a -> Eval b) -> Eval a -> Eval b
|
|
andThen f e env0 =
|
|
case apply e env0 of
|
|
( env, EvalOk res ) ->
|
|
apply (f res) env
|
|
|
|
( env, EvalErr msg ) ->
|
|
( env, EvalErr msg )
|
|
|
|
( env, EvalIO cmd cont ) ->
|
|
( env, EvalIO cmd (cont >> andThen f) )
|
|
|
|
|
|
{-| Apply a transformation to the Env, for a Ok and a Err.
|
|
-}
|
|
finally : (Env -> Env) -> Eval a -> Eval a
|
|
finally f e env0 =
|
|
case apply e env0 of
|
|
( env, EvalOk res ) ->
|
|
( f env, EvalOk res )
|
|
|
|
( env, EvalErr msg ) ->
|
|
( f env, EvalErr msg )
|
|
|
|
( env, EvalIO cmd cont ) ->
|
|
( env, EvalIO cmd (cont >> finally f) )
|
|
|
|
|
|
gcPass : Eval MalExpr -> Eval MalExpr
|
|
gcPass e env0 =
|
|
let
|
|
go env t expr =
|
|
if env.gcCounter >= env.gcInterval then
|
|
--Debug.log
|
|
-- ("before GC: "
|
|
-- ++ (printEnv env)
|
|
-- )
|
|
-- ""
|
|
-- |> always ( Env.gc env, t expr )
|
|
( Env.gc expr env, t expr )
|
|
else
|
|
( env, t expr )
|
|
in
|
|
case apply e env0 of
|
|
( env, EvalOk res ) ->
|
|
go env EvalOk res
|
|
|
|
( env, EvalErr msg ) ->
|
|
go env EvalErr msg
|
|
|
|
( env, EvalIO cmd cont ) ->
|
|
( env, EvalIO cmd (cont >> gcPass) )
|
|
|
|
|
|
catchError : (MalExpr -> Eval a) -> Eval a -> Eval a
|
|
catchError f e env0 =
|
|
case apply e env0 of
|
|
( env, EvalOk res ) ->
|
|
( env, EvalOk res )
|
|
|
|
( env, EvalErr msg ) ->
|
|
apply (f msg) env
|
|
|
|
( env, EvalIO cmd cont ) ->
|
|
( env, EvalIO cmd (cont >> catchError f) )
|
|
|
|
|
|
fail : String -> Eval a
|
|
fail msg env =
|
|
( env, EvalErr <| MalString msg )
|
|
|
|
|
|
throw : MalExpr -> Eval a
|
|
throw ex env =
|
|
( env, EvalErr ex )
|
|
|
|
|
|
{-| Apply f to expr repeatedly.
|
|
Continues iterating if f returns (Left eval).
|
|
Stops if f returns (Right expr).
|
|
|
|
Tail call optimized.
|
|
|
|
-}
|
|
runLoop : (MalExpr -> Env -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr
|
|
runLoop f expr0 env0 =
|
|
case f expr0 env0 of
|
|
Left e ->
|
|
case apply e env0 of
|
|
( env, EvalOk expr ) ->
|
|
runLoop f expr env
|
|
|
|
( env, EvalErr msg ) ->
|
|
( env, EvalErr msg )
|
|
|
|
( env, EvalIO cmd cont ) ->
|
|
( env, EvalIO cmd (cont >> andThen (runLoop f)) )
|
|
|
|
Right expr ->
|
|
( env0, EvalOk expr )
|
|
|
|
|
|
fromResult : Result String a -> Eval a
|
|
fromResult res =
|
|
case res of
|
|
Ok val ->
|
|
succeed val
|
|
|
|
Err msg ->
|
|
fail msg
|
|
|
|
|
|
{-| Chain the left and right Eval but ignore the right's result.
|
|
-}
|
|
ignore : Eval b -> Eval a -> Eval a
|
|
ignore right left =
|
|
left
|
|
|> andThen
|
|
(\res ->
|
|
right
|
|
|> andThen (\_ -> succeed res)
|
|
)
|
|
|
|
|
|
withStack : Eval a -> Eval a
|
|
withStack e =
|
|
withEnv
|
|
(\env ->
|
|
e
|
|
|> ignore
|
|
(modifyEnv
|
|
(Env.restoreRefs env.stack)
|
|
)
|
|
)
|
|
|
|
|
|
pushRef : MalExpr -> Eval a -> Eval a
|
|
pushRef ref e =
|
|
modifyEnv (Env.pushRef ref)
|
|
|> andThen (always e)
|
|
|
|
|
|
inGlobal : Eval a -> Eval a
|
|
inGlobal body =
|
|
let
|
|
enter env =
|
|
setEnv
|
|
{ env
|
|
| keepFrames = env.currentFrameId :: env.keepFrames
|
|
, currentFrameId = Env.globalFrameId
|
|
}
|
|
|
|
leave oldEnv newEnv =
|
|
{ newEnv
|
|
| keepFrames = oldEnv.keepFrames
|
|
, currentFrameId = oldEnv.currentFrameId
|
|
}
|
|
in
|
|
withEnv
|
|
(\env ->
|
|
if env.currentFrameId /= Env.globalFrameId then
|
|
enter env
|
|
|> andThen (always body)
|
|
|> finally (leave env)
|
|
else
|
|
body
|
|
)
|
|
|
|
|
|
runSimple : Eval a -> Result MalExpr a
|
|
runSimple e =
|
|
case run Env.global e of
|
|
( _, EvalOk res ) ->
|
|
Ok res
|
|
|
|
( _, EvalErr msg ) ->
|
|
Err msg
|
|
|
|
_ ->
|
|
Debug.todo "can't happen"
|