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