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