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