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