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.withEnv
 250                 (\env ->
 251                     Eval.modifyEnv (Env.jump Env.globalFrameId)
 252                         |> Eval.andThen (\_ -> eval expr)
 253                         |> Eval.finally Env.leave
 254                 )
 255
 256         _ ->
 257             Eval.fail "unsupported arguments"
 258
 259
 260 evalApply : ApplyRec -> Eval MalExpr
 261 evalApply { frameId, bound, body } =
 262     Eval.withEnv
 263         (\env ->
 264             Eval.modifyEnv (Env.enter frameId bound)
 265                 |> Eval.andThen (\_ -> evalNoApply body)
 266                 |> Eval.finally Env.leave
 267                 |> Eval.gcPass []
 268         )
 269
 270
 271 evalNoApply : MalExpr -> Eval MalExpr
 272 evalNoApply ast =
 273     debug "evalNoApply"
 274         (\env -> printString env True ast)
 275         (case ast of
 276             MalList [] ->
 277                 Eval.succeed ast
 278
 279             MalList ((MalSymbol "def!") :: args) ->
 280                 evalDef args
 281
 282             MalList ((MalSymbol "let*") :: args) ->
 283                 evalLet args
 284
 285             MalList ((MalSymbol "do") :: args) ->
 286                 evalDo args
 287
 288             MalList ((MalSymbol "if") :: args) ->
 289                 evalIf args
 290
 291             MalList ((MalSymbol "fn*") :: args) ->
 292                 evalFn args
 293
 294             MalList list ->
 295                 evalList list
 296                     |> Eval.andThen
 297                         (\newList ->
 298                             case newList of
 299                                 [] ->
 300                                     Eval.fail "can't happen"
 301
 302                                 (MalFunction (CoreFunc fn)) :: args ->
 303                                     fn args
 304
 305                                 (MalFunction (UserFunc { lazyFn })) :: args ->
 306                                     lazyFn args
 307
 308                                 fn :: _ ->
 309                                     Eval.withEnv
 310                                         (\env ->
 311                                             Eval.fail ((printString env True fn) ++ " is not a function")
 312                                         )
 313                         )
 314
 315             _ ->
 316                 evalAst ast
 317         )
 318
 319
 320 evalAst : MalExpr -> Eval MalExpr
 321 evalAst ast =
 322     case ast of
 323         MalSymbol sym ->
 324             -- Lookup symbol in env and return value or raise error if not found.
 325             Eval.withEnv
 326                 (\env ->
 327                     case Env.get sym env of
 328                         Ok val ->
 329                             Eval.succeed val
 330
 331                         Err msg ->
 332                             Eval.fail msg
 333                 )
 334
 335         MalList list ->
 336             -- Return new list that is result of calling eval on each element of list.
 337             evalList list
 338                 |> Eval.map MalList
 339
 340         MalVector vec ->
 341             evalList (Array.toList vec)
 342                 |> Eval.map (Array.fromList >> MalVector)
 343
 344         MalMap map ->
 345             evalList (Dict.values map)
 346                 |> Eval.map
 347                     (zip (Dict.keys map)
 348                         >> Dict.fromList
 349                         >> MalMap
 350                     )
 351
 352         _ ->
 353             Eval.succeed ast
 354
 355
 356 evalList : List MalExpr -> Eval (List MalExpr)
 357 evalList list =
 358     let
 359         go list acc =
 360             case list of
 361                 [] ->
 362                     Eval.succeed (List.reverse acc)
 363
 364                 x :: rest ->
 365                     eval x
 366                         |> Eval.andThen
 367                             (\val ->
 368                                 go rest (val :: acc)
 369                             )
 370     in
 371         go list []
 372
 373
 374 evalDef : List MalExpr -> Eval MalExpr
 375 evalDef args =
 376     case args of
 377         [ MalSymbol name, uneValue ] ->
 378             eval uneValue
 379                 |> Eval.andThen
 380                     (\value ->
 381                         Eval.modifyEnv (Env.set name value)
 382                             |> Eval.andThen (\_ -> Eval.succeed value)
 383                     )
 384
 385         _ ->
 386             Eval.fail "def! expected two args: name and value"
 387
 388
 389 evalLet : List MalExpr -> Eval MalExpr
 390 evalLet args =
 391     let
 392         evalBinds binds =
 393             case binds of
 394                 (MalSymbol name) :: expr :: rest ->
 395                     eval expr
 396                         |> Eval.andThen
 397                             (\value ->
 398                                 Eval.modifyEnv (Env.set name value)
 399                                     |> Eval.andThen
 400                                         (\_ ->
 401                                             if List.isEmpty rest then
 402                                                 Eval.succeed ()
 403                                             else
 404                                                 evalBinds rest
 405                                         )
 406                             )
 407
 408                 _ ->
 409                     Eval.fail "let* expected an even number of binds (symbol expr ..)"
 410
 411         go binds body =
 412             Eval.modifyEnv Env.push
 413                 |> Eval.andThen (\_ -> evalBinds binds)
 414                 |> Eval.andThen (\_ -> evalNoApply body)
 415                 |> Eval.andThen
 416                     (\res ->
 417                         Eval.modifyEnv Env.pop
 418                             |> Eval.map (\_ -> res)
 419                     )
 420     in
 421         case args of
 422             [ MalList binds, body ] ->
 423                 go binds body
 424
 425             [ MalVector bindsVec, body ] ->
 426                 go (Array.toList bindsVec) body
 427
 428             _ ->
 429                 Eval.fail "let* expected two args: binds and a body"
 430
 431
 432 evalDo : List MalExpr -> Eval MalExpr
 433 evalDo args =
 434     case List.reverse args of
 435         last :: rest ->
 436             evalList (List.reverse rest)
 437                 |> Eval.andThen (\_ -> evalNoApply last)
 438
 439         [] ->
 440             Eval.fail "do expected at least one arg"
 441
 442
 443 evalIf : List MalExpr -> Eval MalExpr
 444 evalIf args =
 445     let
 446         isThruthy expr =
 447             expr /= MalNil && expr /= (MalBool False)
 448
 449         go condition trueExpr falseExpr =
 450             eval condition
 451                 |> Eval.map isThruthy
 452                 |> Eval.andThen
 453                     (\cond ->
 454                         evalNoApply
 455                             (if cond then
 456                                 trueExpr
 457                              else
 458                                 falseExpr
 459                             )
 460                     )
 461     in
 462         case args of
 463             [ condition, trueExpr ] ->
 464                 go condition trueExpr MalNil
 465
 466             [ condition, trueExpr, falseExpr ] ->
 467                 go condition trueExpr falseExpr
 468
 469             _ ->
 470                 Eval.fail "if expected at least two args"
 471
 472
 473 evalFn : List MalExpr -> Eval MalExpr
 474 evalFn args =
 475     let
 476         {- Extract symbols from the binds list and verify their uniqueness -}
 477         extractSymbols acc list =
 478             case list of
 479                 [] ->
 480                     Ok (List.reverse acc)
 481
 482                 (MalSymbol name) :: rest ->
 483                     if List.member name acc then
 484                         Err "all binds must have unique names"
 485                     else
 486                         extractSymbols (name :: acc) rest
 487
 488                 _ ->
 489                     Err "all binds in fn* must be a symbol"
 490
 491         parseBinds list =
 492             case List.reverse list of
 493                 var :: "&" :: rest ->
 494                     Ok <| bindVarArgs (List.reverse rest) var
 495
 496                 _ ->
 497                     if List.member "&" list then
 498                         Err "varargs separator '&' is used incorrectly"
 499                     else
 500                         Ok <| bindArgs list
 501
 502         extractAndParse =
 503             extractSymbols [] >> Result.andThen parseBinds
 504
 505         bindArgs binds args =
 506             let
 507                 numBinds =
 508                     List.length binds
 509             in
 510                 if List.length args /= numBinds then
 511                     Err <|
 512                         "function expected "
 513                             ++ (toString numBinds)
 514                             ++ " arguments"
 515                 else
 516                     Ok <| zip binds args
 517
 518         bindVarArgs binds var args =
 519             let
 520                 minArgs =
 521                     List.length binds
 522
 523                 varArgs =
 524                     MalList (List.drop minArgs args)
 525             in
 526                 if List.length args < minArgs then
 527                     Err <|
 528                         "function expected at least "
 529                             ++ (toString minArgs)
 530                             ++ " arguments"
 531                 else
 532                     Ok <| zip binds args ++ [ ( var, varArgs ) ]
 533
 534         makeFn frameId binder body =
 535             MalFunction <|
 536                 let
 537                     lazyFn args =
 538                         case binder args of
 539                             Ok bound ->
 540                                 Eval.succeed <|
 541                                     MalApply
 542                                         { frameId = frameId
 543                                         , bound = bound
 544                                         , body = body
 545                                         }
 546
 547                             Err msg ->
 548                                 Eval.fail msg
 549                 in
 550                     UserFunc
 551                         { frameId = frameId
 552                         , lazyFn = lazyFn
 553                         , eagerFn = \_ -> lazyFn >> Eval.andThen eval
 554                         , isMacro = False
 555                         , meta = Nothing
 556                         }
 557
 558         go bindsList body =
 559             case extractAndParse bindsList of
 560                 Ok binder ->
 561                     Eval.modifyEnv Env.ref
 562                         -- reference the current frame.
 563                         |> Eval.andThen
 564                             (\_ ->
 565                                 Eval.withEnv
 566                                     (\env ->
 567                                         Eval.succeed
 568                                             (makeFn env.currentFrameId binder body)
 569                                     )
 570                             )
 571
 572                 Err msg ->
 573                     Eval.fail msg
 574     in
 575         case args of
 576             [ MalList bindsList, body ] ->
 577                 go bindsList body
 578
 579             [ MalVector bindsVec, body ] ->
 580                 go (Array.toList bindsVec) body
 581
 582             _ ->
 583                 Eval.fail "fn* expected two args: binds list and body"
 584
 585
 586 print : Env -> MalExpr -> String
 587 print env =
 588     printString env True
 589
 590
 591 printError : Env -> MalExpr -> String
 592 printError env expr =
 593     "ERR:" ++ (printString env False expr)
 594
 595
 596 {-| Read-Eval-Print.
 597
 598 Doesn't actually run the Eval but returns the monad.
 599
 600 -}
 601 rep : String -> Maybe (Eval MalExpr)
 602 rep input =
 603     case readString input of
 604         Ok Nothing ->
 605             Nothing
 606
 607         Err msg ->
 608             Just (Eval.fail msg)
 609
 610         Ok (Just ast) ->
 611             eval ast |> Just