elm/step3_env.elm

   1 port module Main exposing (..)
   2
   3 import IO exposing (..)
   4 import Json.Decode exposing (decodeValue)
   5 import Platform exposing (programWithFlags)
   6 import Types exposing (..)
   7 import Reader exposing (readString)
   8 import Printer exposing (printString)
   9 import Utils exposing (maybeToList, zip)
  10 import Dict exposing (Dict)
  11 import Tuple exposing (mapFirst, mapSecond, second)
  12 import Array
  13 import Env
  14 import Eval
  15
  16
  17 main : Program Flags Model Msg
  18 main =
  19     programWithFlags
  20         { init = init
  21         , update = update
  22         , subscriptions = \model -> input (decodeValue decodeIO >> Input)
  23         }
  24
  25
  26 type alias Flags =
  27     { args : List String
  28     }
  29
  30
  31 type alias Model =
  32     { args : List String
  33     , env : Env
  34     }
  35
  36
  37 type Msg
  38     = Input (Result String IO)
  39
  40
  41 init : Flags -> ( Model, Cmd Msg )
  42 init { args } =
  43     ( { args = args, env = initReplEnv }, readLine prompt )
  44
  45
  46 initReplEnv : Env
  47 initReplEnv =
  48     let
  49         makeFn =
  50             CoreFunc >> MalFunction
  51
  52         binaryOp fn args =
  53             case args of
  54                 [ MalInt x, MalInt y ] ->
  55                     Eval.succeed <| MalInt (fn x y)
  56
  57                 _ ->
  58                     Eval.fail "unsupported arguments"
  59     in
  60         Env.global
  61             |> Env.set "+" (makeFn <| binaryOp (+))
  62             |> Env.set "-" (makeFn <| binaryOp (-))
  63             |> Env.set "*" (makeFn <| binaryOp (*))
  64             |> Env.set "/" (makeFn <| binaryOp (//))
  65
  66
  67 update : Msg -> Model -> ( Model, Cmd Msg )
  68 update msg model =
  69     case msg of
  70         Input (Ok (LineRead (Just line))) ->
  71             case rep model.env line of
  72                 Nothing ->
  73                     ( model, readLine prompt )
  74
  75                 Just ( result, newEnv ) ->
  76                     ( { model | env = newEnv }, writeLine (makeOutput result) )
  77
  78         Input (Ok LineWritten) ->
  79             ( model, readLine prompt )
  80
  81         Input (Ok (LineRead Nothing)) ->
  82             ( model, Cmd.none )
  83
  84         Input (Ok io) ->
  85             Debug.crash "unexpected IO received: " io
  86
  87         Input (Err msg) ->
  88             Debug.crash msg ( model, Cmd.none )
  89
  90
  91 makeOutput : Result String String -> String
  92 makeOutput result =
  93     case result of
  94         Ok str ->
  95             str
  96
  97         Err msg ->
  98             "Error: " ++ msg
  99
 100
 101 prompt : String
 102 prompt =
 103     "user> "
 104
 105
 106 {-| read can return three things:
 107
 108 Ok (Just expr) -> parsed okay
 109 Ok Nothing -> empty string (only whitespace and/or comments)
 110 Err msg -> parse error
 111
 112 -}
 113 read : String -> Result String (Maybe MalExpr)
 114 read =
 115     readString
 116
 117
 118 eval : Env -> MalExpr -> ( Result String MalExpr, Env )
 119 eval env ast =
 120     case ast of
 121         MalList [] ->
 122             ( Ok ast, env )
 123
 124         MalList ((MalSymbol "def!") :: args) ->
 125             evalDef env args
 126
 127         MalList ((MalSymbol "let*") :: args) ->
 128             evalLet env args
 129
 130         MalList list ->
 131             case evalList env list [] of
 132                 ( Ok newList, newEnv ) ->
 133                     case newList of
 134                         [] ->
 135                             ( Err "can't happen", newEnv )
 136
 137                         (MalFunction (CoreFunc fn)) :: args ->
 138                             case Eval.runSimple (fn args) of
 139                                 Ok res ->
 140                                     ( Ok res, newEnv )
 141
 142                                 Err msg ->
 143                                     ( Err (print msg), newEnv )
 144
 145                         fn :: _ ->
 146                             ( Err ((print fn) ++ " is not a function"), newEnv )
 147
 148                 ( Err msg, newEnv ) ->
 149                     ( Err msg, newEnv )
 150
 151         _ ->
 152             evalAst env ast
 153
 154
 155 evalAst : Env -> MalExpr -> ( Result String MalExpr, Env )
 156 evalAst env ast =
 157     case ast of
 158         MalSymbol sym ->
 159             -- Lookup symbol in env and return value or raise error if not found.
 160             case Env.get sym env of
 161                 Ok val ->
 162                     ( Ok val, env )
 163
 164                 Err msg ->
 165                     ( Err msg, env )
 166
 167         MalList list ->
 168             -- Return new list that is result of calling eval on each element of list.
 169             evalList env list []
 170                 |> mapFirst (Result.map MalList)
 171
 172         MalVector vec ->
 173             evalList env (Array.toList vec) []
 174                 |> mapFirst (Result.map (Array.fromList >> MalVector))
 175
 176         MalMap map ->
 177             evalList env (Dict.values map) []
 178                 |> mapFirst
 179                     (Result.map
 180                         (zip (Dict.keys map)
 181                             >> Dict.fromList
 182                             >> MalMap
 183                         )
 184                     )
 185
 186         _ ->
 187             ( Ok ast, env )
 188
 189
 190 evalList : Env -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), Env )
 191 evalList env list acc =
 192     case list of
 193         [] ->
 194             ( Ok (List.reverse acc), env )
 195
 196         x :: rest ->
 197             case eval env x of
 198                 ( Ok val, newEnv ) ->
 199                     evalList newEnv rest (val :: acc)
 200
 201                 ( Err msg, newEnv ) ->
 202                     ( Err msg, newEnv )
 203
 204
 205 evalDef : Env -> List MalExpr -> ( Result String MalExpr, Env )
 206 evalDef env args =
 207     case args of
 208         [ MalSymbol name, uneValue ] ->
 209             case eval env uneValue of
 210                 ( Ok value, newEnv ) ->
 211                     ( Ok value, Env.set name value newEnv )
 212
 213                 err ->
 214                     err
 215
 216         _ ->
 217             ( Err "def! expected two args: name and value", env )
 218
 219
 220 evalLet : Env -> List MalExpr -> ( Result String MalExpr, Env )
 221 evalLet env args =
 222     let
 223         evalBinds env binds =
 224             case binds of
 225                 (MalSymbol name) :: expr :: rest ->
 226                     case eval env expr of
 227                         ( Ok value, newEnv ) ->
 228                             let
 229                                 newEnv =
 230                                     Env.set name value env
 231                             in
 232                                 if List.isEmpty rest then
 233                                     Ok newEnv
 234                                 else
 235                                     evalBinds newEnv rest
 236
 237                         ( Err msg, _ ) ->
 238                             Err msg
 239
 240                 _ ->
 241                     Err "let* expected an even number of binds (symbol expr ..)"
 242
 243         go binds body =
 244             case evalBinds (Env.push env) binds of
 245                 Ok newEnv ->
 246                     eval newEnv body
 247                         |> mapSecond (\_ -> Env.pop newEnv)
 248
 249                 Err msg ->
 250                     ( Err msg, env )
 251     in
 252         case args of
 253             [ MalList binds, body ] ->
 254                 go binds body
 255
 256             [ MalVector bindsVec, body ] ->
 257                 go (Array.toList bindsVec) body
 258
 259             _ ->
 260                 ( Err "let* expected two args: binds and a body", env )
 261
 262
 263 {-| Try to map a list with a fn that can return a Err.
 264
 265 Maps the list from left to right. As soon as a error
 266 occurs it will not process any more elements and return
 267 the error.
 268
 269 -}
 270 tryMapList : (a -> Result e b) -> List a -> Result e (List b)
 271 tryMapList fn list =
 272     let
 273         go x =
 274             Result.andThen
 275                 (\acc ->
 276                     case fn x of
 277                         Ok val ->
 278                             Ok (val :: acc)
 279
 280                         Err msg ->
 281                             Err msg
 282                 )
 283     in
 284         List.foldl go (Ok []) list
 285             |> Result.map List.reverse
 286
 287
 288 print : MalExpr -> String
 289 print =
 290     printString Env.global True
 291
 292
 293 {-| Read-Eval-Print. rep returns:
 294
 295 Nothing -> if an empty string is read (ws/comments)
 296 Just ((Ok out), newEnv) -> input has been evaluated.
 297 Just ((Err msg), env) -> error parsing or evaluating.
 298
 299 -}
 300 rep : Env -> String -> Maybe ( Result String String, Env )
 301 rep env input =
 302     let
 303         evalPrint =
 304             eval env >> mapFirst (Result.map print)
 305     in
 306         case readString input of
 307             Ok Nothing ->
 308                 Nothing
 309
 310             Err msg ->
 311                 Just ( Err msg, env )
 312
 313             Ok (Just ast) ->
 314                 Just (evalPrint ast)