elm/step5_tco.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
  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, writeLine (printError env 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 (printError env 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 debug : String -> (Env -> a) -> Eval b -> Eval b
 158 debug msg f e =
 159     Eval.withEnv
 160         (\env ->
 161             Env.debug env msg (f env)
 162                 |> always e
 163         )
 164
 165
 166 eval : MalExpr -> Eval MalExpr
 167 eval ast =
 168     let
 169         apply expr env =
 170             case expr of
 171                 MalApply app ->
 172                     Left
 173                         (debug "evalApply"
 174                             (\env -> printString env True expr)
 175                             (evalApply app)
 176                         )
 177
 178                 _ ->
 179                     Right expr
 180     in
 181         evalNoApply ast
 182             |> Eval.andThen (Eval.runLoop apply)
 183
 184
 185 evalApply : ApplyRec -> Eval MalExpr
 186 evalApply { frameId, bound, body } =
 187     Eval.withEnv
 188         (\env ->
 189             Eval.modifyEnv (Env.enter frameId bound)
 190                 |> Eval.andThen (\_ -> evalNoApply body)
 191                 |> Eval.finally Env.leave
 192                 |> Eval.gcPass
 193         )
 194
 195
 196 evalNoApply : MalExpr -> Eval MalExpr
 197 evalNoApply ast =
 198     debug "evalNoApply"
 199         (\env -> printString env True ast)
 200         (case ast of
 201             MalList [] ->
 202                 Eval.succeed ast
 203
 204             MalList ((MalSymbol "def!") :: args) ->
 205                 evalDef args
 206
 207             MalList ((MalSymbol "let*") :: args) ->
 208                 evalLet args
 209
 210             MalList ((MalSymbol "do") :: args) ->
 211                 evalDo args
 212
 213             MalList ((MalSymbol "if") :: args) ->
 214                 evalIf args
 215
 216             MalList ((MalSymbol "fn*") :: args) ->
 217                 evalFn args
 218
 219             MalList list ->
 220                 evalList list
 221                     |> Eval.andThen
 222                         (\newList ->
 223                             case newList of
 224                                 [] ->
 225                                     Eval.fail "can't happen"
 226
 227                                 (MalFunction (CoreFunc fn)) :: args ->
 228                                     fn args
 229
 230                                 (MalFunction (UserFunc { lazyFn })) :: args ->
 231                                     lazyFn args
 232
 233                                 fn :: _ ->
 234                                     Eval.withEnv
 235                                         (\env ->
 236                                             Eval.fail ((printString env True fn) ++ " is not a function")
 237                                         )
 238                         )
 239
 240             _ ->
 241                 evalAst ast
 242         )
 243
 244
 245 evalAst : MalExpr -> Eval MalExpr
 246 evalAst ast =
 247     case ast of
 248         MalSymbol sym ->
 249             -- Lookup symbol in env and return value or raise error if not found.
 250             Eval.withEnv
 251                 (\env ->
 252                     case Env.get sym env of
 253                         Ok val ->
 254                             Eval.succeed val
 255
 256                         Err msg ->
 257                             Eval.fail msg
 258                 )
 259
 260         MalList list ->
 261             -- Return new list that is result of calling eval on each element of list.
 262             evalList list
 263                 |> Eval.map MalList
 264
 265         MalVector vec ->
 266             evalList (Array.toList vec)
 267                 |> Eval.map (Array.fromList >> MalVector)
 268
 269         MalMap map ->
 270             evalList (Dict.values map)
 271                 |> Eval.map
 272                     (zip (Dict.keys map)
 273                         >> Dict.fromList
 274                         >> MalMap
 275                     )
 276
 277         _ ->
 278             Eval.succeed ast
 279
 280
 281 evalList : List MalExpr -> Eval (List MalExpr)
 282 evalList list =
 283     let
 284         go list acc =
 285             case list of
 286                 [] ->
 287                     Eval.succeed (List.reverse acc)
 288
 289                 x :: rest ->
 290                     eval x
 291                         |> Eval.andThen
 292                             (\val ->
 293                                 go rest (val :: acc)
 294                             )
 295     in
 296         go list []
 297
 298
 299 evalDef : List MalExpr -> Eval MalExpr
 300 evalDef args =
 301     case args of
 302         [ MalSymbol name, uneValue ] ->
 303             eval uneValue
 304                 |> Eval.andThen
 305                     (\value ->
 306                         Eval.modifyEnv (Env.set name value)
 307                             |> Eval.andThen (\_ -> Eval.succeed value)
 308                     )
 309
 310         _ ->
 311             Eval.fail "def! expected two args: name and value"
 312
 313
 314 evalLet : List MalExpr -> Eval MalExpr
 315 evalLet args =
 316     let
 317         evalBinds binds =
 318             case binds of
 319                 (MalSymbol name) :: expr :: rest ->
 320                     eval expr
 321                         |> Eval.andThen
 322                             (\value ->
 323                                 Eval.modifyEnv (Env.set name value)
 324                                     |> Eval.andThen
 325                                         (\_ ->
 326                                             if List.isEmpty rest then
 327                                                 Eval.succeed ()
 328                                             else
 329                                                 evalBinds rest
 330                                         )
 331                             )
 332
 333                 _ ->
 334                     Eval.fail "let* expected an even number of binds (symbol expr ..)"
 335
 336         go binds body =
 337             Eval.modifyEnv Env.push
 338                 |> Eval.andThen (\_ -> evalBinds binds)
 339                 |> Eval.andThen (\_ -> evalNoApply body)
 340                 |> Eval.andThen
 341                     (\res ->
 342                         Eval.modifyEnv Env.pop
 343                             |> Eval.map (\_ -> res)
 344                     )
 345     in
 346         case args of
 347             [ MalList binds, body ] ->
 348                 go binds body
 349
 350             [ MalVector bindsVec, body ] ->
 351                 go (Array.toList bindsVec) body
 352
 353             _ ->
 354                 Eval.fail "let* expected two args: binds and a body"
 355
 356
 357 evalDo : List MalExpr -> Eval MalExpr
 358 evalDo args =
 359     case List.reverse args of
 360         last :: rest ->
 361             evalList (List.reverse rest)
 362                 |> Eval.andThen (\_ -> evalNoApply last)
 363
 364         [] ->
 365             Eval.fail "do expected at least one arg"
 366
 367
 368 evalIf : List MalExpr -> Eval MalExpr
 369 evalIf args =
 370     let
 371         isThruthy expr =
 372             expr /= MalNil && expr /= (MalBool False)
 373
 374         go condition trueExpr falseExpr =
 375             eval condition
 376                 |> Eval.map isThruthy
 377                 |> Eval.andThen
 378                     (\cond ->
 379                         evalNoApply
 380                             (if cond then
 381                                 trueExpr
 382                              else
 383                                 falseExpr
 384                             )
 385                     )
 386     in
 387         case args of
 388             [ condition, trueExpr ] ->
 389                 go condition trueExpr MalNil
 390
 391             [ condition, trueExpr, falseExpr ] ->
 392                 go condition trueExpr falseExpr
 393
 394             _ ->
 395                 Eval.fail "if expected at least two args"
 396
 397
 398 evalFn : List MalExpr -> Eval MalExpr
 399 evalFn args =
 400     let
 401         {- Extract symbols from the binds list and verify their uniqueness -}
 402         extractSymbols acc list =
 403             case list of
 404                 [] ->
 405                     Ok (List.reverse acc)
 406
 407                 (MalSymbol name) :: rest ->
 408                     if List.member name acc then
 409                         Err "all binds must have unique names"
 410                     else
 411                         extractSymbols (name :: acc) rest
 412
 413                 _ ->
 414                     Err "all binds in fn* must be a symbol"
 415
 416         parseBinds list =
 417             case List.reverse list of
 418                 var :: "&" :: rest ->
 419                     Ok <| bindVarArgs (List.reverse rest) var
 420
 421                 _ ->
 422                     if List.member "&" list then
 423                         Err "varargs separator '&' is used incorrectly"
 424                     else
 425                         Ok <| bindArgs list
 426
 427         extractAndParse =
 428             extractSymbols [] >> Result.andThen parseBinds
 429
 430         bindArgs binds args =
 431             let
 432                 numBinds =
 433                     List.length binds
 434             in
 435                 if List.length args /= numBinds then
 436                     Err <|
 437                         "function expected "
 438                             ++ (toString numBinds)
 439                             ++ " arguments"
 440                 else
 441                     Ok <| zip binds args
 442
 443         bindVarArgs binds var args =
 444             let
 445                 minArgs =
 446                     List.length binds
 447
 448                 varArgs =
 449                     MalList (List.drop minArgs args)
 450             in
 451                 if List.length args < minArgs then
 452                     Err <|
 453                         "function expected at least "
 454                             ++ (toString minArgs)
 455                             ++ " arguments"
 456                 else
 457                     Ok <| zip binds args ++ [ ( var, varArgs ) ]
 458
 459         makeFn frameId binder body =
 460             MalFunction <|
 461                 let
 462                     lazyFn args =
 463                         case binder args of
 464                             Ok bound ->
 465                                 Eval.succeed <|
 466                                     MalApply
 467                                         { frameId = frameId
 468                                         , bound = bound
 469                                         , body = body
 470                                         }
 471
 472                             Err msg ->
 473                                 Eval.fail msg
 474                 in
 475                     UserFunc
 476                         { frameId = frameId
 477                         , lazyFn = lazyFn
 478                         , eagerFn = lazyFn >> Eval.andThen eval
 479                         , isMacro = False
 480                         , meta = Nothing
 481                         }
 482
 483         go bindsList body =
 484             case extractAndParse bindsList of
 485                 Ok binder ->
 486                     Eval.modifyEnv Env.ref
 487                         -- reference the current frame.
 488                         |> Eval.andThen
 489                             (\_ ->
 490                                 Eval.withEnv
 491                                     (\env ->
 492                                         Eval.succeed
 493                                             (makeFn env.currentFrameId binder body)
 494                                     )
 495                             )
 496
 497                 Err msg ->
 498                     Eval.fail msg
 499     in
 500         case args of
 501             [ MalList bindsList, body ] ->
 502                 go bindsList body
 503
 504             [ MalVector bindsVec, body ] ->
 505                 go (Array.toList bindsVec) body
 506
 507             _ ->
 508                 Eval.fail "fn* expected two args: binds list and body"
 509
 510
 511 print : Env -> MalExpr -> String
 512 print env =
 513     printString env True
 514
 515
 516 printError : Env -> MalExpr -> String
 517 printError env expr =
 518     "Error: " ++ (printString env False expr)
 519
 520
 521 {-| Read-Eval-Print.
 522
 523 Doesn't actually run the Eval but returns the monad.
 524
 525 -}
 526 rep : String -> Maybe (Eval MalExpr)
 527 rep input =
 528     case readString input of
 529         Ok Nothing ->
 530             Nothing
 531
 532         Err msg ->
 533             Just (Eval.fail msg)
 534
 535         Ok (Just ast) ->
 536             eval ast |> Just