elm/Core.elm

   1 module Core exposing (..)
   2
   3 import Types exposing (MalExpr(..), MalFunction(..), Eval, Env, keywordPrefix)
   4 import Env
   5 import Eval
   6 import Printer exposing (printString)
   7 import Array
   8 import Dict
   9 import IO exposing (IO(..))
  10 import Reader
  11 import Utils exposing (zip)
  12
  13
  14 ns : Env
  15 ns =
  16     let
  17         makeFn =
  18             CoreFunc >> MalFunction
  19
  20         binaryOp fn retType args =
  21             case args of
  22                 [ MalInt x, MalInt y ] ->
  23                     Eval.succeed (retType (fn x y))
  24
  25                 _ ->
  26                     Eval.fail "unsupported arguments"
  27
  28         {- list -}
  29         list =
  30             Eval.succeed << MalList
  31
  32         {- list? -}
  33         isList args =
  34             case args of
  35                 [ MalList _ ] ->
  36                     Eval.succeed (MalBool True)
  37
  38                 _ ->
  39                     Eval.succeed (MalBool False)
  40
  41         {- empty? -}
  42         isEmpty args =
  43             case args of
  44                 [ MalList list ] ->
  45                     Eval.succeed <| MalBool (List.isEmpty list)
  46
  47                 [ MalVector vec ] ->
  48                     Eval.succeed <| MalBool (Array.isEmpty vec)
  49
  50                 _ ->
  51                     Eval.fail "unsupported arguments"
  52
  53         {- count -}
  54         count args =
  55             case args of
  56                 [ MalNil ] ->
  57                     Eval.succeed (MalInt 0)
  58
  59                 [ MalList list ] ->
  60                     Eval.succeed <| MalInt (List.length list)
  61
  62                 [ MalVector vec ] ->
  63                     Eval.succeed <| MalInt (Array.length vec)
  64
  65                 _ ->
  66                     Eval.fail "unsupported arguments"
  67
  68         equalLists a b =
  69             case ( a, b ) of
  70                 ( [], [] ) ->
  71                     True
  72
  73                 ( x :: xs, y :: ys ) ->
  74                     if deepEquals x y then
  75                         equalLists xs ys
  76                     else
  77                         False
  78
  79                 _ ->
  80                     False
  81
  82         compareListTo list other =
  83             case other of
  84                 MalList otherList ->
  85                     equalLists list otherList
  86
  87                 MalVector vec ->
  88                     equalLists list (Array.toList vec)
  89
  90                 _ ->
  91                     False
  92
  93         equalMaps a b =
  94             if Dict.keys a /= Dict.keys b then
  95                 False
  96             else
  97                 zip (Dict.values a) (Dict.values b)
  98                     |> List.map (uncurry deepEquals)
  99                     |> List.all identity
 100
 101         deepEquals a b =
 102             case ( a, b ) of
 103                 ( MalList list, MalList otherList ) ->
 104                     equalLists list otherList
 105
 106                 ( MalList list, MalVector vec ) ->
 107                     equalLists list (Array.toList vec)
 108
 109                 ( MalList _, _ ) ->
 110                     False
 111
 112                 ( MalVector vec, MalList list ) ->
 113                     equalLists (Array.toList vec) list
 114
 115                 ( MalVector vec, MalVector otherVec ) ->
 116                     equalLists (Array.toList vec) (Array.toList otherVec)
 117
 118                 ( MalVector _, _ ) ->
 119                     False
 120
 121                 ( MalMap map, MalMap otherMap ) ->
 122                     equalMaps map otherMap
 123
 124                 ( MalMap _, _ ) ->
 125                     False
 126
 127                 ( _, MalMap _ ) ->
 128                     False
 129
 130                 _ ->
 131                     a == b
 132
 133         {- = -}
 134         equals args =
 135             case args of
 136                 [ a, b ] ->
 137                     Eval.succeed <| MalBool (deepEquals a b)
 138
 139                 _ ->
 140                     Eval.fail "unsupported arguments"
 141
 142         {- pr-str -}
 143         prStr args =
 144             Eval.withEnv
 145                 (\env ->
 146                     args
 147                         |> List.map (printString env True)
 148                         |> String.join " "
 149                         |> MalString
 150                         |> Eval.succeed
 151                 )
 152
 153         {- str -}
 154         str args =
 155             Eval.withEnv
 156                 (\env ->
 157                     args
 158                         |> List.map (printString env False)
 159                         |> String.join ""
 160                         |> MalString
 161                         |> Eval.succeed
 162                 )
 163
 164         {- helper function to write a string to stdout -}
 165         writeLine str =
 166             Eval.io (IO.writeLine str)
 167                 (\msg ->
 168                     case msg of
 169                         LineWritten ->
 170                             Eval.succeed MalNil
 171
 172                         _ ->
 173                             Eval.fail "wrong IO, expected LineWritten"
 174                 )
 175
 176         prn args =
 177             Eval.withEnv
 178                 (\env ->
 179                     args
 180                         |> List.map (printString env True)
 181                         |> String.join " "
 182                         |> writeLine
 183                 )
 184
 185         println args =
 186             Eval.withEnv
 187                 (\env ->
 188                     args
 189                         |> List.map (printString env False)
 190                         |> String.join " "
 191                         |> writeLine
 192                 )
 193
 194         printEnv args =
 195             case args of
 196                 [] ->
 197                     Eval.withEnv (Printer.printEnv >> writeLine)
 198
 199                 _ ->
 200                     Eval.fail "unsupported arguments"
 201
 202         readString args =
 203             case args of
 204                 [ MalString str ] ->
 205                     case Reader.readString str of
 206                         Ok Nothing ->
 207                             Eval.succeed MalNil
 208
 209                         Ok (Just ast) ->
 210                             Eval.succeed ast
 211
 212                         Err msg ->
 213                             Eval.fail msg
 214
 215                 _ ->
 216                     Eval.fail "unsupported arguments"
 217
 218         slurp args =
 219             case args of
 220                 [ MalString filename ] ->
 221                     Eval.io (IO.readFile filename)
 222                         (\msg ->
 223                             case msg of
 224                                 FileRead contents ->
 225                                     Eval.succeed <| MalString contents
 226
 227                                 Exception msg ->
 228                                     Eval.fail msg
 229
 230                                 _ ->
 231                                     Eval.fail "wrong IO, expected FileRead"
 232                         )
 233
 234                 _ ->
 235                     Eval.fail "unsupported arguments"
 236
 237         atom args =
 238             case args of
 239                 [ value ] ->
 240                     Eval.withEnv
 241                         (\env ->
 242                             case Env.newAtom value env of
 243                                 ( newEnv, atomId ) ->
 244                                     Eval.setEnv newEnv
 245                                         |> Eval.map (\_ -> MalAtom atomId)
 246                         )
 247
 248                 _ ->
 249                     Eval.fail "unsupported arguments"
 250
 251         isAtom args =
 252             case args of
 253                 [ MalAtom _ ] ->
 254                     Eval.succeed <| MalBool True
 255
 256                 _ ->
 257                     Eval.succeed <| MalBool False
 258
 259         deref args =
 260             case args of
 261                 [ MalAtom atomId ] ->
 262                     Eval.withEnv (Env.getAtom atomId >> Eval.succeed)
 263
 264                 _ ->
 265                     Eval.fail "unsupported arguments"
 266
 267         reset args =
 268             case args of
 269                 [ MalAtom atomId, value ] ->
 270                     Eval.modifyEnv (Env.setAtom atomId value)
 271                         |> Eval.map (always value)
 272
 273                 _ ->
 274                     Eval.fail "unsupported arguments"
 275
 276         {- helper function for calling a core or user function -}
 277         callFn func args =
 278             case func of
 279                 CoreFunc fn ->
 280                     fn args
 281
 282                 UserFunc { eagerFn } ->
 283                     eagerFn args
 284
 285         swap args =
 286             case args of
 287                 (MalAtom atomId) :: (MalFunction func) :: args ->
 288                     Eval.withEnv
 289                         (\env ->
 290                             let
 291                                 value =
 292                                     Env.getAtom atomId env
 293                             in
 294                                 callFn func (value :: args)
 295                         )
 296                         |> Eval.andThen
 297                             (\res ->
 298                                 Eval.modifyEnv (Env.setAtom atomId res)
 299                                     |> Eval.map (always res)
 300                             )
 301
 302                 _ ->
 303                     Eval.fail "unsupported arguments"
 304
 305         gc args =
 306             Eval.withEnv (Env.gc >> Printer.printEnv >> writeLine)
 307
 308         setDebug enabled =
 309             Eval.modifyEnv
 310                 (\env ->
 311                     { env | debug = enabled }
 312                 )
 313                 |> Eval.andThen (\_ -> Eval.succeed MalNil)
 314
 315         debug args =
 316             case args of
 317                 [ MalBool True ] ->
 318                     setDebug True
 319
 320                 _ ->
 321                     setDebug False
 322
 323         typeof args =
 324             case args of
 325                 [ MalInt _ ] ->
 326                     Eval.succeed <| MalSymbol "int"
 327
 328                 [ MalBool _ ] ->
 329                     Eval.succeed <| MalSymbol "bool"
 330
 331                 [ MalString _ ] ->
 332                     Eval.succeed <| MalSymbol "string"
 333
 334                 [ MalKeyword _ ] ->
 335                     Eval.succeed <| MalSymbol "keyword"
 336
 337                 [ MalSymbol _ ] ->
 338                     Eval.succeed <| MalSymbol "symbol"
 339
 340                 [ MalNil ] ->
 341                     Eval.succeed <| MalSymbol "nil"
 342
 343                 [ MalList _ ] ->
 344                     Eval.succeed <| MalSymbol "vector"
 345
 346                 [ MalVector _ ] ->
 347                     Eval.succeed <| MalSymbol "vector"
 348
 349                 [ MalMap _ ] ->
 350                     Eval.succeed <| MalSymbol "vector"
 351
 352                 [ MalFunction _ ] ->
 353                     Eval.succeed <| MalSymbol "function"
 354
 355                 [ MalAtom _ ] ->
 356                     Eval.succeed <| MalSymbol "atom"
 357
 358                 _ ->
 359                     Eval.fail "unsupported arguments"
 360
 361         cons args =
 362             case args of
 363                 [ e, MalList list ] ->
 364                     Eval.succeed <| MalList (e :: list)
 365
 366                 [ e, MalVector vec ] ->
 367                     Eval.succeed <| MalList (e :: (Array.toList vec))
 368
 369                 _ ->
 370                     Eval.fail "unsupported arguments"
 371
 372         concat args =
 373             let
 374                 go arg acc =
 375                     case arg of
 376                         MalList list ->
 377                             Eval.succeed (acc ++ list)
 378
 379                         MalVector vec ->
 380                             Eval.succeed (acc ++ Array.toList vec)
 381
 382                         _ ->
 383                             Eval.fail "unsupported arguments"
 384             in
 385                 List.foldl (go >> Eval.andThen) (Eval.succeed []) args
 386                     |> Eval.map MalList
 387
 388         nth args =
 389             let
 390                 get list index =
 391                     if index < 0 then
 392                         Nothing
 393                     else if index == 0 then
 394                         List.head list
 395                     else
 396                         case list of
 397                             [] ->
 398                                 Nothing
 399
 400                             _ :: rest ->
 401                                 get rest (index - 1)
 402
 403                 make res =
 404                     case res of
 405                         Just value ->
 406                             Eval.succeed value
 407
 408                         Nothing ->
 409                             Eval.fail "index out of bounds"
 410             in
 411                 case args of
 412                     [ MalList list, MalInt index ] ->
 413                         make <| get list index
 414
 415                     [ MalVector vec, MalInt index ] ->
 416                         make <| Array.get index vec
 417
 418                     _ ->
 419                         Eval.fail "unsupported arguments"
 420
 421         first args =
 422             let
 423                 make =
 424                     Eval.succeed << Maybe.withDefault MalNil
 425             in
 426                 case args of
 427                     [ MalNil ] ->
 428                         Eval.succeed MalNil
 429
 430                     [ MalList list ] ->
 431                         make <| List.head list
 432
 433                     [ MalVector vec ] ->
 434                         make <| Array.get 0 vec
 435
 436                     _ ->
 437                         Eval.fail "unsupported arguments"
 438
 439         rest args =
 440             case args of
 441                 [ MalNil ] ->
 442                     Eval.succeed <| MalList []
 443
 444                 [ MalList [] ] ->
 445                     Eval.succeed <| MalList []
 446
 447                 [ MalList (head :: tail) ] ->
 448                     Eval.succeed <| MalList tail
 449
 450                 [ MalVector vec ] ->
 451                     Array.toList vec
 452                         |> List.tail
 453                         |> Maybe.withDefault []
 454                         |> MalList
 455                         |> Eval.succeed
 456
 457                 _ ->
 458                     Eval.fail "unsupported arguments"
 459
 460         throw args =
 461             case args of
 462                 [ MalString msg ] ->
 463                     Eval.fail msg
 464
 465                 _ ->
 466                     Eval.fail "undefined exception"
 467
 468         apply args =
 469             case args of
 470                 (MalFunction func) :: rest ->
 471                     callFn func rest
 472
 473                 _ ->
 474                     Eval.fail "unsupported arguments"
 475
 476         map args =
 477             let
 478                 go func list acc =
 479                     case list of
 480                         [] ->
 481                             Eval.succeed <| MalList <| List.reverse acc
 482
 483                         inv :: rest ->
 484                             callFn func [ inv ]
 485                                 |> Eval.andThen
 486                                     (\outv ->
 487                                         go func rest (outv :: acc)
 488                                     )
 489             in
 490                 case args of
 491                     [ MalFunction func, MalList list ] ->
 492                         go func list []
 493
 494                     [ MalFunction func, MalVector vec ] ->
 495                         go func (Array.toList vec) []
 496
 497                     _ ->
 498                         Eval.fail "unsupported arguments"
 499
 500         isNil args =
 501             Eval.succeed <|
 502                 MalBool <|
 503                     case args of
 504                         MalNil :: _ ->
 505                             True
 506
 507                         _ ->
 508                             False
 509
 510         isTrue args =
 511             Eval.succeed <|
 512                 MalBool <|
 513                     case args of
 514                         (MalBool True) :: _ ->
 515                             True
 516
 517                         _ ->
 518                             False
 519
 520         isFalse args =
 521             Eval.succeed <|
 522                 MalBool <|
 523                     case args of
 524                         (MalBool False) :: _ ->
 525                             True
 526
 527                         _ ->
 528                             False
 529
 530         isSymbol args =
 531             Eval.succeed <|
 532                 MalBool <|
 533                     case args of
 534                         (MalSymbol _) :: _ ->
 535                             True
 536
 537                         _ ->
 538                             False
 539
 540         isKeyword args =
 541             Eval.succeed <|
 542                 MalBool <|
 543                     case args of
 544                         (MalKeyword _) :: _ ->
 545                             True
 546
 547                         _ ->
 548                             False
 549
 550         isVector args =
 551             Eval.succeed <|
 552                 MalBool <|
 553                     case args of
 554                         (MalVector _) :: _ ->
 555                             True
 556
 557                         _ ->
 558                             False
 559
 560         isMap args =
 561             Eval.succeed <|
 562                 MalBool <|
 563                     case args of
 564                         (MalMap _) :: _ ->
 565                             True
 566
 567                         _ ->
 568                             False
 569
 570         symbol args =
 571             case args of
 572                 [ MalString str ] ->
 573                     Eval.succeed <| MalSymbol str
 574
 575                 _ ->
 576                     Eval.fail "unsupported arguments"
 577
 578         keyword args =
 579             case args of
 580                 [ MalString str ] ->
 581                     Eval.succeed <| MalKeyword (String.cons ':' str)
 582
 583                 _ ->
 584                     Eval.fail "unsupported arguments"
 585
 586         vector args =
 587             Eval.succeed <| MalVector <| Array.fromList args
 588
 589         parseKey key =
 590             case key of
 591                 MalString str ->
 592                     Ok str
 593
 594                 MalKeyword keyword ->
 595                     Ok <| String.cons keywordPrefix keyword
 596
 597                 _ ->
 598                     Err "map key must be a symbol or keyword"
 599
 600         buildMap list acc =
 601             case list of
 602                 [] ->
 603                     Eval.succeed <| MalMap acc
 604
 605                 key :: value :: rest ->
 606                     parseKey key
 607                         |> Eval.fromResult
 608                         |> Eval.andThen
 609                             (\key ->
 610                                 buildMap rest (Dict.insert key value acc)
 611                             )
 612
 613                 _ ->
 614                     Eval.fail "expected an even number of key-value pairs"
 615
 616         hashMap args =
 617             buildMap args Dict.empty
 618
 619         assoc args =
 620             case args of
 621                 (MalMap dict) :: rest ->
 622                     buildMap rest dict
 623
 624                 _ ->
 625                     Eval.fail "unsupported arguments"
 626
 627         dissoc args =
 628             let
 629                 go keys acc =
 630                     case keys of
 631                         [] ->
 632                             Eval.succeed <| MalMap acc
 633
 634                         key :: rest ->
 635                             parseKey key
 636                                 |> Eval.fromResult
 637                                 |> Eval.andThen
 638                                     (\key ->
 639                                         go rest (Dict.remove key acc)
 640                                     )
 641             in
 642                 case args of
 643                     (MalMap dict) :: keys ->
 644                         go keys dict
 645
 646                     _ ->
 647                         Eval.fail "unsupported arguments"
 648
 649         get args =
 650             case args of
 651                 [ MalNil, key ] ->
 652                     Eval.succeed MalNil
 653
 654                 [ MalMap dict, key ] ->
 655                     parseKey key
 656                         |> Eval.fromResult
 657                         |> Eval.map
 658                             (\key ->
 659                                 Dict.get key dict
 660                                     |> Maybe.withDefault MalNil
 661                             )
 662
 663                 _ ->
 664                     Eval.fail "unsupported arguments"
 665
 666         contains args =
 667             case args of
 668                 [ MalMap dict, key ] ->
 669                     parseKey key
 670                         |> Eval.fromResult
 671                         |> Eval.map (\key -> Dict.member key dict)
 672                         |> Eval.map MalBool
 673
 674                 _ ->
 675                     Eval.fail "unsupported arguments"
 676
 677         unparseKey key =
 678             case String.uncons key of
 679                 Just ( prefix, rest ) ->
 680                     if prefix == keywordPrefix then
 681                         MalKeyword rest
 682                     else
 683                         MalString key
 684
 685                 _ ->
 686                     MalString key
 687
 688         keys args =
 689             case args of
 690                 [ MalMap dict ] ->
 691                     Dict.keys dict
 692                         |> List.map unparseKey
 693                         |> MalList
 694                         |> Eval.succeed
 695
 696                 _ ->
 697                     Eval.fail "unsupported arguments"
 698
 699         vals args =
 700             case args of
 701                 [ MalMap dict ] ->
 702                     Dict.values dict
 703                         |> MalList
 704                         |> Eval.succeed
 705
 706                 _ ->
 707                     Eval.fail "unsupported arguments"
 708     in
 709         Env.global
 710             |> Env.set "+" (makeFn <| binaryOp (+) MalInt)
 711             |> Env.set "-" (makeFn <| binaryOp (-) MalInt)
 712             |> Env.set "*" (makeFn <| binaryOp (*) MalInt)
 713             |> Env.set "/" (makeFn <| binaryOp (//) MalInt)
 714             |> Env.set "<" (makeFn <| binaryOp (<) MalBool)
 715             |> Env.set ">" (makeFn <| binaryOp (>) MalBool)
 716             |> Env.set "<=" (makeFn <| binaryOp (<=) MalBool)
 717             |> Env.set ">=" (makeFn <| binaryOp (>=) MalBool)
 718             |> Env.set "list" (makeFn list)
 719             |> Env.set "list?" (makeFn isList)
 720             |> Env.set "empty?" (makeFn isEmpty)
 721             |> Env.set "count" (makeFn count)
 722             |> Env.set "=" (makeFn equals)
 723             |> Env.set "pr-str" (makeFn prStr)
 724             |> Env.set "str" (makeFn str)
 725             |> Env.set "prn" (makeFn prn)
 726             |> Env.set "println" (makeFn println)
 727             |> Env.set "pr-env" (makeFn printEnv)
 728             |> Env.set "read-string" (makeFn readString)
 729             |> Env.set "slurp" (makeFn slurp)
 730             |> Env.set "atom" (makeFn atom)
 731             |> Env.set "atom?" (makeFn isAtom)
 732             |> Env.set "deref" (makeFn deref)
 733             |> Env.set "reset!" (makeFn reset)
 734             |> Env.set "swap!" (makeFn swap)
 735             |> Env.set "gc" (makeFn gc)
 736             |> Env.set "debug!" (makeFn debug)
 737             |> Env.set "typeof" (makeFn typeof)
 738             |> Env.set "cons" (makeFn cons)
 739             |> Env.set "concat" (makeFn concat)
 740             |> Env.set "nth" (makeFn nth)
 741             |> Env.set "first" (makeFn first)
 742             |> Env.set "rest" (makeFn rest)
 743             |> Env.set "throw" (makeFn throw)
 744             |> Env.set "nil?" (makeFn isNil)
 745             |> Env.set "true?" (makeFn isTrue)
 746             |> Env.set "false?" (makeFn isFalse)
 747             |> Env.set "symbol?" (makeFn isSymbol)
 748             |> Env.set "keyword?" (makeFn isKeyword)
 749             |> Env.set "vector?" (makeFn isVector)
 750             |> Env.set "map?" (makeFn isMap)
 751             |> Env.set "symbol" (makeFn symbol)
 752             |> Env.set "keyword" (makeFn keyword)
 753             |> Env.set "vector" (makeFn vector)
 754             |> Env.set "hash-map" (makeFn hashMap)
 755             |> Env.set "assoc" (makeFn assoc)
 756             |> Env.set "dissoc" (makeFn dissoc)
 757             |> Env.set "get" (makeFn get)
 758             |> Env.set "contains?" (makeFn contains)
 759             |> Env.set "keys" (makeFn keys)
 760             |> Env.set "vals" (makeFn vals)