2013-10-21 00:48:02 +00:00
|
|
|
-- Interpreter for the Lamb programming language
|
|
|
|
-- Copyright (c) 2013 darkf
|
|
|
|
-- Licensed under the terms of the zlib license, see LICENSE for details
|
|
|
|
|
2013-10-20 22:55:30 +00:00
|
|
|
module Interp where
|
2013-10-20 23:30:39 +00:00
|
|
|
import Prelude hiding (lookup)
|
2013-10-18 01:58:41 +00:00
|
|
|
import qualified Data.Map as M
|
2013-10-22 22:10:34 +00:00
|
|
|
import Data.List (intercalate)
|
2013-10-23 00:24:28 +00:00
|
|
|
import Control.Monad.Trans (lift)
|
|
|
|
import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put)
|
2013-10-20 08:12:10 +00:00
|
|
|
import System.IO (Handle, hPutStr, hGetLine, hFlush, stdout, stdin)
|
2013-10-20 05:42:48 +00:00
|
|
|
import System.IO.Unsafe (unsafePerformIO)
|
2013-10-19 06:21:06 +00:00
|
|
|
import AST
|
|
|
|
import Parser (parseProgram)
|
2013-10-18 01:58:41 +00:00
|
|
|
|
2013-10-20 05:42:48 +00:00
|
|
|
-- for Show
|
|
|
|
newtype BIF = BIF (Value -> InterpState Value)
|
|
|
|
instance Show BIF where show _ = "<built-in>"
|
|
|
|
instance Eq BIF where a == b = False
|
|
|
|
|
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-20 04:34:30 +00:00
|
|
|
| StreamV Int
|
2013-10-22 22:10:34 +00:00
|
|
|
| TupleV [Value]
|
2013-10-18 20:24:00 +00:00
|
|
|
| ListV [Value]
|
2013-10-20 05:42:48 +00:00
|
|
|
| Builtin BIF
|
2013-10-21 20:18:25 +00:00
|
|
|
| FnV [(Pattern, AST)] -- pattern->body bindings
|
2013-10-21 05:37:58 +00:00
|
|
|
deriving (Eq)
|
2013-10-18 01:58:41 +00:00
|
|
|
|
|
|
|
type Env = M.Map String Value -- an environment
|
2013-10-23 00:24:28 +00:00
|
|
|
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
|
2013-10-18 01:58:41 +00:00
|
|
|
|
2013-10-20 23:30:39 +00:00
|
|
|
lookup :: Env -> String -> Maybe Value
|
|
|
|
lookup env name = M.lookup name env
|
|
|
|
|
2013-10-20 23:32:23 +00:00
|
|
|
bind :: Env -> String -> Value -> Env
|
|
|
|
bind env name value = M.insert name value env
|
|
|
|
|
2013-10-21 05:37:58 +00:00
|
|
|
instance Show Value where
|
|
|
|
show (IntV i) = show i
|
|
|
|
show (StrV s) = show s
|
2013-10-22 22:10:34 +00:00
|
|
|
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
2013-10-21 05:37:58 +00:00
|
|
|
show (ListV v) = show v
|
|
|
|
show (FnV _) = "<fn>"
|
|
|
|
show (StreamV _) = "<stream>"
|
|
|
|
show (Builtin _) = "<built-in>"
|
|
|
|
show UnitV = "()"
|
|
|
|
|
2013-10-21 00:24:51 +00:00
|
|
|
-- value operators
|
2013-10-18 01:58:41 +00:00
|
|
|
(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-21 00:24:51 +00:00
|
|
|
(IntV l) -$ (IntV r) = IntV (l - r)
|
|
|
|
l -$ r = error $ "cannot - " ++ show l ++ " and " ++ show r
|
|
|
|
|
|
|
|
(IntV l) *$ (IntV r) = IntV (l * r)
|
|
|
|
l *$ r = error $ "cannot * " ++ show l ++ " and " ++ show r
|
|
|
|
|
|
|
|
(IntV l) /$ (IntV r) = IntV (l `div` r)
|
|
|
|
l /$ r = error $ "cannot / " ++ show l ++ " and " ++ show r
|
|
|
|
|
2013-10-20 05:42:48 +00:00
|
|
|
_putstr (StrV str) = do
|
|
|
|
(handles,_) <- get
|
|
|
|
let stdout_s = head handles
|
2013-10-23 00:24:28 +00:00
|
|
|
io <- lift $ hPutStr stdout_s str >> hFlush stdout_s
|
|
|
|
return UnitV
|
2013-10-20 08:12:10 +00:00
|
|
|
|
2013-10-21 05:37:58 +00:00
|
|
|
_print v = _putstr $ StrV $ show v ++ "\n"
|
|
|
|
|
2013-10-20 08:12:10 +00:00
|
|
|
_getline UnitV = do
|
|
|
|
(handles,_) <- get
|
|
|
|
let stdin_s = handles !! 1
|
2013-10-23 00:24:28 +00:00
|
|
|
str <- lift $ hGetLine stdin_s
|
|
|
|
return $ StrV str
|
2013-10-20 05:42:48 +00:00
|
|
|
|
2013-10-21 00:25:38 +00:00
|
|
|
_itos (IntV i) = return $ StrV $ show i
|
|
|
|
_itos v = error $ "itos: not an int: " ++ show v
|
|
|
|
|
2013-10-20 08:12:10 +00:00
|
|
|
initialState = ([stdout, stdin],
|
2013-10-21 20:18:25 +00:00
|
|
|
M.fromList [("id", FnV [(VarP "x", Var "x")]),
|
2013-10-20 05:42:48 +00:00
|
|
|
("stdout", StreamV 0),
|
|
|
|
("putstr", Builtin $ BIF _putstr),
|
2013-10-20 08:12:10 +00:00
|
|
|
("putstrln", Builtin $ BIF (\x -> _putstr $ x +$ StrV "\n")),
|
2013-10-21 05:37:58 +00:00
|
|
|
("print", Builtin $ BIF _print),
|
2013-10-21 00:25:38 +00:00
|
|
|
("itos", Builtin $ BIF _itos),
|
2013-10-20 08:12:10 +00:00
|
|
|
("getline", Builtin $ BIF _getline)])
|
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-20 23:04:56 +00:00
|
|
|
eval (Block body) = foldr1 (>>) $ map eval body
|
|
|
|
|
2013-10-21 05:27:27 +00:00
|
|
|
eval (Cons a b) = do
|
|
|
|
a' <- eval a
|
|
|
|
b' <- eval b
|
|
|
|
case b' of
|
|
|
|
ListV v' -> return $ ListV $ a':v'
|
|
|
|
_ -> error "cons: RHS must be a list"
|
|
|
|
|
2013-10-18 20:24:00 +00:00
|
|
|
eval (ListConst v) =
|
|
|
|
mapM eval v >>= \xs ->
|
|
|
|
return $ ListV xs
|
|
|
|
|
2013-10-22 22:10:34 +00:00
|
|
|
eval (TupleConst v) = mapM eval v >>= return . TupleV
|
|
|
|
|
2013-10-20 23:30:39 +00:00
|
|
|
eval (Var var) = get >>= \(_,env) ->
|
|
|
|
case lookup env var of
|
2013-10-18 01:58:41 +00:00
|
|
|
Just v -> return v
|
|
|
|
Nothing -> error $ "unbound variable " ++ var
|
|
|
|
|
2013-10-20 23:57:48 +00:00
|
|
|
eval (Defun name fn) = do
|
|
|
|
(s,env) <- get
|
|
|
|
case lookup env name of
|
2013-10-22 22:59:05 +00:00
|
|
|
Nothing -> -- bind new fn
|
|
|
|
eval fn >>= \fn' ->
|
|
|
|
put (s, bind env name fn') >> return fn'
|
|
|
|
Just oldfn -> -- add pattern to old fn
|
|
|
|
let FnV oldpats = oldfn
|
|
|
|
Lambda [(pat, body)] = fn
|
|
|
|
newfn = FnV (oldpats ++ [(pat, body)]) in
|
|
|
|
put (s, bind env name newfn) >> return newfn
|
2013-10-20 23:57:48 +00:00
|
|
|
|
2013-10-18 01:58:41 +00:00
|
|
|
eval (Def name v') = do
|
|
|
|
v <- eval v'
|
2013-10-20 23:32:23 +00:00
|
|
|
(s,env) <- get
|
|
|
|
put (s, bind env name v)
|
2013-10-18 01:58:41 +00:00
|
|
|
return v
|
|
|
|
|
2013-10-18 08:14:13 +00:00
|
|
|
eval (Lambda pats) =
|
|
|
|
return $ FnV pats
|
|
|
|
|
2013-10-21 00:24:51 +00:00
|
|
|
eval (Add l r) = do { l <- eval l; r <- eval r; return $ l +$ r }
|
|
|
|
eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r }
|
|
|
|
eval (Mul l r) = do { l <- eval l; r <- eval r; return $ l *$ r }
|
|
|
|
eval (Div l r) = do { l <- eval l; r <- eval r; return $ l /$ r }
|
2013-10-18 01:58:41 +00:00
|
|
|
|
2013-10-22 22:59:05 +00:00
|
|
|
eval (Call name arg) = get >>= \(_,env) ->
|
2013-10-20 23:30:39 +00:00
|
|
|
case lookup env name of
|
2013-10-22 22:59:05 +00:00
|
|
|
Just fn@(FnV _) -> eval arg >>= apply fn
|
|
|
|
Just fn@(Builtin _) -> eval arg >>= apply fn
|
2013-10-18 03:46:34 +00:00
|
|
|
Nothing -> error $ "call: name " ++ name ++ " doesn't exist or is not a function"
|
|
|
|
|
2013-10-22 22:59:05 +00:00
|
|
|
eval x = error $ "eval: unhandled: " ++ show x
|
|
|
|
|
2013-10-18 03:46:34 +00:00
|
|
|
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 xp xsp) (ListV (x:xs)) =
|
|
|
|
do
|
|
|
|
xe <- patternBindings xp x
|
|
|
|
xse <- patternBindings xsp $ ListV xs
|
|
|
|
Just $ M.union xe xse
|
2013-10-19 09:21:04 +00:00
|
|
|
patternBindings (ConsP _ _) _ = Nothing
|
2013-10-18 20:49:33 +00:00
|
|
|
|
2013-10-22 22:59:05 +00:00
|
|
|
-- lists
|
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-21 00:04:12 +00:00
|
|
|
patternBindings (ListP _) _ = Nothing -- not a list
|
2013-10-18 21:06:27 +00:00
|
|
|
|
2013-10-22 22:59:05 +00:00
|
|
|
-- tuples
|
|
|
|
patternBindings (TupleP []) (TupleV (x:_)) = Nothing -- not enough patterns
|
|
|
|
patternBindings (TupleP (_:_)) (TupleV []) = Nothing -- not enough values
|
|
|
|
patternBindings (TupleP []) (TupleV []) = Just M.empty -- base case
|
|
|
|
patternBindings (TupleP (x:xs)) (TupleV (y:ys)) =
|
|
|
|
do
|
|
|
|
env <- patternBindings x y
|
|
|
|
env' <- patternBindings (TupleP xs) (TupleV ys)
|
|
|
|
Just $ M.union env' env
|
|
|
|
patternBindings (TupleP _) _ = Nothing -- not a tuple
|
2013-10-18 08:14:13 +00:00
|
|
|
|
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
|
2013-10-20 04:34:30 +00:00
|
|
|
(s,env) <- get
|
2013-10-21 01:45:23 +00:00
|
|
|
put (s, M.union env' env)
|
2013-10-21 20:18:25 +00:00
|
|
|
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-22 22:59:05 +00:00
|
|
|
apply (Builtin (BIF fn)) arg = fn arg
|
|
|
|
|
2013-10-23 00:24:28 +00:00
|
|
|
evalProgram :: [AST] -> IO Value -- fold the state from each node and return the result
|
|
|
|
evalProgram nodes = evalStateT (foldr1 (>>) $ map eval nodes) initialState
|
2013-10-18 01:58:41 +00:00
|
|
|
|
2013-10-23 00:24:28 +00:00
|
|
|
evalString :: String -> IO Value
|
2013-10-19 09:21:34 +00:00
|
|
|
evalString program =
|
|
|
|
case parseProgram program of
|
|
|
|
Left err -> error $ show err
|
|
|
|
Right prg -> evalProgram prg
|