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 {-| Chain two Eval's together. The function f takes the result from
  57 the left eval and generates a new Eval.
  58 -}
  59 andThen : (a -> Eval b) -> Eval a -> Eval b
  60 andThen f e env =
  61     case apply e env of
  62         ( env, EvalOk res ) ->
  63             apply (f res) env
  64
  65         ( env, EvalErr msg ) ->
  66             ( env, EvalErr msg )
  67
  68         ( env, EvalIO cmd cont ) ->
  69             ( env, EvalIO cmd (cont >> andThen f) )
  70
  71
  72 {-| Apply a transformation to the Env, for a Ok and a Err.
  73 -}
  74 finally : (Env -> Env) -> Eval a -> Eval a
  75 finally f e env =
  76     case apply e env of
  77         ( env, EvalOk res ) ->
  78             ( f env, EvalOk res )
  79
  80         ( env, EvalErr msg ) ->
  81             ( f env, EvalErr msg )
  82
  83         ( env, EvalIO cmd cont ) ->
  84             ( env, EvalIO cmd (cont >> finally f) )
  85
  86
  87 gcPass : Eval MalExpr -> Eval MalExpr
  88 gcPass e env =
  89     let
  90         go env t expr =
  91             if env.gcCounter >= env.gcInterval then
  92                 --Debug.log
  93                 --    ("before GC: "
  94                 --        ++ (printEnv env)
  95                 --    )
  96                 --    ""
  97                 --    |> always ( Env.gc env, t expr )
  98                 ( Env.gc expr env, t expr )
  99             else
 100                 ( env, t expr )
 101     in
 102         case apply e env of
 103             ( env, EvalOk res ) ->
 104                 go env EvalOk res
 105
 106             ( env, EvalErr msg ) ->
 107                 go env EvalErr msg
 108
 109             ( env, EvalIO cmd cont ) ->
 110                 ( env, EvalIO cmd (cont >> gcPass) )
 111
 112
 113 catchError : (MalExpr -> Eval a) -> Eval a -> Eval a
 114 catchError f e env =
 115     case apply e env of
 116         ( env, EvalOk res ) ->
 117             ( env, EvalOk res )
 118
 119         ( env, EvalErr msg ) ->
 120             apply (f msg) env
 121
 122         ( env, EvalIO cmd cont ) ->
 123             ( env, EvalIO cmd (cont >> catchError f) )
 124
 125
 126 fail : String -> Eval a
 127 fail msg env =
 128     ( env, EvalErr <| MalString msg )
 129
 130
 131 throw : MalExpr -> Eval a
 132 throw ex env =
 133     ( env, EvalErr ex )
 134
 135
 136 {-| Apply f to expr repeatedly.
 137 Continues iterating if f returns (Left eval).
 138 Stops if f returns (Right expr).
 139
 140 Tail call optimized.
 141
 142 -}
 143 runLoop : (MalExpr -> Env -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr
 144 runLoop f expr env =
 145     case f expr env of
 146         Left e ->
 147             case apply e env of
 148                 ( env, EvalOk expr ) ->
 149                     runLoop f expr env
 150
 151                 ( env, EvalErr msg ) ->
 152                     ( env, EvalErr msg )
 153
 154                 ( env, EvalIO cmd cont ) ->
 155                     ( env, EvalIO cmd (cont >> andThen (runLoop f)) )
 156
 157         Right expr ->
 158             ( env, EvalOk expr )
 159
 160
 161 fromResult : Result String a -> Eval a
 162 fromResult res =
 163     case res of
 164         Ok val ->
 165             succeed val
 166
 167         Err msg ->
 168             fail msg
 169
 170
 171 {-| Chain the left and right Eval but ignore the right's result.
 172 -}
 173 ignore : Eval b -> Eval a -> Eval a
 174 ignore right left =
 175     left
 176         |> andThen
 177             (\res ->
 178                 right
 179                     |> andThen (\_ -> succeed res)
 180             )
 181
 182
 183 withStack : Eval a -> Eval a
 184 withStack e =
 185     withEnv
 186         (\env ->
 187             e
 188                 |> ignore
 189                     (modifyEnv
 190                         (Env.restoreRefs env.stack)
 191                     )
 192         )
 193
 194
 195 pushRef : MalExpr -> Eval a -> Eval a
 196 pushRef ref e =
 197     modifyEnv (Env.pushRef ref)
 198         |> andThen (always e)
 199
 200
 201 inGlobal : Eval a -> Eval a
 202 inGlobal body =
 203     let
 204         enter env =
 205             setEnv
 206                 { env
 207                     | keepFrames = env.currentFrameId :: env.keepFrames
 208                     , currentFrameId = Env.globalFrameId
 209                 }
 210
 211         leave oldEnv newEnv =
 212             { newEnv
 213                 | keepFrames = oldEnv.keepFrames
 214                 , currentFrameId = oldEnv.currentFrameId
 215             }
 216     in
 217         withEnv
 218             (\env ->
 219                 if env.currentFrameId /= Env.globalFrameId then
 220                     enter env
 221                         |> andThen (always body)
 222                         |> finally (leave env)
 223                 else
 224                     body
 225             )
 226
 227
 228 runSimple : Eval a -> Result MalExpr a
 229 runSimple e =
 230     case run Env.global e of
 231         ( _, EvalOk res ) ->
 232             Ok res
 233
 234         ( _, EvalErr msg ) ->
 235             Err msg
 236
 237         _ ->
 238             Debug.crash "can't happen"