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