elm/step4_if_fn_do.elm

   1 port module Main exposing (..)
   2
   3 import Array
   4 import Dict exposing (Dict)
   5 import IO exposing (..)
   6 import Json.Decode exposing (decodeValue)
   7 import Platform exposing (programWithFlags)
   8 import Types exposing (..)
   9 import Reader exposing (readString)
  10 import Printer exposing (printString)
  11 import Utils exposing (maybeToList, zip, last, justValues)
  12 import Env
  13 import Core
  14 import Eval
  15
  16
  17 main : Program Flags Model Msg
  18 main =
  19     programWithFlags
  20         { init = init
  21         , update = update
  22         , subscriptions =
  23             \model -> input (decodeValue decodeIO >> Input)
  24         }
  25
  26
  27 type alias Flags =
  28     { args : List String
  29     }
  30
  31
  32 type Model
  33     = InitIO Env (IO -> Eval MalExpr)
  34     | InitError String
  35     | ReplActive Env
  36     | ReplIO Env (IO -> Eval MalExpr)
  37
  38
  39 init : Flags -> ( Model, Cmd Msg )
  40 init { args } =
  41     let
  42         initEnv =
  43             Core.ns
  44
  45         evalMalInit =
  46             malInit
  47                 |> List.map rep
  48                 |> justValues
  49                 |> List.foldl
  50                     (\b a -> a |> Eval.andThen (\_ -> b))
  51                     (Eval.succeed MalNil)
  52     in
  53         runInit initEnv evalMalInit
  54
  55
  56 malInit : List String
  57 malInit =
  58     [ """(def! not
  59             (fn* (a)
  60                 (if a false true)))"""
  61     ]
  62
  63
  64 update : Msg -> Model -> ( Model, Cmd Msg )
  65 update msg model =
  66     case model of
  67         InitError _ ->
  68             -- ignore all
  69             ( model, Cmd.none )
  70
  71         InitIO env cont ->
  72             case msg of
  73                 Input (Ok io) ->
  74                     runInit env (cont io)
  75
  76                 Input (Err msg) ->
  77                     Debug.crash msg
  78
  79         ReplActive env ->
  80             case msg of
  81                 Input (Ok (LineRead (Just line))) ->
  82                     case rep line of
  83                         Just expr ->
  84                             run env expr
  85
  86                         Nothing ->
  87                             ( model, readLine prompt )
  88
  89                 Input (Ok LineWritten) ->
  90                     ( model, readLine prompt )
  91
  92                 Input (Ok (LineRead Nothing)) ->
  93                     -- Ctrl+D = The End.
  94                     ( model, Cmd.none )
  95
  96                 Input (Ok io) ->
  97                     Debug.crash "unexpected IO received: " io
  98
  99                 Input (Err msg) ->
 100                     Debug.crash msg
 101
 102         ReplIO env cont ->
 103             case msg of
 104                 Input (Ok io) ->
 105                     run env (cont io)
 106
 107                 Input (Err msg) ->
 108                     Debug.crash msg ( model, Cmd.none )
 109
 110
 111 runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg )
 112 runInit env expr =
 113     case Eval.run env expr of
 114         ( env, EvalOk expr ) ->
 115             -- Init went okay, start REPL.
 116             ( ReplActive env, readLine prompt )
 117
 118         ( env, EvalErr msg ) ->
 119             -- Init failed, don't start REPL.
 120             ( InitError msg, writeLine ("ERR:" ++ msg) )
 121
 122         ( env, EvalIO cmd cont ) ->
 123             -- IO in init.
 124             ( InitIO env cont, cmd )
 125
 126
 127 run : Env -> Eval MalExpr -> ( Model, Cmd Msg )
 128 run env expr =
 129     case Eval.run env expr of
 130         ( env, EvalOk expr ) ->
 131             ( ReplActive env, writeLine (print env expr) )
 132
 133         ( env, EvalErr msg ) ->
 134             ( ReplActive env, writeLine ("ERR:" ++ msg) )
 135
 136         ( env, EvalIO cmd cont ) ->
 137             ( ReplIO env cont, cmd )
 138
 139
 140 prompt : String
 141 prompt =
 142     "user> "
 143
 144
 145 {-| read can return three things:
 146
 147 Ok (Just expr) -> parsed okay
 148 Ok Nothing -> empty string (only whitespace and/or comments)
 149 Err msg -> parse error
 150
 151 -}
 152 read : String -> Result String (Maybe MalExpr)
 153 read =
 154     readString
 155
 156
 157 eval : MalExpr -> Eval MalExpr
 158 eval ast =
 159     case ast of
 160         MalList [] ->
 161             Eval.succeed ast
 162
 163         MalList ((MalSymbol "def!") :: args) ->
 164             evalDef args
 165
 166         MalList ((MalSymbol "let*") :: args) ->
 167             evalLet args
 168
 169         MalList ((MalSymbol "do") :: args) ->
 170             evalDo args
 171
 172         MalList ((MalSymbol "if") :: args) ->
 173             evalIf args
 174
 175         MalList ((MalSymbol "fn*") :: args) ->
 176             evalFn args
 177
 178         MalList list ->
 179             evalList list
 180                 |> Eval.andThen
 181                     (\newList ->
 182                         case newList of
 183                             [] ->
 184                                 Eval.fail "can't happen"
 185
 186                             (MalFunction (CoreFunc fn)) :: args ->
 187                                 fn args
 188
 189                             (MalFunction (UserFunc { eagerFn })) :: args ->
 190                                 eagerFn args
 191
 192                             fn :: _ ->
 193                                 Eval.withEnv
 194                                     (\env ->
 195                                         Eval.fail ((printString env True fn) ++ " is not a function")
 196                                     )
 197                     )
 198
 199         _ ->
 200             evalAst ast
 201
 202
 203 evalAst : MalExpr -> Eval MalExpr
 204 evalAst ast =
 205     case ast of
 206         MalSymbol sym ->
 207             -- Lookup symbol in env and return value or raise error if not found.
 208             Eval.withEnv
 209                 (\env ->
 210                     case Env.get sym env of
 211                         Ok val ->
 212                             Eval.succeed val
 213
 214                         Err msg ->
 215                             Eval.fail msg
 216                 )
 217
 218         MalList list ->
 219             -- Return new list that is result of calling eval on each element of list.
 220             evalList list
 221                 |> Eval.map MalList
 222
 223         MalVector vec ->
 224             evalList (Array.toList vec)
 225                 |> Eval.map (Array.fromList >> MalVector)
 226
 227         MalMap map ->
 228             evalList (Dict.values map)
 229                 |> Eval.map
 230                     (zip (Dict.keys map)
 231                         >> Dict.fromList
 232                         >> MalMap
 233                     )
 234
 235         _ ->
 236             Eval.succeed ast
 237
 238
 239 evalList : List MalExpr -> Eval (List MalExpr)
 240 evalList list =
 241     let
 242         go list acc =
 243             case list of
 244                 [] ->
 245                     Eval.succeed (List.reverse acc)
 246
 247                 x :: rest ->
 248                     eval x
 249                         |> Eval.andThen
 250                             (\val ->
 251                                 go rest (val :: acc)
 252                             )
 253     in
 254         go list []
 255
 256
 257 evalDef : List MalExpr -> Eval MalExpr
 258 evalDef args =
 259     case args of
 260         [ MalSymbol name, uneValue ] ->
 261             eval uneValue
 262                 |> Eval.andThen
 263                     (\value ->
 264                         Eval.modifyEnv (Env.set name value)
 265                             |> Eval.andThen (\_ -> Eval.succeed value)
 266                     )
 267
 268         _ ->
 269             Eval.fail "def! expected two args: name and value"
 270
 271
 272 evalLet : List MalExpr -> Eval MalExpr
 273 evalLet args =
 274     let
 275         evalBinds binds =
 276             case binds of
 277                 (MalSymbol name) :: expr :: rest ->
 278                     eval expr
 279                         |> Eval.andThen
 280                             (\value ->
 281                                 Eval.modifyEnv (Env.set name value)
 282                                     |> Eval.andThen
 283                                         (\_ ->
 284                                             if List.isEmpty rest then
 285                                                 Eval.succeed ()
 286                                             else
 287                                                 evalBinds rest
 288                                         )
 289                             )
 290
 291                 _ ->
 292                     Eval.fail "let* expected an even number of binds (symbol expr ..)"
 293
 294         go binds body =
 295             Eval.modifyEnv Env.push
 296                 |> Eval.andThen (\_ -> evalBinds binds)
 297                 |> Eval.andThen (\_ -> eval body)
 298                 |> Eval.andThen
 299                     (\res ->
 300                         Eval.modifyEnv Env.pop
 301                             |> Eval.map (\_ -> res)
 302                     )
 303     in
 304         case args of
 305             [ MalList binds, body ] ->
 306                 go binds body
 307
 308             [ MalVector bindsVec, body ] ->
 309                 go (Array.toList bindsVec) body
 310
 311             _ ->
 312                 Eval.fail "let* expected two args: binds and a body"
 313
 314
 315 evalDo : List MalExpr -> Eval MalExpr
 316 evalDo args =
 317     let
 318         returnLast list =
 319             case last list of
 320                 Just value ->
 321                     Eval.succeed value
 322
 323                 Nothing ->
 324                     Eval.fail "do expected at least one arg"
 325     in
 326         evalList args
 327             |> Eval.andThen returnLast
 328
 329
 330 evalIf : List MalExpr -> Eval MalExpr
 331 evalIf args =
 332     let
 333         isThruthy expr =
 334             expr /= MalNil && expr /= (MalBool False)
 335
 336         go condition trueExpr falseExpr =
 337             eval condition
 338                 |> Eval.map isThruthy
 339                 |> Eval.andThen
 340                     (\cond ->
 341                         eval
 342                             (if cond then
 343                                 trueExpr
 344                              else
 345                                 falseExpr
 346                             )
 347                     )
 348     in
 349         case args of
 350             [ condition, trueExpr ] ->
 351                 go condition trueExpr MalNil
 352
 353             [ condition, trueExpr, falseExpr ] ->
 354                 go condition trueExpr falseExpr
 355
 356             _ ->
 357                 Eval.fail "if expected at least two args"
 358
 359
 360 evalFn : List MalExpr -> Eval MalExpr
 361 evalFn args =
 362     let
 363         {- Extract symbols from the binds list and verify their uniqueness -}
 364         extractSymbols acc list =
 365             case list of
 366                 [] ->
 367                     Ok (List.reverse acc)
 368
 369                 (MalSymbol name) :: rest ->
 370                     if List.member name acc then
 371                         Err "all binds must have unique names"
 372                     else
 373                         extractSymbols (name :: acc) rest
 374
 375                 _ ->
 376                     Err "all binds in fn* must be a symbol"
 377
 378         parseBinds list =
 379             case List.reverse list of
 380                 var :: "&" :: rest ->
 381                     Ok <| bindVarArgs (List.reverse rest) var
 382
 383                 _ ->
 384                     if List.member "&" list then
 385                         Err "varargs separator '&' is used incorrectly"
 386                     else
 387                         Ok <| bindArgs list
 388
 389         extractAndParse =
 390             extractSymbols [] >> Result.andThen parseBinds
 391
 392         bindArgs binds args =
 393             let
 394                 numBinds =
 395                     List.length binds
 396             in
 397                 if List.length args /= numBinds then
 398                     Err <|
 399                         "function expected "
 400                             ++ (toString numBinds)
 401                             ++ " arguments"
 402                 else
 403                     Ok <| zip binds args
 404
 405         bindVarArgs binds var args =
 406             let
 407                 minArgs =
 408                     List.length binds
 409
 410                 varArgs =
 411                     MalList (List.drop minArgs args)
 412             in
 413                 if List.length args < minArgs then
 414                     Err <|
 415                         "function expected at least "
 416                             ++ (toString minArgs)
 417                             ++ " arguments"
 418                 else
 419                     Ok <| zip binds args ++ [ ( var, varArgs ) ]
 420
 421         makeFn frameId binder body =
 422             let
 423                 fn args =
 424                     case binder args of
 425                         Ok bound ->
 426                             Eval.enter frameId bound (eval body)
 427
 428                         Err msg ->
 429                             Eval.fail msg
 430             in
 431                 MalFunction <|
 432                     UserFunc
 433                         { frameId = frameId
 434                         , lazyFn = fn
 435                         , eagerFn = fn
 436                         , isMacro = False
 437                         }
 438
 439         go bindsList body =
 440             case extractAndParse bindsList of
 441                 Ok binder ->
 442                     Eval.modifyEnv Env.ref
 443                         -- reference the current frame.
 444                         |> Eval.andThen
 445                             (\_ ->
 446                                 Eval.withEnv
 447                                     (\env ->
 448                                         Eval.succeed
 449                                             (makeFn env.currentFrameId binder body)
 450                                     )
 451                             )
 452
 453                 Err msg ->
 454                     Eval.fail msg
 455     in
 456         case args of
 457             [ MalList bindsList, body ] ->
 458                 go bindsList body
 459
 460             [ MalVector bindsVec, body ] ->
 461                 go (Array.toList bindsVec) body
 462
 463             _ ->
 464                 Eval.fail "fn* expected two args: binds list and body"
 465
 466
 467 print : Env -> MalExpr -> String
 468 print env =
 469     printString env True
 470
 471
 472 {-| Read-Eval-Print.
 473
 474 Doesn't actually run the Eval but returns the monad.
 475
 476 -}
 477 rep : String -> Maybe (Eval MalExpr)
 478 rep input =
 479     case readString input of
 480         Ok Nothing ->
 481             Nothing
 482
 483         Err msg ->
 484             Just (Eval.fail msg)
 485
 486         Ok (Just ast) ->
 487             eval ast |> Just