mirror of
https://github.com/kanaka/mal.git
synced 2024-11-13 01:43:50 +03:00
Elm: step5 - TCO the theory
This commit is contained in:
Jos van Bakel
parent
86fcd61dfa
commit
0bac0757af
165
elm/Core.elm
165
elm/Core.elm
@ -1,16 +1,20 @@
|
||||
module Core exposing (..)
|
||||
|
||||
import Types exposing (MalExpr(..), Eval, Env)
|
||||
import Types exposing (MalExpr(..), MalFunction(..), Eval, Env)
|
||||
import Env
|
||||
import Eval
|
||||
import Printer exposing (printString)
|
||||
import Array
|
||||
import IO exposing (IO(..))
|
||||
import Reader
|
||||
|
||||
|
||||
ns : Env
|
||||
ns =
|
||||
let
|
||||
makeFn =
|
||||
CoreFunc >> MalFunction
|
||||
|
||||
binaryOp fn retType args =
|
||||
case args of
|
||||
[ MalInt x, MalInt y ] ->
|
||||
@ -82,12 +86,12 @@ ns =
|
||||
>> MalString
|
||||
>> Eval.succeed
|
||||
|
||||
{- helper function to write a string to stdout -}
|
||||
writeLine str =
|
||||
Eval.io (IO.writeLine str)
|
||||
(\msg ->
|
||||
case msg of
|
||||
LineWritten ->
|
||||
-- TODO need caller continuation here...
|
||||
Eval.succeed MalNil
|
||||
|
||||
_ ->
|
||||
@ -103,25 +107,148 @@ ns =
|
||||
List.map (printString False)
|
||||
>> String.join " "
|
||||
>> writeLine
|
||||
|
||||
printEnv args =
|
||||
case args of
|
||||
[] ->
|
||||
Eval.withEnv (Printer.printEnv >> writeLine)
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
readString args =
|
||||
case args of
|
||||
[ MalString str ] ->
|
||||
case Reader.readString str of
|
||||
Ok Nothing ->
|
||||
Eval.succeed MalNil
|
||||
|
||||
Ok (Just ast) ->
|
||||
Eval.succeed ast
|
||||
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
slurp args =
|
||||
case args of
|
||||
[ MalString filename ] ->
|
||||
Eval.io (IO.readFile filename)
|
||||
(\msg ->
|
||||
case msg of
|
||||
FileRead contents ->
|
||||
Eval.succeed <| MalString contents
|
||||
|
||||
Exception msg ->
|
||||
Eval.fail msg
|
||||
|
||||
_ ->
|
||||
Eval.fail "wrong IO, expected FileRead"
|
||||
)
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
atom args =
|
||||
case args of
|
||||
[ value ] ->
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
case Env.newAtom value env of
|
||||
( newEnv, atomId ) ->
|
||||
Eval.setEnv newEnv
|
||||
|> Eval.map (\_ -> MalAtom atomId)
|
||||
)
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
isAtom args =
|
||||
case args of
|
||||
[ MalAtom _ ] ->
|
||||
Eval.succeed <| MalBool True
|
||||
|
||||
_ ->
|
||||
Eval.succeed <| MalBool False
|
||||
|
||||
deref args =
|
||||
case args of
|
||||
[ MalAtom atomId ] ->
|
||||
Eval.withEnv (Env.getAtom atomId >> Eval.succeed)
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
reset args =
|
||||
case args of
|
||||
[ MalAtom atomId, value ] ->
|
||||
Eval.modifyEnv (Env.setAtom atomId value)
|
||||
|> Eval.map (always value)
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
{- helper function for calling a core or user function -}
|
||||
callFn func args =
|
||||
case func of
|
||||
CoreFunc fn ->
|
||||
fn args
|
||||
|
||||
UserFunc { fn } ->
|
||||
fn args
|
||||
|
||||
swap args =
|
||||
case args of
|
||||
(MalAtom atomId) :: (MalFunction func) :: args ->
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
let
|
||||
value =
|
||||
Env.getAtom atomId env
|
||||
in
|
||||
callFn func (value :: args)
|
||||
)
|
||||
|> Eval.andThen
|
||||
(\res ->
|
||||
Eval.modifyEnv (Env.setAtom atomId res)
|
||||
|> Eval.map (always res)
|
||||
)
|
||||
|
||||
_ ->
|
||||
Eval.fail "unsupported arguments"
|
||||
|
||||
gc args =
|
||||
Eval.withEnv (Env.gc >> Printer.printEnv >> writeLine)
|
||||
in
|
||||
Env.global
|
||||
|> Env.set "+" (MalFunction <| binaryOp (+) MalInt)
|
||||
|> Env.set "-" (MalFunction <| binaryOp (-) MalInt)
|
||||
|> Env.set "*" (MalFunction <| binaryOp (*) MalInt)
|
||||
|> Env.set "/" (MalFunction <| binaryOp (//) MalInt)
|
||||
|> Env.set "<" (MalFunction <| binaryOp (<) MalBool)
|
||||
|> Env.set ">" (MalFunction <| binaryOp (>) MalBool)
|
||||
|> Env.set "<=" (MalFunction <| binaryOp (<=) MalBool)
|
||||
|> Env.set ">=" (MalFunction <| binaryOp (>=) MalBool)
|
||||
|> Env.set "list" (MalFunction list)
|
||||
|> Env.set "list?" (MalFunction isList)
|
||||
|> Env.set "empty?" (MalFunction isEmpty)
|
||||
|> Env.set "count" (MalFunction count)
|
||||
|> Env.set "=" (MalFunction equals)
|
||||
|> Env.set "pr-str" (MalFunction prStr)
|
||||
|> Env.set "str" (MalFunction str)
|
||||
|> Env.set "prn" (MalFunction prn)
|
||||
|> Env.set "println" (MalFunction println)
|
||||
|> Env.set "+" (makeFn <| binaryOp (+) MalInt)
|
||||
|> Env.set "-" (makeFn <| binaryOp (-) MalInt)
|
||||
|> Env.set "*" (makeFn <| binaryOp (*) MalInt)
|
||||
|> Env.set "/" (makeFn <| binaryOp (//) MalInt)
|
||||
|> Env.set "<" (makeFn <| binaryOp (<) MalBool)
|
||||
|> Env.set ">" (makeFn <| binaryOp (>) MalBool)
|
||||
|> Env.set "<=" (makeFn <| binaryOp (<=) MalBool)
|
||||
|> Env.set ">=" (makeFn <| binaryOp (>=) MalBool)
|
||||
|> Env.set "list" (makeFn list)
|
||||
|> Env.set "list?" (makeFn isList)
|
||||
|> Env.set "empty?" (makeFn isEmpty)
|
||||
|> Env.set "count" (makeFn count)
|
||||
|> Env.set "=" (makeFn equals)
|
||||
|> Env.set "pr-str" (makeFn prStr)
|
||||
|> Env.set "str" (makeFn str)
|
||||
|> Env.set "prn" (makeFn prn)
|
||||
|> Env.set "println" (makeFn println)
|
||||
|> Env.set "pr-env" (makeFn printEnv)
|
||||
|> Env.set "read-string" (makeFn readString)
|
||||
|> Env.set "slurp" (makeFn slurp)
|
||||
|> Env.set "atom" (makeFn atom)
|
||||
|> Env.set "atom?" (makeFn isAtom)
|
||||
|> Env.set "deref" (makeFn deref)
|
||||
|> Env.set "reset!" (makeFn reset)
|
||||
|> Env.set "swap!" (makeFn swap)
|
||||
|> Env.set "gc" (makeFn gc)
|
||||
|
||||
|
||||
malInit : List String
|
||||
|
||||
172
elm/Env.elm
172
elm/Env.elm
@ -1,14 +1,37 @@
|
||||
module Env exposing (global, push, pop, enter, leave, ref, get, set)
|
||||
module Env
|
||||
exposing
|
||||
( global
|
||||
, push
|
||||
, pop
|
||||
, enter
|
||||
, leave
|
||||
, ref
|
||||
, get
|
||||
, set
|
||||
, newAtom
|
||||
, getAtom
|
||||
, setAtom
|
||||
, gc
|
||||
)
|
||||
|
||||
import Types exposing (MalExpr, Frame, Env)
|
||||
import Dict exposing (Dict)
|
||||
import Types exposing (MalExpr(..), MalFunction(..), Frame, Env)
|
||||
import Dict
|
||||
import Array
|
||||
import Set
|
||||
|
||||
|
||||
globalFrameId : Int
|
||||
globalFrameId =
|
||||
0
|
||||
|
||||
|
||||
global : Env
|
||||
global =
|
||||
{ frames = Dict.singleton 0 (emptyFrame Nothing)
|
||||
, nextFrameId = 1
|
||||
, currentFrameId = 0
|
||||
{ frames = Dict.singleton globalFrameId (emptyFrame Nothing)
|
||||
, nextFrameId = globalFrameId + 1
|
||||
, currentFrameId = globalFrameId
|
||||
, atoms = Dict.empty
|
||||
, nextAtomId = 0
|
||||
}
|
||||
|
||||
|
||||
@ -21,17 +44,14 @@ push env =
|
||||
newFrame =
|
||||
emptyFrame (Just env.currentFrameId)
|
||||
in
|
||||
{ currentFrameId = frameId
|
||||
, frames = Dict.insert frameId newFrame env.frames
|
||||
, nextFrameId = env.nextFrameId + 1
|
||||
{ env
|
||||
| currentFrameId = frameId
|
||||
, frames = Dict.insert frameId newFrame env.frames
|
||||
, nextFrameId = env.nextFrameId + 1
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- TODO Dont' return result, Debug.crash instead.
|
||||
|
||||
|
||||
pop : Env -> Result String Env
|
||||
pop : Env -> Env
|
||||
pop env =
|
||||
let
|
||||
frameId =
|
||||
@ -41,17 +61,19 @@ pop env =
|
||||
Just currentFrame ->
|
||||
case currentFrame.outerId of
|
||||
Just outerId ->
|
||||
Ok
|
||||
{ env
|
||||
| currentFrameId = outerId
|
||||
, frames = Dict.update frameId deref env.frames
|
||||
}
|
||||
{ env
|
||||
| currentFrameId = outerId
|
||||
, frames = Dict.update frameId deref env.frames
|
||||
}
|
||||
|
||||
Nothing ->
|
||||
Err "tried to pop global frame"
|
||||
_ ->
|
||||
Debug.crash "tried to pop global frame"
|
||||
|
||||
Nothing ->
|
||||
Err ("current frame " ++ (toString frameId) ++ " doesn't exist")
|
||||
Debug.crash <|
|
||||
"current frame "
|
||||
++ (toString frameId)
|
||||
++ " doesn't exist"
|
||||
|
||||
|
||||
setBinds : List ( String, MalExpr ) -> Frame -> Frame
|
||||
@ -69,14 +91,16 @@ enter : Int -> List ( String, MalExpr ) -> Env -> Env
|
||||
enter parentFrameId binds env =
|
||||
let
|
||||
frameId =
|
||||
env.nextFrameId
|
||||
Debug.log "enter #"
|
||||
env.nextFrameId
|
||||
|
||||
newFrame =
|
||||
setBinds binds (emptyFrame (Just parentFrameId))
|
||||
in
|
||||
{ currentFrameId = frameId
|
||||
, frames = Dict.insert frameId newFrame env.frames
|
||||
, nextFrameId = env.nextFrameId + 1
|
||||
{ env
|
||||
| currentFrameId = frameId
|
||||
, frames = Dict.insert frameId newFrame env.frames
|
||||
, nextFrameId = env.nextFrameId + 1
|
||||
}
|
||||
|
||||
|
||||
@ -84,7 +108,8 @@ leave : Int -> Env -> Env
|
||||
leave orgFrameId env =
|
||||
let
|
||||
frameId =
|
||||
env.currentFrameId
|
||||
Debug.log "leave #"
|
||||
env.currentFrameId
|
||||
in
|
||||
{ env
|
||||
| currentFrameId = orgFrameId
|
||||
@ -111,7 +136,8 @@ ref env =
|
||||
|
||||
|
||||
-- TODO: when disposing, deref all function's frames?
|
||||
-- TODO: is that enough instead of a GC?
|
||||
-- TODO: is that enough instead of a GC? no: don't know how often the function is referenced.
|
||||
-- TODO: consideration: keep refCnt for MalFunction, or implement a light GC.
|
||||
|
||||
|
||||
deref : Maybe Frame -> Maybe Frame
|
||||
@ -131,6 +157,62 @@ deref =
|
||||
-- in MalFunction need to refer to the frameId.
|
||||
|
||||
|
||||
{-| Given an Env see which frames are not reachable from the
|
||||
global frame. Return a new Env without the unreachable frames.
|
||||
-}
|
||||
gc : Env -> Env
|
||||
gc env =
|
||||
let
|
||||
countList acc =
|
||||
List.foldl countRefs acc
|
||||
|
||||
countFrame acc { data } =
|
||||
data |> Dict.values |> countList acc
|
||||
|
||||
countRefs expr acc =
|
||||
Debug.log (toString expr) <|
|
||||
case expr of
|
||||
MalFunction (UserFunc { frameId }) ->
|
||||
if not (Set.member frameId acc) then
|
||||
Debug.log "counting" <|
|
||||
case Dict.get frameId env.frames of
|
||||
Just frame ->
|
||||
countFrame (Set.insert frameId acc) frame
|
||||
|
||||
Nothing ->
|
||||
Debug.crash ("frame " ++ (toString frameId) ++ " not found in GC")
|
||||
else
|
||||
acc
|
||||
|
||||
MalList list ->
|
||||
countList acc list
|
||||
|
||||
MalVector vec ->
|
||||
countList acc (Array.toList vec)
|
||||
|
||||
MalMap map ->
|
||||
countList acc (Dict.values map)
|
||||
|
||||
_ ->
|
||||
acc
|
||||
|
||||
initSet =
|
||||
Set.fromList [ globalFrameId, env.currentFrameId ]
|
||||
in
|
||||
case Dict.get globalFrameId env.frames of
|
||||
Nothing ->
|
||||
Debug.crash "global frame not found"
|
||||
|
||||
Just globalFrame ->
|
||||
countFrame initSet globalFrame
|
||||
|> Set.toList
|
||||
|> Debug.log "used frames"
|
||||
|> List.map (\frameId -> ( frameId, emptyFrame Nothing ))
|
||||
|> Dict.fromList
|
||||
|> Dict.intersect (Debug.log "cur frames" env.frames)
|
||||
|> (\frames -> { env | frames = frames })
|
||||
|
||||
|
||||
emptyFrame : Maybe Int -> Frame
|
||||
emptyFrame outerId =
|
||||
{ outerId = outerId
|
||||
@ -163,7 +245,7 @@ get name env =
|
||||
go frameId =
|
||||
case Dict.get frameId env.frames of
|
||||
Nothing ->
|
||||
Err "frame not found"
|
||||
Err <| "frame " ++ (toString frameId) ++ " not found"
|
||||
|
||||
Just frame ->
|
||||
case Dict.get name frame.data of
|
||||
@ -176,3 +258,35 @@ get name env =
|
||||
|> Maybe.withDefault (Err "symbol not found")
|
||||
in
|
||||
go env.currentFrameId
|
||||
|
||||
|
||||
newAtom : MalExpr -> Env -> ( Env, Int )
|
||||
newAtom value env =
|
||||
let
|
||||
atomId =
|
||||
env.nextAtomId
|
||||
|
||||
newEnv =
|
||||
{ env
|
||||
| atoms = Dict.insert atomId value env.atoms
|
||||
, nextAtomId = atomId + 1
|
||||
}
|
||||
in
|
||||
( newEnv, atomId )
|
||||
|
||||
|
||||
getAtom : Int -> Env -> MalExpr
|
||||
getAtom atomId env =
|
||||
case Dict.get atomId env.atoms of
|
||||
Just value ->
|
||||
value
|
||||
|
||||
Nothing ->
|
||||
Debug.crash <| "atom " ++ (toString atomId) ++ " not found"
|
||||
|
||||
|
||||
setAtom : Int -> MalExpr -> Env -> Env
|
||||
setAtom atomId value env =
|
||||
{ env
|
||||
| atoms = Dict.insert atomId value env.atoms
|
||||
}
|
||||
|
||||
16
elm/Eval.elm
16
elm/Eval.elm
@ -2,6 +2,8 @@ module Eval exposing (..)
|
||||
|
||||
import Types exposing (..)
|
||||
import IO exposing (IO)
|
||||
import Env
|
||||
import Printer
|
||||
|
||||
|
||||
apply : Eval a -> Env -> EvalContext a
|
||||
@ -84,3 +86,17 @@ fail msg =
|
||||
Eval <|
|
||||
\state ->
|
||||
( state, EvalErr msg )
|
||||
|
||||
|
||||
enter : Int -> List ( String, MalExpr ) -> Eval a -> Eval a
|
||||
enter frameId bound body =
|
||||
withEnv
|
||||
(\env ->
|
||||
modifyEnv (Env.enter frameId bound)
|
||||
|> andThen (\_ -> body)
|
||||
|> andThen
|
||||
(\res ->
|
||||
modifyEnv (Env.leave env.currentFrameId)
|
||||
|> map (\_ -> res)
|
||||
)
|
||||
)
|
||||
|
||||
16
elm/IO.elm
16
elm/IO.elm
@ -3,6 +3,7 @@ port module IO
|
||||
( IO(..)
|
||||
, writeLine
|
||||
, readLine
|
||||
, readFile
|
||||
, input
|
||||
, decodeIO
|
||||
)
|
||||
@ -20,6 +21,11 @@ port writeLine : String -> Cmd msg
|
||||
port readLine : String -> Cmd msg
|
||||
|
||||
|
||||
{-| Read the contents of a file
|
||||
-}
|
||||
port readFile : String -> Cmd msg
|
||||
|
||||
|
||||
{-| Received a response for a command.
|
||||
-}
|
||||
port input : (Value -> msg) -> Sub msg
|
||||
@ -28,6 +34,8 @@ port input : (Value -> msg) -> Sub msg
|
||||
type IO
|
||||
= LineRead (Maybe String)
|
||||
| LineWritten
|
||||
| FileRead String
|
||||
| Exception String
|
||||
|
||||
|
||||
decodeIO : Decoder IO
|
||||
@ -46,6 +54,14 @@ decodeTag tag =
|
||||
"lineWritten" ->
|
||||
succeed LineWritten
|
||||
|
||||
"fileRead" ->
|
||||
field "contents" string
|
||||
|> map FileRead
|
||||
|
||||
"exception" ->
|
||||
field "message" string
|
||||
|> map Exception
|
||||
|
||||
_ ->
|
||||
fail <|
|
||||
"Trying to decode IO, but tag "
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
SOURCES_BASE = Reader.elm Printer.elm Utils.elm Types.elm Env.elm \
|
||||
Core.elm Eval.elm IO.elm
|
||||
SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm #step1_read_print.elm step2_eval.elm \
|
||||
step3_env.elm step4_if_fn_do.elm #step5_tco.ls step6_file.ls \
|
||||
SOURCES_STEPS = step0_repl.elm step4_if_fn_do.elm step5_tco.elm #step1_read_print.elm step2_eval.elm \
|
||||
step3_env.elm #step6_file.ls \
|
||||
step7_quote.ls step8_macros.ls step9_try.ls stepA_mal.ls
|
||||
SOURCES_LISP = #env.ls core.ls stepA_mal.ls
|
||||
SOURCES = $(SOURCES_STEPS)
|
||||
@ -25,7 +25,7 @@ step1_read_print.js: Reader.elm Printer.elm Utils.elm Types.elm
|
||||
#step2_eval.js: Reader.elm Printer.elm Utils.elm Types.elm
|
||||
#step3_env.js: Reader.elm Printer.elm Utils.elm Types.elm Env.elm
|
||||
step4_if_fn_do.js: $(SOURCES_BASE)
|
||||
# step5_tco.js: utils.js reader.js printer.js env.js core.js
|
||||
step5_tco.js: $(SOURCES_BASE)
|
||||
# step6_file.js: utils.js reader.js printer.js env.js core.js
|
||||
# step7_quote.js: utils.js reader.js printer.js env.js core.js
|
||||
# step8_macros.js: utils.js reader.js printer.js env.js core.js
|
||||
|
||||
@ -2,7 +2,7 @@ module Printer exposing (..)
|
||||
|
||||
import Array exposing (Array)
|
||||
import Dict exposing (Dict)
|
||||
import Types exposing (MalExpr(..), keywordPrefix)
|
||||
import Types exposing (Env, MalExpr(..), keywordPrefix)
|
||||
import Utils exposing (encodeString, wrap)
|
||||
|
||||
|
||||
@ -42,6 +42,12 @@ printString readably ast =
|
||||
MalFunction _ ->
|
||||
"#<function>"
|
||||
|
||||
MalAtom atomId ->
|
||||
"#<atom:" ++ (toString atomId) ++ ">"
|
||||
|
||||
MalApply _ ->
|
||||
"#<apply>"
|
||||
|
||||
|
||||
printRawString : Bool -> String -> String
|
||||
printRawString readably str =
|
||||
@ -88,3 +94,36 @@ printMap readably =
|
||||
>> List.map printEntry
|
||||
>> String.join " "
|
||||
>> wrap "{" "}"
|
||||
|
||||
|
||||
printEnv : Env -> String
|
||||
printEnv env =
|
||||
let
|
||||
printOuterId =
|
||||
Maybe.map toString >> Maybe.withDefault "nil"
|
||||
|
||||
printHeader frameId { outerId, refCnt } =
|
||||
"#"
|
||||
++ (toString frameId)
|
||||
++ " outer="
|
||||
++ printOuterId outerId
|
||||
++ " refCnt="
|
||||
++ (toString refCnt)
|
||||
|
||||
printFrame frameId frame =
|
||||
String.join "\n"
|
||||
((printHeader frameId frame)
|
||||
:: (Dict.foldr printDatum [] frame.data)
|
||||
)
|
||||
|
||||
printFrameAcc k v acc =
|
||||
printFrame k v :: acc
|
||||
|
||||
printDatum k v acc =
|
||||
(k ++ " = " ++ (printString True v)) :: acc
|
||||
in
|
||||
"--- Environment ---\n"
|
||||
++ "Current frame: #"
|
||||
++ (toString env.currentFrameId)
|
||||
++ "\n\n"
|
||||
++ String.join "\n\n" (Dict.foldr printFrameAcc [] env.frames)
|
||||
|
||||
@ -20,6 +20,8 @@ type alias Env =
|
||||
{ frames : Dict Int Frame
|
||||
, nextFrameId : Int
|
||||
, currentFrameId : Int
|
||||
, atoms : Dict Int MalExpr
|
||||
, nextAtomId : Int
|
||||
}
|
||||
|
||||
|
||||
@ -29,6 +31,10 @@ type EvalResult res
|
||||
| EvalIO (Cmd Msg) (IO -> Eval res)
|
||||
|
||||
|
||||
|
||||
-- TODO EvalTCO Env -> Eval MalExpr (?)
|
||||
|
||||
|
||||
type alias EvalContext res =
|
||||
( Env, EvalResult res )
|
||||
|
||||
@ -41,6 +47,23 @@ type Eval res
|
||||
= Eval (EvalFn res)
|
||||
|
||||
|
||||
type alias MalFn =
|
||||
List MalExpr -> Eval MalExpr
|
||||
|
||||
|
||||
type MalFunction
|
||||
= CoreFunc MalFn
|
||||
| UserFunc { frameId : Int, fn : MalFn }
|
||||
|
||||
|
||||
type alias TcoFn =
|
||||
() -> Eval MalExpr
|
||||
|
||||
|
||||
type alias Bound =
|
||||
List ( String, MalExpr )
|
||||
|
||||
|
||||
type MalExpr
|
||||
= MalNil
|
||||
| MalBool Bool
|
||||
@ -51,7 +74,9 @@ type MalExpr
|
||||
| MalList (List MalExpr)
|
||||
| MalVector (Array MalExpr)
|
||||
| MalMap (Dict String MalExpr)
|
||||
| MalFunction (List MalExpr -> Eval MalExpr)
|
||||
| MalFunction MalFunction
|
||||
| MalApply { frameId : Int, bound : Bound, body : MalExpr }
|
||||
| MalAtom Int
|
||||
|
||||
|
||||
{-| Keywords are prefixed by this char for usage in a MalMap.
|
||||
|
||||
11
elm/bootstrap.js
vendored
11
elm/bootstrap.js
vendored
@ -1,4 +1,5 @@
|
||||
var readline = require('./node_readline');
|
||||
var fs = require('fs');
|
||||
|
||||
// The first two arguments are: 'node' and 'bootstrap.js'
|
||||
// The third argument is the name of the Elm module to load.
|
||||
@ -19,3 +20,13 @@ app.ports.readLine.subscribe(function(prompt) {
|
||||
var line = readline.readline(prompt);
|
||||
app.ports.input.send({"tag": "lineRead", "line": line});
|
||||
});
|
||||
|
||||
// Read the contents of a file.
|
||||
app.ports.readFile.subscribe(function(filename) {
|
||||
try {
|
||||
var contents = fs.readFileSync(filename, 'utf8');
|
||||
app.ports.input.send({"tag": "fileRead", "contents": contents});
|
||||
} catch (e) {
|
||||
app.ports.input.send({"tag": "exception", "message": e.message});
|
||||
}
|
||||
});
|
||||
@ -66,7 +66,7 @@ update msg model =
|
||||
runInit env (cont io)
|
||||
|
||||
Input (Err msg) ->
|
||||
Debug.crash msg ( model, Cmd.none )
|
||||
Debug.crash msg
|
||||
|
||||
ReplActive env ->
|
||||
case msg of
|
||||
@ -85,8 +85,11 @@ update msg model =
|
||||
-- Ctrl+D = The End.
|
||||
( model, Cmd.none )
|
||||
|
||||
Input (Ok io) ->
|
||||
Debug.crash "unexpected IO received: " io
|
||||
|
||||
Input (Err msg) ->
|
||||
Debug.crash msg ( model, Cmd.none )
|
||||
Debug.crash msg
|
||||
|
||||
ReplIO env cont ->
|
||||
case msg of
|
||||
@ -145,42 +148,48 @@ read =
|
||||
|
||||
eval : MalExpr -> Eval MalExpr
|
||||
eval ast =
|
||||
case ast of
|
||||
MalList [] ->
|
||||
Eval.succeed ast
|
||||
Debug.log "eval " (printString True ast)
|
||||
|> (\_ ->
|
||||
case ast of
|
||||
MalList [] ->
|
||||
Eval.succeed ast
|
||||
|
||||
MalList ((MalSymbol "def!") :: args) ->
|
||||
evalDef args
|
||||
MalList ((MalSymbol "def!") :: args) ->
|
||||
evalDef args
|
||||
|
||||
MalList ((MalSymbol "let*") :: args) ->
|
||||
evalLet args
|
||||
MalList ((MalSymbol "let*") :: args) ->
|
||||
evalLet args
|
||||
|
||||
MalList ((MalSymbol "do") :: args) ->
|
||||
evalDo args
|
||||
MalList ((MalSymbol "do") :: args) ->
|
||||
evalDo args
|
||||
|
||||
MalList ((MalSymbol "if") :: args) ->
|
||||
evalIf args
|
||||
MalList ((MalSymbol "if") :: args) ->
|
||||
evalIf args
|
||||
|
||||
MalList ((MalSymbol "fn*") :: args) ->
|
||||
evalFn args
|
||||
MalList ((MalSymbol "fn*") :: args) ->
|
||||
evalFn args
|
||||
|
||||
MalList list ->
|
||||
evalList list
|
||||
|> Eval.andThen
|
||||
(\newList ->
|
||||
case newList of
|
||||
[] ->
|
||||
Eval.fail "can't happen"
|
||||
MalList list ->
|
||||
evalList list
|
||||
|> Eval.andThen
|
||||
(\newList ->
|
||||
case newList of
|
||||
[] ->
|
||||
Eval.fail "can't happen"
|
||||
|
||||
(MalFunction fn) :: args ->
|
||||
fn args
|
||||
(MalFunction (CoreFunc fn)) :: args ->
|
||||
fn args
|
||||
|
||||
fn :: _ ->
|
||||
Eval.fail ((printString True fn) ++ " is not a function")
|
||||
)
|
||||
(MalFunction (UserFunc { fn })) :: args ->
|
||||
fn args
|
||||
|
||||
_ ->
|
||||
evalAst ast
|
||||
fn :: _ ->
|
||||
Eval.fail ((printString True fn) ++ " is not a function")
|
||||
)
|
||||
|
||||
_ ->
|
||||
evalAst ast
|
||||
)
|
||||
|
||||
|
||||
evalAst : MalExpr -> Eval MalExpr
|
||||
@ -280,15 +289,8 @@ evalLet args =
|
||||
|> Eval.andThen (\_ -> eval body)
|
||||
|> Eval.andThen
|
||||
(\res ->
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
case Env.pop env of
|
||||
Ok env ->
|
||||
Eval.setEnv env |> Eval.map (\_ -> res)
|
||||
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
)
|
||||
Eval.modifyEnv Env.pop
|
||||
|> Eval.map (\_ -> res)
|
||||
)
|
||||
in
|
||||
case args of
|
||||
@ -408,22 +410,19 @@ evalFn args =
|
||||
else
|
||||
Ok <| zip binds args ++ [ ( var, varArgs ) ]
|
||||
|
||||
makeFn frameId binder body args =
|
||||
case binder args of
|
||||
Ok bound ->
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
Eval.modifyEnv (Env.enter frameId bound)
|
||||
|> Eval.andThen (\_ -> eval body)
|
||||
|> Eval.andThen
|
||||
(\res ->
|
||||
Eval.modifyEnv (Env.leave env.currentFrameId)
|
||||
|> Eval.map (\_ -> res)
|
||||
)
|
||||
)
|
||||
makeFn frameId binder body =
|
||||
MalFunction <|
|
||||
UserFunc
|
||||
{ frameId = frameId
|
||||
, fn =
|
||||
\args ->
|
||||
case binder args of
|
||||
Ok bound ->
|
||||
Eval.enter frameId bound (eval body)
|
||||
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
}
|
||||
|
||||
go bindsList body =
|
||||
case extractAndParse bindsList of
|
||||
@ -435,9 +434,7 @@ evalFn args =
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
Eval.succeed
|
||||
(MalFunction
|
||||
(makeFn env.currentFrameId binder body)
|
||||
)
|
||||
(makeFn env.currentFrameId binder body)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
505
elm/step5_tco.elm
Normal file
505
elm/step5_tco.elm
Normal file
@ -0,0 +1,505 @@
|
||||
port module Main exposing (..)
|
||||
|
||||
import Array
|
||||
import Dict exposing (Dict)
|
||||
import IO exposing (..)
|
||||
import Json.Decode exposing (decodeValue)
|
||||
import Platform exposing (programWithFlags)
|
||||
import Types exposing (..)
|
||||
import Reader exposing (readString)
|
||||
import Printer exposing (printString)
|
||||
import Utils exposing (maybeToList, zip, last, justValues)
|
||||
import Env
|
||||
import Core
|
||||
import Eval
|
||||
|
||||
|
||||
main : Program Flags Model Msg
|
||||
main =
|
||||
programWithFlags
|
||||
{ init = init
|
||||
, update = update
|
||||
, subscriptions =
|
||||
\model -> input (decodeValue decodeIO >> Input)
|
||||
}
|
||||
|
||||
|
||||
type alias Flags =
|
||||
{ args : List String
|
||||
}
|
||||
|
||||
|
||||
type Model
|
||||
= InitIO Env (IO -> Eval MalExpr)
|
||||
| InitError String
|
||||
| ReplActive Env
|
||||
| ReplIO Env (IO -> Eval MalExpr)
|
||||
|
||||
|
||||
init : Flags -> ( Model, Cmd Msg )
|
||||
init { args } =
|
||||
let
|
||||
initEnv =
|
||||
Core.ns
|
||||
|
||||
evalMalInit =
|
||||
Core.malInit
|
||||
|> List.map rep
|
||||
|> justValues
|
||||
|> List.foldl
|
||||
(\b a -> a |> Eval.andThen (\_ -> b))
|
||||
(Eval.succeed MalNil)
|
||||
in
|
||||
runInit initEnv evalMalInit
|
||||
|
||||
|
||||
update : Msg -> Model -> ( Model, Cmd Msg )
|
||||
update msg model =
|
||||
case model of
|
||||
InitError _ ->
|
||||
-- ignore all
|
||||
( model, Cmd.none )
|
||||
|
||||
InitIO env cont ->
|
||||
case msg of
|
||||
Input (Ok io) ->
|
||||
runInit env (cont io)
|
||||
|
||||
Input (Err msg) ->
|
||||
Debug.crash msg
|
||||
|
||||
ReplActive env ->
|
||||
case msg of
|
||||
Input (Ok (LineRead (Just line))) ->
|
||||
case rep line of
|
||||
Just expr ->
|
||||
run env expr
|
||||
|
||||
Nothing ->
|
||||
( model, readLine prompt )
|
||||
|
||||
Input (Ok LineWritten) ->
|
||||
( model, readLine prompt )
|
||||
|
||||
Input (Ok (LineRead Nothing)) ->
|
||||
-- Ctrl+D = The End.
|
||||
( model, Cmd.none )
|
||||
|
||||
Input (Ok io) ->
|
||||
Debug.crash "unexpected IO received: " io
|
||||
|
||||
Input (Err msg) ->
|
||||
Debug.crash msg
|
||||
|
||||
ReplIO env cont ->
|
||||
case msg of
|
||||
Input (Ok io) ->
|
||||
run env (cont io)
|
||||
|
||||
Input (Err msg) ->
|
||||
Debug.crash msg ( model, Cmd.none )
|
||||
|
||||
|
||||
runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg )
|
||||
runInit env expr =
|
||||
case Eval.run env expr of
|
||||
( env, EvalOk expr ) ->
|
||||
-- Init went okay, start REPL.
|
||||
( ReplActive env, readLine prompt )
|
||||
|
||||
( env, EvalErr msg ) ->
|
||||
-- Init failed, don't start REPL.
|
||||
( InitError msg, writeLine ("ERR:" ++ msg) )
|
||||
|
||||
( env, EvalIO cmd cont ) ->
|
||||
-- IO in init.
|
||||
( InitIO env cont, cmd )
|
||||
|
||||
|
||||
run : Env -> Eval MalExpr -> ( Model, Cmd Msg )
|
||||
run env expr =
|
||||
case Eval.run env expr of
|
||||
( env, EvalOk expr ) ->
|
||||
( ReplActive env, writeLine (print expr) )
|
||||
|
||||
( env, EvalErr msg ) ->
|
||||
( ReplActive env, writeLine ("ERR:" ++ msg) )
|
||||
|
||||
( env, EvalIO cmd cont ) ->
|
||||
( ReplIO env cont, cmd )
|
||||
|
||||
|
||||
prompt : String
|
||||
prompt =
|
||||
"user> "
|
||||
|
||||
|
||||
{-| read can return three things:
|
||||
|
||||
Ok (Just expr) -> parsed okay
|
||||
Ok Nothing -> empty string (only whitespace and/or comments)
|
||||
Err msg -> parse error
|
||||
|
||||
-}
|
||||
read : String -> Result String (Maybe MalExpr)
|
||||
read =
|
||||
readString
|
||||
|
||||
|
||||
eval : MalExpr -> Eval MalExpr
|
||||
eval ast =
|
||||
Debug.log "eval " (printString True ast)
|
||||
|> (\_ ->
|
||||
evalNoApply ast
|
||||
|> Eval.andThen
|
||||
(\ast ->
|
||||
case ast of
|
||||
MalApply { frameId, bound, body } ->
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
Eval.modifyEnv (Env.enter frameId bound)
|
||||
|> Eval.andThen (\_ -> evalNoApply body)
|
||||
|> Eval.andThen
|
||||
(\res ->
|
||||
Eval.modifyEnv (Env.leave env.currentFrameId)
|
||||
|> Eval.map (\_ -> res)
|
||||
)
|
||||
)
|
||||
|> Eval.andThen eval
|
||||
|
||||
_ ->
|
||||
Eval.succeed ast
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
evalNoApply : MalExpr -> Eval MalExpr
|
||||
evalNoApply ast =
|
||||
Debug.log "evalNoApply " (printString True ast)
|
||||
|> (\_ ->
|
||||
case ast of
|
||||
MalList [] ->
|
||||
Eval.succeed ast
|
||||
|
||||
MalList ((MalSymbol "def!") :: args) ->
|
||||
evalDef args
|
||||
|
||||
MalList ((MalSymbol "let*") :: args) ->
|
||||
evalLet args
|
||||
|
||||
MalList ((MalSymbol "do") :: args) ->
|
||||
evalDo args
|
||||
|
||||
MalList ((MalSymbol "if") :: args) ->
|
||||
evalIf args
|
||||
|
||||
MalList ((MalSymbol "fn*") :: args) ->
|
||||
evalFn args
|
||||
|
||||
MalList list ->
|
||||
evalList list
|
||||
|> Eval.andThen
|
||||
(\newList ->
|
||||
case newList of
|
||||
[] ->
|
||||
Eval.fail "can't happen"
|
||||
|
||||
(MalFunction (CoreFunc fn)) :: args ->
|
||||
fn args
|
||||
|
||||
(MalFunction (UserFunc { fn })) :: args ->
|
||||
fn args
|
||||
|
||||
fn :: _ ->
|
||||
Eval.fail ((printString True fn) ++ " is not a function")
|
||||
)
|
||||
|
||||
_ ->
|
||||
evalAst ast
|
||||
)
|
||||
|
||||
|
||||
evalAst : MalExpr -> Eval MalExpr
|
||||
evalAst ast =
|
||||
case ast of
|
||||
MalSymbol sym ->
|
||||
-- Lookup symbol in env and return value or raise error if not found.
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
case Env.get sym env of
|
||||
Ok val ->
|
||||
Eval.succeed val
|
||||
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
)
|
||||
|
||||
MalList list ->
|
||||
-- Return new list that is result of calling eval on each element of list.
|
||||
evalList list
|
||||
|> Eval.map MalList
|
||||
|
||||
MalVector vec ->
|
||||
evalList (Array.toList vec)
|
||||
|> Eval.map (Array.fromList >> MalVector)
|
||||
|
||||
MalMap map ->
|
||||
evalList (Dict.values map)
|
||||
|> Eval.map
|
||||
(zip (Dict.keys map)
|
||||
>> Dict.fromList
|
||||
>> MalMap
|
||||
)
|
||||
|
||||
_ ->
|
||||
Eval.succeed ast
|
||||
|
||||
|
||||
evalList : List MalExpr -> Eval (List MalExpr)
|
||||
evalList list =
|
||||
let
|
||||
go list acc =
|
||||
case list of
|
||||
[] ->
|
||||
Eval.succeed (List.reverse acc)
|
||||
|
||||
x :: rest ->
|
||||
eval x
|
||||
|> Eval.andThen
|
||||
(\val ->
|
||||
go rest (val :: acc)
|
||||
)
|
||||
in
|
||||
go list []
|
||||
|
||||
|
||||
evalDef : List MalExpr -> Eval MalExpr
|
||||
evalDef args =
|
||||
case args of
|
||||
[ MalSymbol name, uneValue ] ->
|
||||
eval uneValue
|
||||
|> Eval.andThen
|
||||
(\value ->
|
||||
Eval.modifyEnv (Env.set name value)
|
||||
|> Eval.andThen (\_ -> Eval.succeed value)
|
||||
)
|
||||
|
||||
_ ->
|
||||
Eval.fail "def! expected two args: name and value"
|
||||
|
||||
|
||||
evalLet : List MalExpr -> Eval MalExpr
|
||||
evalLet args =
|
||||
let
|
||||
evalBinds binds =
|
||||
case binds of
|
||||
(MalSymbol name) :: expr :: rest ->
|
||||
eval expr
|
||||
|> Eval.andThen
|
||||
(\value ->
|
||||
Eval.modifyEnv (Env.set name value)
|
||||
|> Eval.andThen
|
||||
(\_ ->
|
||||
if List.isEmpty rest then
|
||||
Eval.succeed ()
|
||||
else
|
||||
evalBinds rest
|
||||
)
|
||||
)
|
||||
|
||||
_ ->
|
||||
Eval.fail "let* expected an even number of binds (symbol expr ..)"
|
||||
|
||||
go binds body =
|
||||
Eval.modifyEnv Env.push
|
||||
|> Eval.andThen (\_ -> evalBinds binds)
|
||||
|> Eval.andThen (\_ -> evalNoApply body)
|
||||
|> Eval.andThen
|
||||
(\res ->
|
||||
Eval.modifyEnv Env.pop
|
||||
|> Eval.map (\_ -> res)
|
||||
)
|
||||
in
|
||||
case args of
|
||||
[ MalList binds, body ] ->
|
||||
go binds body
|
||||
|
||||
[ MalVector bindsVec, body ] ->
|
||||
go (Array.toList bindsVec) body
|
||||
|
||||
_ ->
|
||||
Eval.fail "let* expected two args: binds and a body"
|
||||
|
||||
|
||||
evalDo : List MalExpr -> Eval MalExpr
|
||||
evalDo args =
|
||||
case List.reverse args of
|
||||
last :: rest ->
|
||||
evalList (List.reverse rest)
|
||||
|> Eval.andThen (\_ -> evalNoApply last)
|
||||
|
||||
[] ->
|
||||
Eval.fail "do expected at least one arg"
|
||||
|
||||
|
||||
evalIf : List MalExpr -> Eval MalExpr
|
||||
evalIf args =
|
||||
let
|
||||
isThruthy expr =
|
||||
expr /= MalNil && expr /= (MalBool False)
|
||||
|
||||
go condition trueExpr falseExpr =
|
||||
eval condition
|
||||
|> Eval.map isThruthy
|
||||
|> Eval.andThen
|
||||
(\cond ->
|
||||
evalNoApply
|
||||
(if cond then
|
||||
trueExpr
|
||||
else
|
||||
falseExpr
|
||||
)
|
||||
)
|
||||
in
|
||||
case args of
|
||||
[ condition, trueExpr ] ->
|
||||
go condition trueExpr MalNil
|
||||
|
||||
[ condition, trueExpr, falseExpr ] ->
|
||||
go condition trueExpr falseExpr
|
||||
|
||||
_ ->
|
||||
Eval.fail "if expected at least two args"
|
||||
|
||||
|
||||
evalFn : List MalExpr -> Eval MalExpr
|
||||
evalFn args =
|
||||
let
|
||||
{- Extract symbols from the binds list and verify their uniqueness -}
|
||||
extractSymbols acc list =
|
||||
case list of
|
||||
[] ->
|
||||
Ok (List.reverse acc)
|
||||
|
||||
(MalSymbol name) :: rest ->
|
||||
if List.member name acc then
|
||||
Err "all binds must have unique names"
|
||||
else
|
||||
extractSymbols (name :: acc) rest
|
||||
|
||||
_ ->
|
||||
Err "all binds in fn* must be a symbol"
|
||||
|
||||
parseBinds list =
|
||||
case List.reverse list of
|
||||
var :: "&" :: rest ->
|
||||
Ok <| bindVarArgs (List.reverse rest) var
|
||||
|
||||
_ ->
|
||||
if List.member "&" list then
|
||||
Err "varargs separator '&' is used incorrectly"
|
||||
else
|
||||
Ok <| bindArgs list
|
||||
|
||||
extractAndParse =
|
||||
extractSymbols [] >> Result.andThen parseBinds
|
||||
|
||||
bindArgs binds args =
|
||||
let
|
||||
numBinds =
|
||||
List.length binds
|
||||
in
|
||||
if List.length args /= numBinds then
|
||||
Err <|
|
||||
"function expected "
|
||||
++ (toString numBinds)
|
||||
++ " arguments"
|
||||
else
|
||||
Ok <| zip binds args
|
||||
|
||||
bindVarArgs binds var args =
|
||||
let
|
||||
minArgs =
|
||||
List.length binds
|
||||
|
||||
varArgs =
|
||||
MalList (List.drop minArgs args)
|
||||
in
|
||||
if List.length args < minArgs then
|
||||
Err <|
|
||||
"function expected at least "
|
||||
++ (toString minArgs)
|
||||
++ " arguments"
|
||||
else
|
||||
Ok <| zip binds args ++ [ ( var, varArgs ) ]
|
||||
|
||||
makeFn frameId binder body =
|
||||
MalFunction <|
|
||||
UserFunc
|
||||
{ frameId = frameId
|
||||
, fn =
|
||||
\args ->
|
||||
case binder args of
|
||||
Ok bound ->
|
||||
Eval.succeed <|
|
||||
-- TODO : choice Env.enter prematurely?
|
||||
-- I think it is needed by the garbage collect..
|
||||
MalApply
|
||||
{ frameId = frameId
|
||||
, bound = bound
|
||||
, body = body
|
||||
}
|
||||
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
}
|
||||
|
||||
go bindsList body =
|
||||
case extractAndParse bindsList of
|
||||
Ok binder ->
|
||||
Eval.modifyEnv Env.ref
|
||||
-- reference the current frame.
|
||||
|> Eval.andThen
|
||||
(\_ ->
|
||||
Eval.withEnv
|
||||
(\env ->
|
||||
Eval.succeed
|
||||
(makeFn env.currentFrameId binder body)
|
||||
)
|
||||
)
|
||||
|
||||
Err msg ->
|
||||
Eval.fail msg
|
||||
in
|
||||
case args of
|
||||
[ MalList bindsList, body ] ->
|
||||
go bindsList body
|
||||
|
||||
[ MalVector bindsVec, body ] ->
|
||||
go (Array.toList bindsVec) body
|
||||
|
||||
_ ->
|
||||
Eval.fail "fn* expected two args: binds list and body"
|
||||
|
||||
|
||||
print : MalExpr -> String
|
||||
print =
|
||||
printString True
|
||||
|
||||
|
||||
{-| Read-Eval-Print.
|
||||
|
||||
Doesn't actually run the Eval but returns the monad.
|
||||
|
||||
-}
|
||||
rep : String -> Maybe (Eval MalExpr)
|
||||
rep input =
|
||||
case readString input of
|
||||
Ok Nothing ->
|
||||
Nothing
|
||||
|
||||
Err msg ->
|
||||
Just (Eval.fail msg)
|
||||
|
||||
Ok (Just ast) ->
|
||||
eval ast |> Just
|
||||
Loading…
Reference in New Issue
Block a user