elm/Eval.elm

   1 module Eval exposing (..)
   2
   3 import Types exposing (..)
   4 import IO exposing (IO)
   5 import Env
   6
   7
   8 apply : Eval a -> Env -> EvalContext a
   9 apply f env =
  10     f env
  11
  12
  13 run : Env -> Eval a -> EvalContext a
  14 run env e =
  15     apply e env
  16
  17
  18 withEnv : (Env -> Eval a) -> Eval a
  19 withEnv f env =
  20     apply (f env) env
  21
  22
  23 setEnv : Env -> Eval ()
  24 setEnv env _ =
  25     apply (succeed ()) env
  26
  27
  28 modifyEnv : (Env -> Env) -> Eval ()
  29 modifyEnv f env =
  30     apply (succeed ()) (f env)
  31
  32
  33 succeed : a -> Eval a
  34 succeed res env =
  35     ( env, EvalOk res )
  36
  37
  38 io : Cmd Msg -> (IO -> Eval a) -> Eval a
  39 io cmd cont env =
  40     ( env, EvalIO cmd cont )
  41
  42
  43 map : (a -> b) -> Eval a -> Eval b
  44 map f e env =
  45     case apply e env of
  46         ( env, EvalOk res ) ->
  47             ( env, EvalOk (f res) )
  48
  49         ( env, EvalErr msg ) ->
  50             ( env, EvalErr msg )
  51
  52         ( env, EvalIO cmd cont ) ->
  53             ( env, EvalIO cmd (cont >> map f) )
  54
  55
  56 andThen : (a -> Eval b) -> Eval a -> Eval b
  57 andThen f e env =
  58     case apply e env of
  59         ( env, EvalOk res ) ->
  60             apply (f res) env
  61
  62         ( env, EvalErr msg ) ->
  63             ( env, EvalErr msg )
  64
  65         ( env, EvalIO cmd cont ) ->
  66             ( env, EvalIO cmd (cont >> andThen f) )
  67
  68
  69 catchError : (MalExpr -> Eval a) -> Eval a -> Eval a
  70 catchError f e env =
  71     case apply e env of
  72         ( env, EvalOk res ) ->
  73             ( env, EvalOk res )
  74
  75         ( env, EvalErr msg ) ->
  76             apply (f msg) env
  77
  78         ( env, EvalIO cmd cont ) ->
  79             ( env, EvalIO cmd (cont >> catchError f) )
  80
  81
  82 fail : String -> Eval a
  83 fail msg env =
  84     ( env, EvalErr <| MalString msg )
  85
  86
  87 throw : MalExpr -> Eval a
  88 throw ex env =
  89     ( env, EvalErr ex )
  90
  91
  92 enter : Int -> List ( String, MalExpr ) -> Eval a -> Eval a
  93 enter frameId bound body =
  94     withEnv
  95         (\env ->
  96             modifyEnv (Env.enter frameId bound)
  97                 |> andThen (always body)
  98                 |> andThen
  99                     (\res ->
 100                         modifyEnv (Env.leave env.currentFrameId)
 101                             |> map (always res)
 102                     )
 103         )
 104
 105
 106 {-| Apply f to expr repeatedly.
 107 Continues iterating if f returns (Left eval).
 108 Stops if f returns (Right expr).
 109
 110 Tail call optimized.
 111
 112 -}
 113 runLoop : (MalExpr -> Env -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr
 114 runLoop f expr env =
 115     case f expr env of
 116         Left e ->
 117             case apply e env of
 118                 ( env, EvalOk expr ) ->
 119                     runLoop f expr env
 120
 121                 ( env, EvalErr msg ) ->
 122                     ( env, EvalErr msg )
 123
 124                 ( env, EvalIO cmd cont ) ->
 125                     ( env, EvalIO cmd (cont >> andThen (runLoop f)) )
 126
 127         Right expr ->
 128             ( env, EvalOk expr )
 129
 130
 131 fromResult : Result String a -> Eval a
 132 fromResult res =
 133     case res of
 134         Ok val ->
 135             succeed val
 136
 137         Err msg ->
 138             fail msg
 139
 140
 141 {-| Chain the left and right Eval but ignore the right's result.
 142 -}
 143 ignore : Eval b -> Eval a -> Eval a
 144 ignore right left =
 145     left
 146         |> andThen
 147             (\res ->
 148                 right
 149                     |> andThen (\_ -> succeed res)
 150             )