2013-10-18 01:58:41 +00:00
|
|
|
import Control.Monad.State (State, runState, evalState, get, put)
|
|
|
|
import qualified Data.Map as M
|
2013-10-19 06:21:06 +00:00
|
|
|
import AST
|
|
|
|
import Parser (parseProgram)
|
2013-10-18 01:58:41 +00:00
|
|
|
|
2013-10-19 06:21:06 +00:00
|
|
|
data Value = IntV Integer
|
2013-10-18 01:58:41 +00:00
|
|
|
| StrV String
|
2013-10-19 06:21:06 +00:00
|
|
|
| UnitV
|
2013-10-18 20:24:00 +00:00
|
|
|
| ListV [Value]
|
2013-10-18 08:14:13 +00:00
|
|
|
| FnV [(Pattern, [AST])] -- pattern->body bindings
|
2013-10-18 01:58:41 +00:00
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
type Env = M.Map String Value -- an environment
|
|
|
|
type InterpState = State Env -- interpreter state (pass along the global environment)
|
|
|
|
|
|
|
|
(IntV l) +$ (IntV r) = IntV (l + r)
|
|
|
|
(StrV l) +$ (StrV r) = StrV (l ++ r)
|
|
|
|
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
|
|
|
|
|
2013-10-18 08:14:13 +00:00
|
|
|
initialState = M.fromList [("id", FnV [(VarP "x", [Var "x"])])]
|
2013-10-18 03:46:34 +00:00
|
|
|
|
2013-10-18 01:58:41 +00:00
|
|
|
eval :: AST -> InterpState Value
|
|
|
|
|
|
|
|
eval (IntConst i) = return $ IntV i
|
|
|
|
eval (StrConst s) = return $ StrV s
|
|
|
|
|
2013-10-19 06:21:06 +00:00
|
|
|
eval UnitConst = return UnitV
|
|
|
|
|
2013-10-18 20:24:00 +00:00
|
|
|
eval (ListConst v) =
|
|
|
|
mapM eval v >>= \xs ->
|
|
|
|
return $ ListV xs
|
|
|
|
|
2013-10-18 01:58:41 +00:00
|
|
|
eval (Var var) = get >>= \m ->
|
|
|
|
case M.lookup var m of
|
|
|
|
Just v -> return v
|
|
|
|
Nothing -> error $ "unbound variable " ++ var
|
|
|
|
|
|
|
|
eval (Def name v') = do
|
|
|
|
v <- eval v'
|
|
|
|
m <- get
|
|
|
|
put $ M.insert name v m
|
|
|
|
return v
|
|
|
|
|
2013-10-18 08:14:13 +00:00
|
|
|
eval (Lambda pats) =
|
|
|
|
return $ FnV pats
|
|
|
|
|
2013-10-18 01:58:41 +00:00
|
|
|
eval (Add l r) = do
|
|
|
|
l <- eval l
|
|
|
|
r <- eval r
|
|
|
|
return $ l +$ r
|
|
|
|
|
2013-10-18 03:46:34 +00:00
|
|
|
eval (Call name args) = get >>= \m ->
|
|
|
|
case M.lookup name m of
|
|
|
|
Just fn@(FnV _) ->
|
|
|
|
do
|
|
|
|
xargs <- mapM eval args
|
2013-10-18 08:14:13 +00:00
|
|
|
applyMany fn xargs
|
2013-10-18 03:46:34 +00:00
|
|
|
Nothing -> error $ "call: name " ++ name ++ " doesn't exist or is not a function"
|
|
|
|
|
|
|
|
patternBindings :: Pattern -> Value -> Maybe Env
|
|
|
|
patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
|
2013-10-18 20:49:33 +00:00
|
|
|
|
2013-10-18 08:28:42 +00:00
|
|
|
patternBindings (IntP n) (IntV v)
|
|
|
|
| v == n = Just M.empty
|
|
|
|
| otherwise = Nothing
|
|
|
|
patternBindings (IntP n) _ = Nothing
|
2013-10-18 03:46:34 +00:00
|
|
|
|
2013-10-19 06:21:06 +00:00
|
|
|
patternBindings UnitP UnitV = Just M.empty
|
|
|
|
patternBindings UnitP _ = Nothing
|
|
|
|
|
2013-10-18 21:06:27 +00:00
|
|
|
patternBindings (ConsP x (ListP [])) (ListV (y:[])) = patternBindings x y
|
2013-10-18 20:49:33 +00:00
|
|
|
patternBindings (ConsP _ _) (ListV (_:[])) = Nothing
|
|
|
|
patternBindings (ConsP xp xsp) (ListV (x:xs)) =
|
|
|
|
do
|
|
|
|
xe <- patternBindings xp x
|
|
|
|
xse <- patternBindings xsp $ ListV xs
|
|
|
|
Just $ M.union xe xse
|
|
|
|
|
2013-10-18 21:06:27 +00:00
|
|
|
patternBindings (ListP []) (ListV (x:xs)) = Nothing -- not enough patterns
|
|
|
|
patternBindings (ListP (_:_)) (ListV []) = Nothing -- not enough values
|
|
|
|
patternBindings (ListP []) (ListV []) = Just M.empty -- base case
|
|
|
|
patternBindings (ListP (x:xs)) (ListV (y:ys)) =
|
|
|
|
do
|
|
|
|
env <- patternBindings x y
|
|
|
|
env' <- patternBindings (ListP xs) (ListV ys)
|
|
|
|
Just $ M.union env' env
|
|
|
|
|
2013-10-18 08:14:13 +00:00
|
|
|
-- applies many arguments to a function
|
|
|
|
applyMany :: Value -> [Value] -> InterpState Value
|
|
|
|
applyMany fn@(FnV _) (arg:xs) =
|
|
|
|
apply fn arg >>= \value ->
|
|
|
|
applyMany value xs
|
|
|
|
applyMany value [] = return value
|
|
|
|
applyMany _ xs = error "couldn't apply all arguments"
|
|
|
|
|
2013-10-18 03:46:34 +00:00
|
|
|
-- applies a function
|
2013-10-18 08:14:13 +00:00
|
|
|
apply :: Value -> Value -> InterpState Value
|
|
|
|
apply (FnV pats) arg =
|
|
|
|
apply' pats
|
2013-10-18 03:46:34 +00:00
|
|
|
where
|
2013-10-18 08:28:42 +00:00
|
|
|
apply' [] = error $ "argument " ++ show arg ++ " doesn't satisfy any patterns"
|
2013-10-18 08:14:13 +00:00
|
|
|
apply' ((pat, body):xs) =
|
2013-10-18 03:46:34 +00:00
|
|
|
case patternBindings pat arg of
|
|
|
|
Just env' -> -- satisfies
|
|
|
|
do
|
|
|
|
env <- get
|
|
|
|
put $ M.union env env'
|
|
|
|
foldr1 (>>) $ map eval body
|
2013-10-18 08:28:42 +00:00
|
|
|
Nothing -> -- doesn't satisfy this pattern
|
|
|
|
apply' xs
|
2013-10-18 03:46:34 +00:00
|
|
|
|
2013-10-18 01:58:41 +00:00
|
|
|
evalProgram :: [AST] -> Value -- fold the state from each node and return the result
|
2013-10-18 03:46:34 +00:00
|
|
|
evalProgram nodes = evalState (foldr1 (>>) $ map eval nodes) initialState
|
2013-10-18 01:58:41 +00:00
|
|
|
|
|
|
|
main = do
|
|
|
|
print $ evalProgram prg
|
|
|
|
print $ evalProgram prg2
|
2013-10-18 03:46:34 +00:00
|
|
|
print $ evalProgram prg3
|
2013-10-18 20:24:00 +00:00
|
|
|
print $ evalProgram prg4
|
2013-10-18 01:58:41 +00:00
|
|
|
where
|
|
|
|
prg = [Def "x" (IntConst 5),
|
|
|
|
Def "y" (IntConst 3),
|
|
|
|
Add (Var "x") (Var "y")]
|
2013-10-18 03:46:34 +00:00
|
|
|
prg2 = [Add (StrConst "hi ") (StrConst "there")]
|
2013-10-18 08:14:13 +00:00
|
|
|
lam arg body = Lambda [(VarP arg, [body])]
|
|
|
|
prg3 = [ Def "add" (lam "x" $ lam "y" $ Add (Var "x") (Var "y")),
|
2013-10-18 08:28:42 +00:00
|
|
|
Def "f" $ Lambda [
|
|
|
|
(IntP 0, [IntConst 100]),
|
|
|
|
(IntP 1, [IntConst 200]),
|
|
|
|
(VarP "x", [IntConst 300])
|
|
|
|
],
|
2013-10-18 20:24:00 +00:00
|
|
|
Call "f" [IntConst 2]]
|
2013-10-18 20:49:33 +00:00
|
|
|
prg4 = [ Def "lst" (ListConst [IntConst 1, IntConst 2, IntConst 3]),
|
|
|
|
Def "f" $ Lambda [
|
2013-10-18 21:06:27 +00:00
|
|
|
(ListP [VarP "x", VarP "y", VarP "z", VarP "w"], [Var "w"]),
|
2013-10-18 20:49:33 +00:00
|
|
|
(ConsP (VarP "x") (ConsP (VarP "y") (VarP "ys")), [Var "ys"])
|
|
|
|
],
|
|
|
|
Call "f" [Var "lst"]]
|