add stream list to interpreter state
This commit is contained in:
parent
d10596f037
commit
3d680c99f9
19
interp.hs
19
interp.hs
|
@ -1,23 +1,26 @@
|
||||||
import Control.Monad.State (State, runState, evalState, get, put)
|
import Control.Monad.State (State, runState, evalState, get, put)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.ByteString.Lazy as BS
|
||||||
import AST
|
import AST
|
||||||
import Parser (parseProgram)
|
import Parser (parseProgram)
|
||||||
|
|
||||||
data Value = IntV Integer
|
data Value = IntV Integer
|
||||||
| StrV String
|
| StrV String
|
||||||
| UnitV
|
| UnitV
|
||||||
|
| StreamV Int
|
||||||
| ListV [Value]
|
| ListV [Value]
|
||||||
| FnV [(Pattern, [AST])] -- pattern->body bindings
|
| FnV [(Pattern, [AST])] -- pattern->body bindings
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
type Env = M.Map String Value -- an environment
|
type Env = M.Map String Value -- an environment
|
||||||
type InterpState = State Env -- interpreter state (pass along the global environment)
|
type InterpState = State ([BS.ByteString], Env) -- interpreter state
|
||||||
|
|
||||||
(IntV l) +$ (IntV r) = IntV (l + r)
|
(IntV l) +$ (IntV r) = IntV (l + r)
|
||||||
(StrV l) +$ (StrV r) = StrV (l ++ r)
|
(StrV l) +$ (StrV r) = StrV (l ++ r)
|
||||||
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
|
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
|
||||||
|
|
||||||
initialState = M.fromList [("id", FnV [(VarP "x", [Var "x"])])]
|
initialState = ([], M.fromList [("id", FnV [(VarP "x", [Var "x"])]),
|
||||||
|
("stdout", StreamV 0)])
|
||||||
|
|
||||||
eval :: AST -> InterpState Value
|
eval :: AST -> InterpState Value
|
||||||
|
|
||||||
|
@ -30,15 +33,15 @@ eval (ListConst v) =
|
||||||
mapM eval v >>= \xs ->
|
mapM eval v >>= \xs ->
|
||||||
return $ ListV xs
|
return $ ListV xs
|
||||||
|
|
||||||
eval (Var var) = get >>= \m ->
|
eval (Var var) = get >>= \(_,m) ->
|
||||||
case M.lookup var m of
|
case M.lookup var m of
|
||||||
Just v -> return v
|
Just v -> return v
|
||||||
Nothing -> error $ "unbound variable " ++ var
|
Nothing -> error $ "unbound variable " ++ var
|
||||||
|
|
||||||
eval (Def name v') = do
|
eval (Def name v') = do
|
||||||
v <- eval v'
|
v <- eval v'
|
||||||
m <- get
|
(s,m) <- get
|
||||||
put $ M.insert name v m
|
put (s, M.insert name v m)
|
||||||
return v
|
return v
|
||||||
|
|
||||||
eval (Lambda pats) =
|
eval (Lambda pats) =
|
||||||
|
@ -49,7 +52,7 @@ eval (Add l r) = do
|
||||||
r <- eval r
|
r <- eval r
|
||||||
return $ l +$ r
|
return $ l +$ r
|
||||||
|
|
||||||
eval (Call name args) = get >>= \m ->
|
eval (Call name args) = get >>= \(_,m) ->
|
||||||
case M.lookup name m of
|
case M.lookup name m of
|
||||||
Just fn@(FnV _) ->
|
Just fn@(FnV _) ->
|
||||||
do
|
do
|
||||||
|
@ -104,8 +107,8 @@ apply (FnV pats) arg =
|
||||||
case patternBindings pat arg of
|
case patternBindings pat arg of
|
||||||
Just env' -> -- satisfies
|
Just env' -> -- satisfies
|
||||||
do
|
do
|
||||||
env <- get
|
(s,env) <- get
|
||||||
put $ M.union env env'
|
put (s, M.union env env')
|
||||||
foldr1 (>>) $ map eval body
|
foldr1 (>>) $ map eval body
|
||||||
Nothing -> -- doesn't satisfy this pattern
|
Nothing -> -- doesn't satisfy this pattern
|
||||||
apply' xs
|
apply' xs
|
||||||
|
|
Loading…
Reference in New Issue