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