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