elm/Core.elm

   1 module Core exposing (..)
   2
   3 import Types exposing (MalExpr(..), MalFunction(..), Eval, Env)
   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                     -- TODO eval apply here!
 289                     Eval.withEnv
 290                         (\env ->
 291                             let
 292                                 value =
 293                                     Env.getAtom atomId env
 294                             in
 295                                 callFn func (value :: args)
 296                         )
 297                         |> Eval.andThen
 298                             (\res ->
 299                                 Eval.modifyEnv (Env.setAtom atomId res)
 300                                     |> Eval.map (always res)
 301                             )
 302
 303                 _ ->
 304                     Eval.fail "unsupported arguments"
 305
 306         gc args =
 307             Eval.withEnv (Env.gc >> Printer.printEnv >> writeLine)
 308
 309         setDebug enabled =
 310             Eval.modifyEnv
 311                 (\env ->
 312                     { env | debug = enabled }
 313                 )
 314                 |> Eval.andThen (\_ -> Eval.succeed MalNil)
 315
 316         debug args =
 317             case args of
 318                 [ MalBool True ] ->
 319                     setDebug True
 320
 321                 _ ->
 322                     setDebug False
 323
 324         typeof args =
 325             case args of
 326                 [ MalInt _ ] ->
 327                     Eval.succeed <| MalSymbol "int"
 328
 329                 [ MalBool _ ] ->
 330                     Eval.succeed <| MalSymbol "bool"
 331
 332                 [ MalString _ ] ->
 333                     Eval.succeed <| MalSymbol "string"
 334
 335                 [ MalKeyword _ ] ->
 336                     Eval.succeed <| MalSymbol "keyword"
 337
 338                 [ MalSymbol _ ] ->
 339                     Eval.succeed <| MalSymbol "symbol"
 340
 341                 [ MalNil ] ->
 342                     Eval.succeed <| MalSymbol "nil"
 343
 344                 [ MalList _ ] ->
 345                     Eval.succeed <| MalSymbol "vector"
 346
 347                 [ MalVector _ ] ->
 348                     Eval.succeed <| MalSymbol "vector"
 349
 350                 [ MalMap _ ] ->
 351                     Eval.succeed <| MalSymbol "vector"
 352
 353                 [ MalFunction _ ] ->
 354                     Eval.succeed <| MalSymbol "function"
 355
 356                 [ MalAtom _ ] ->
 357                     Eval.succeed <| MalSymbol "atom"
 358
 359                 _ ->
 360                     Eval.fail "unsupported arguments"
 361
 362         cons args =
 363             case args of
 364                 [ e, MalList list ] ->
 365                     Eval.succeed <| MalList (e :: list)
 366
 367                 _ ->
 368                     Eval.fail "unsupported arguments"
 369
 370         concat args =
 371             let
 372                 go arg acc =
 373                     case arg of
 374                         MalList list ->
 375                             Eval.succeed (acc ++ list)
 376
 377                         MalVector vec ->
 378                             Eval.succeed (acc ++ Array.toList vec)
 379
 380                         _ ->
 381                             Eval.fail "unsupported arguments"
 382             in
 383                 List.foldl (go >> Eval.andThen) (Eval.succeed []) args
 384                     |> Eval.map MalList
 385     in
 386         Env.global
 387             |> Env.set "+" (makeFn <| binaryOp (+) MalInt)
 388             |> Env.set "-" (makeFn <| binaryOp (-) MalInt)
 389             |> Env.set "*" (makeFn <| binaryOp (*) MalInt)
 390             |> Env.set "/" (makeFn <| binaryOp (//) MalInt)
 391             |> Env.set "<" (makeFn <| binaryOp (<) MalBool)
 392             |> Env.set ">" (makeFn <| binaryOp (>) MalBool)
 393             |> Env.set "<=" (makeFn <| binaryOp (<=) MalBool)
 394             |> Env.set ">=" (makeFn <| binaryOp (>=) MalBool)
 395             |> Env.set "list" (makeFn list)
 396             |> Env.set "list?" (makeFn isList)
 397             |> Env.set "empty?" (makeFn isEmpty)
 398             |> Env.set "count" (makeFn count)
 399             |> Env.set "=" (makeFn equals)
 400             |> Env.set "pr-str" (makeFn prStr)
 401             |> Env.set "str" (makeFn str)
 402             |> Env.set "prn" (makeFn prn)
 403             |> Env.set "println" (makeFn println)
 404             |> Env.set "pr-env" (makeFn printEnv)
 405             |> Env.set "read-string" (makeFn readString)
 406             |> Env.set "slurp" (makeFn slurp)
 407             |> Env.set "atom" (makeFn atom)
 408             |> Env.set "atom?" (makeFn isAtom)
 409             |> Env.set "deref" (makeFn deref)
 410             |> Env.set "reset!" (makeFn reset)
 411             |> Env.set "swap!" (makeFn swap)
 412             |> Env.set "gc" (makeFn gc)
 413             |> Env.set "debug!" (makeFn debug)
 414             |> Env.set "typeof" (makeFn typeof)
 415             |> Env.set "cons" (makeFn cons)
 416             |> Env.set "concat" (makeFn concat)
 417
 418
 419 malInit : List String
 420 malInit =
 421     [ """(def! not
 422             (fn* (a)
 423                 (if a false true)))"""
 424     , """(def! load-file
 425             (fn* (f)
 426                 (eval (read-string
 427                     (str "(do " (slurp f) ")")))))"""
 428     ]