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 "quasiquote") :: args) ->
 303                     case args of
 304                         [ expr ] ->
 305                             -- TCO.
 306                             evalNoApply (evalQuasiQuote expr)
 307
 308                         _ ->
 309                             Eval.fail "unsupported arguments"
 310
 311                 MalList ((MalSymbol "defmacro!") :: args) ->
 312                     evalDefMacro args
 313
 314                 MalList ((MalSymbol "macroexpand") :: args) ->
 315                     case args of
 316                         [ expr ] ->
 317                             macroexpand expr
 318
 319                         _ ->
 320                             Eval.fail "unsupported arguments"
 321
 322                 MalList ((MalSymbol "try*") :: args) ->
 323                     evalTry args
 324
 325                 MalList list ->
 326                     evalList list
 327                         |> Eval.andThen
 328                             (\newList ->
 329                                 case newList of
 330                                     [] ->
 331                                         Eval.fail "can't happen"
 332
 333                                     (MalFunction (CoreFunc fn)) :: args ->
 334                                         fn args
 335
 336                                     (MalFunction (UserFunc { lazyFn })) :: args ->
 337                                         lazyFn args
 338
 339                                     fn :: _ ->
 340                                         Eval.withEnv
 341                                             (\env ->
 342                                                 Eval.fail ((printString env True fn) ++ " is not a function")
 343                                             )
 344                             )
 345
 346                 _ ->
 347                     evalAst ast
 348     in
 349         macroexpand ast
 350             |> Eval.andThen go
 351             |> Eval.andThen
 352                 (\res ->
 353                     debug "evalNoApply"
 354                         (\env -> (printString env True ast) ++ " = " ++ (printString env True res))
 355                         (Eval.succeed res)
 356                 )
 357
 358
 359 evalAst : MalExpr -> Eval MalExpr
 360 evalAst ast =
 361     case ast of
 362         MalSymbol sym ->
 363             -- Lookup symbol in env and return value or raise error if not found.
 364             Eval.withEnv (Env.get sym >> Eval.fromResult)
 365
 366         MalList list ->
 367             -- Return new list that is result of calling eval on each element of list.
 368             evalList list
 369                 |> Eval.map MalList
 370
 371         MalVector vec ->
 372             evalList (Array.toList vec)
 373                 |> Eval.map (Array.fromList >> MalVector)
 374
 375         MalMap map ->
 376             evalList (Dict.values map)
 377                 |> Eval.map
 378                     (zip (Dict.keys map)
 379                         >> Dict.fromList
 380                         >> MalMap
 381                     )
 382
 383         _ ->
 384             Eval.succeed ast
 385
 386
 387 evalList : List MalExpr -> Eval (List MalExpr)
 388 evalList list =
 389     let
 390         go list acc =
 391             case list of
 392                 [] ->
 393                     Eval.succeed (List.reverse acc)
 394
 395                 x :: rest ->
 396                     eval x
 397                         |> Eval.andThen
 398                             (\val ->
 399                                 Eval.pushRef val <| go rest (val :: acc)
 400                             )
 401     in
 402         Eval.withStack <| go list []
 403
 404
 405 evalDef : List MalExpr -> Eval MalExpr
 406 evalDef args =
 407     case args of
 408         [ MalSymbol name, uneValue ] ->
 409             eval uneValue
 410                 |> Eval.andThen
 411                     (\value ->
 412                         Eval.modifyEnv (Env.set name value)
 413                             |> Eval.andThen (\_ -> Eval.succeed value)
 414                     )
 415
 416         _ ->
 417             Eval.fail "def! expected two args: name and value"
 418
 419
 420 evalDefMacro : List MalExpr -> Eval MalExpr
 421 evalDefMacro args =
 422     case args of
 423         [ MalSymbol name, uneValue ] ->
 424             eval uneValue
 425                 |> Eval.andThen
 426                     (\value ->
 427                         case value of
 428                             MalFunction (UserFunc fn) ->
 429                                 let
 430                                     macroFn =
 431                                         MalFunction (UserFunc { fn | isMacro = True })
 432                                 in
 433                                     Eval.modifyEnv (Env.set name macroFn)
 434                                         |> Eval.andThen (\_ -> Eval.succeed macroFn)
 435
 436                             _ ->
 437                                 Eval.fail "defmacro! is only supported on a user function"
 438                     )
 439
 440         _ ->
 441             Eval.fail "defmacro! expected two args: name and value"
 442
 443
 444 evalLet : List MalExpr -> Eval MalExpr
 445 evalLet args =
 446     let
 447         evalBinds binds =
 448             case binds of
 449                 (MalSymbol name) :: expr :: rest ->
 450                     eval expr
 451                         |> Eval.andThen
 452                             (\value ->
 453                                 Eval.modifyEnv (Env.set name value)
 454                                     |> Eval.andThen
 455                                         (\_ ->
 456                                             if List.isEmpty rest then
 457                                                 Eval.succeed ()
 458                                             else
 459                                                 evalBinds rest
 460                                         )
 461                             )
 462
 463                 _ ->
 464                     Eval.fail "let* expected an even number of binds (symbol expr ..)"
 465
 466         go binds body =
 467             Eval.modifyEnv Env.push
 468                 |> Eval.andThen (\_ -> evalBinds binds)
 469                 |> Eval.andThen (\_ -> evalNoApply body)
 470                 |> Eval.finally Env.pop
 471     in
 472         case args of
 473             [ MalList binds, body ] ->
 474                 go binds body
 475
 476             [ MalVector bindsVec, body ] ->
 477                 go (Array.toList bindsVec) body
 478
 479             _ ->
 480                 Eval.fail "let* expected two args: binds and a body"
 481
 482
 483 evalDo : List MalExpr -> Eval MalExpr
 484 evalDo args =
 485     case List.reverse args of
 486         last :: rest ->
 487             evalList (List.reverse rest)
 488                 |> Eval.andThen (\_ -> evalNoApply last)
 489
 490         [] ->
 491             Eval.fail "do expected at least one arg"
 492
 493
 494 evalIf : List MalExpr -> Eval MalExpr
 495 evalIf args =
 496     let
 497         isThruthy expr =
 498             expr /= MalNil && expr /= (MalBool False)
 499
 500         go condition trueExpr falseExpr =
 501             eval condition
 502                 |> Eval.map isThruthy
 503                 |> Eval.andThen
 504                     (\cond ->
 505                         evalNoApply
 506                             (if cond then
 507                                 trueExpr
 508                              else
 509                                 falseExpr
 510                             )
 511                     )
 512     in
 513         case args of
 514             [ condition, trueExpr ] ->
 515                 go condition trueExpr MalNil
 516
 517             [ condition, trueExpr, falseExpr ] ->
 518                 go condition trueExpr falseExpr
 519
 520             _ ->
 521                 Eval.fail "if expected at least two args"
 522
 523
 524 evalFn : List MalExpr -> Eval MalExpr
 525 evalFn args =
 526     let
 527         {- Extract symbols from the binds list and verify their uniqueness -}
 528         extractSymbols acc list =
 529             case list of
 530                 [] ->
 531                     Ok (List.reverse acc)
 532
 533                 (MalSymbol name) :: rest ->
 534                     if List.member name acc then
 535                         Err "all binds must have unique names"
 536                     else
 537                         extractSymbols (name :: acc) rest
 538
 539                 _ ->
 540                     Err "all binds in fn* must be a symbol"
 541
 542         parseBinds list =
 543             case List.reverse list of
 544                 var :: "&" :: rest ->
 545                     Ok <| bindVarArgs (List.reverse rest) var
 546
 547                 _ ->
 548                     if List.member "&" list then
 549                         Err "varargs separator '&' is used incorrectly"
 550                     else
 551                         Ok <| bindArgs list
 552
 553         extractAndParse =
 554             extractSymbols [] >> Result.andThen parseBinds
 555
 556         bindArgs binds args =
 557             let
 558                 numBinds =
 559                     List.length binds
 560             in
 561                 if List.length args /= numBinds then
 562                     Err <|
 563                         "function expected "
 564                             ++ (toString numBinds)
 565                             ++ " arguments"
 566                 else
 567                     Ok <| zip binds args
 568
 569         bindVarArgs binds var args =
 570             let
 571                 minArgs =
 572                     List.length binds
 573
 574                 varArgs =
 575                     MalList (List.drop minArgs args)
 576             in
 577                 if List.length args < minArgs then
 578                     Err <|
 579                         "function expected at least "
 580                             ++ (toString minArgs)
 581                             ++ " arguments"
 582                 else
 583                     Ok <| zip binds args ++ [ ( var, varArgs ) ]
 584
 585         makeFn frameId binder body =
 586             MalFunction <|
 587                 let
 588                     lazyFn =
 589                         binder
 590                             >> Eval.fromResult
 591                             >> Eval.map
 592                                 (\bound ->
 593                                     MalApply
 594                                         { frameId = frameId
 595                                         , bound = bound
 596                                         , body = body
 597                                         }
 598                                 )
 599                 in
 600                     UserFunc
 601                         { frameId = frameId
 602                         , lazyFn = lazyFn
 603                         , eagerFn = lazyFn >> Eval.andThen eval
 604                         , isMacro = False
 605                         , meta = Nothing
 606                         }
 607
 608         go bindsList body =
 609             extractAndParse bindsList
 610                 |> Eval.fromResult
 611                 -- reference the current frame.
 612                 |> Eval.ignore (Eval.modifyEnv Env.ref)
 613                 |> Eval.andThen
 614                     (\binder ->
 615                         Eval.withEnv
 616                             (\env ->
 617                                 Eval.succeed
 618                                     (makeFn env.currentFrameId binder body)
 619                             )
 620                     )
 621     in
 622         case args of
 623             [ MalList bindsList, body ] ->
 624                 go bindsList body
 625
 626             [ MalVector bindsVec, body ] ->
 627                 go (Array.toList bindsVec) body
 628
 629             _ ->
 630                 Eval.fail "fn* expected two args: binds list and body"
 631
 632
 633 evalQuote : List MalExpr -> Eval MalExpr
 634 evalQuote args =
 635     case args of
 636         [ expr ] ->
 637             Eval.succeed expr
 638
 639         _ ->
 640             Eval.fail "unsupported arguments"
 641
 642
 643 evalQuasiQuote : MalExpr -> MalExpr
 644 evalQuasiQuote expr =
 645     let
 646         apply list empty =
 647             case list of
 648                 [ MalSymbol "unquote", ast ] ->
 649                     ast
 650
 651                 (MalList [ MalSymbol "splice-unquote", ast ]) :: rest ->
 652                     makeCall "concat"
 653                         [ ast
 654                         , evalQuasiQuote (MalList rest)
 655                         ]
 656
 657                 ast :: rest ->
 658                     makeCall "cons"
 659                         [ evalQuasiQuote ast
 660                         , evalQuasiQuote (MalList rest)
 661                         ]
 662
 663                 _ ->
 664                     makeCall "quote" [ empty ]
 665     in
 666         case expr of
 667             MalList list ->
 668                 apply list (MalList [])
 669
 670             MalVector vec ->
 671                 apply (Array.toList vec) (MalVector Array.empty)
 672
 673             ast ->
 674                 makeCall "quote" [ ast ]
 675
 676
 677 macroexpand : MalExpr -> Eval MalExpr
 678 macroexpand expr =
 679     let
 680         expand expr env =
 681             case expr of
 682                 MalList ((MalSymbol name) :: args) ->
 683                     case Env.get name env of
 684                         Ok (MalFunction (UserFunc fn)) ->
 685                             if fn.isMacro then
 686                                 Left <| fn.eagerFn args
 687                             else
 688                                 Right expr
 689
 690                         _ ->
 691                             Right expr
 692
 693                 _ ->
 694                     Right expr
 695     in
 696         Eval.runLoop expand expr
 697
 698
 699 evalTry : List MalExpr -> Eval MalExpr
 700 evalTry args =
 701     case args of
 702         [ body ] ->
 703             eval body
 704         [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] ->
 705             eval body
 706                 |> Eval.catchError
 707                     (\ex ->
 708                         Eval.modifyEnv Env.push
 709                             |> Eval.andThen
 710                                 (\_ ->
 711                                     Eval.modifyEnv (Env.set sym ex)
 712                                 )
 713                             |> Eval.andThen (\_ -> eval handler)
 714                             |> Eval.finally Env.pop
 715                     )
 716
 717         _ ->
 718             Eval.fail "try* expected a body a catch block"
 719
 720
 721 print : Env -> MalExpr -> String
 722 print env =
 723     printString env True
 724
 725
 726 printError : Env -> MalExpr -> String
 727 printError env expr =
 728     "Error: " ++ (printString env False expr)
 729
 730
 731 {-| Read-Eval-Print.
 732
 733 Doesn't actually run the Eval but returns the monad.
 734
 735 -}
 736 rep : String -> Maybe (Eval MalExpr)
 737 rep input =
 738     case readString input of
 739         Ok Nothing ->
 740             Nothing
 741
 742         Err msg ->
 743             Just (Eval.fail msg)
 744
 745         Ok (Just ast) ->
 746             eval ast |> Just