The Lamb programming language - https://github.com/darkf/lamb
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

547 lines
18 KiB

-- Interpreter for the Lamb programming language
-- Copyright (c) 2013 darkf
-- Licensed under the terms of the zlib license, see LICENSE for details
module Interp where
import Prelude hiding (lookup, (<$))
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Char8 as BSC
import qualified Network.Socket as SO
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.List (intercalate, foldl1')
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Bits
import Control.Applicative ((<$>))
import Control.Exception (try, SomeException)
import Control.Concurrent (ThreadId, forkIO, threadDelay, killThread)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put)
import System.IO (Handle, hPutStr, hGetLine, hClose, hIsEOF, hSetBuffering,
hSetBinaryMode, openBinaryFile, IOMode(..), BufferMode(NoBuffering), stdout, stdin)
import System.Directory (doesFileExist)
import System.FilePath (FilePath, splitExtension, takeBaseName, takeDirectory, (</>))
import System.Environment (getExecutablePath)
import AST
import Parser (parseProgram)
-- for Show
newtype BIF = BIF (Value -> InterpState Value)
instance Show BIF where show _ = "<built-in>"
instance Eq BIF where a == b = False
instance Ord BIF where compare a b = if a == b then EQ else LT
data Value = IntV Integer
| StrV T.Text
| BoolV Bool
| StreamV Handle
| TupleV [Value]
| ListV [Value]
| DictV (M.Map Value Value)
| RefV (TVar Value)
| Thread ThreadId
| Builtin BIF
| FnV Env [(Pattern, AST)] -- closure pattern->body bindings
deriving (Eq)
instance Ord Value where
compare (IntV a) (IntV b) = compare a b
compare (StrV a) (StrV b) = compare a b
compare (BoolV a) (BoolV b) = compare a b
compare (TupleV a) (TupleV b) = compare a b
compare (ListV a) (ListV b) = compare a b
compare (StreamV a) (StreamV b) = if a == b then EQ else LT
compare (Builtin a) (Builtin b) = compare a b
compare (FnV a b) (FnV x y) = if a == x && b == y then EQ else LT
compare (DictV a) (DictV b) = compare a b
compare _ _ = error "compare: not valid"
type Env = [M.Map T.Text Value] -- lexical environment (linked list)
type InterpState = StateT Env IO -- interpreter state (open handles, global env)
type StrDict = M.Map T.Text Value
type ValueDict = M.Map Value Value
emptyEnv = [M.empty]
unitv = TupleV []
-- look up a binding from the bottom up
lookup :: Env -> T.Text -> Maybe Value
lookup [] _ = Nothing
lookup (env:xs) name = maybe (lookup xs name) Just (M.lookup name env)
-- bind in the local environment
bind :: Env -> T.Text -> Value -> Env
bind (env:xs) name value = (M.insert name value env):xs
instance Show Value where
show (IntV i) = show i
show (StrV s) = show s
show (BoolV b) = show b
show (TupleV []) = "(,)"
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
show (ListV v) = show v
show (DictV d) = "<dict " ++ show d ++ ">"
show (FnV _ _) = "<fn>"
show (StreamV _) = "<stream>"
show (Builtin _) = "<built-in>"
show (RefV _) = "<ref>"
show (Thread t) = "<thread " ++ show t ++ ">"
-- value operators
(IntV l) +$ (IntV r) = IntV (l + r)
(StrV l) +$ (StrV r) = StrV (l `T.append` r)
(ListV l) +$ (ListV r) = ListV (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 * 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
(IntV l) <$ (IntV r) = BoolV (l < r)
l <$ r = error $ "cannot < " ++ show l ++ " and " ++ show r
(IntV l) >$ (IntV r) = BoolV (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 .|. r)
l |$ r = error $ "cannot | " ++ show l ++ " and " ++ show r
(IntV l) <<$ (IntV r) = IntV (l `shiftL` fromInteger r)
l <<$ r = error $ "cannot << " ++ show l ++ " and " ++ show r
(IntV l) >>$ (IntV r) = IntV (l `shiftR` fromInteger r)
l >>$ r = error $ "cannot >> " ++ show l ++ " and " ++ show r
bitNot (IntV v) = IntV (complement v)
bitNot v = error $ "cannot ~ " ++ show v
l ==$ r = BoolV (l == r)
l !=$ r = BoolV (l /= r)
toDict :: StrDict -> Value
toDict m = DictV (M.mapKeys StrV m) -- wrap keys in StrV
fromDict :: ValueDict -> StrDict
fromDict m = M.mapKeys (\(StrV k) -> k) m -- unwrap keys
-- some built-in functions
_fputstr (TupleV [StreamV handle, StrV str]) =
liftIO $ TIO.hPutStr handle str >> return unitv
_fgetline (StreamV handle) = do
str <- liftIO $ TIO.hGetLine handle
if T.last str == '\r' then -- remove trailing CR
return . StrV $ T.init str
else return $ StrV str
_freadbytes (TupleV [StreamV handle, IntV n]) = do
liftIO $ StrV . T.take (fromIntegral n) <$> TIO.hGetContents handle
_freadcontents (StreamV handle) = do
liftIO $ StrV <$> TIO.hGetContents handle
_fopen (TupleV [StrV path, StrV mode]) = do
let mode' = case T.unpack mode of
"r" -> ReadMode
"w" -> WriteMode
"rw" -> ReadWriteMode
StreamV <$> liftIO (openBinaryFile (T.unpack path) mode')
_feof (StreamV handle) = do
BoolV <$> liftIO (hIsEOF handle)
_fclose (StreamV handle) = do
liftIO (hClose handle) >> return unitv
_sockopen (TupleV [StrV host, IntV port]) = do
liftIO $ SO.withSocketsDo $ do
addr:_ <- SO.getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port)
sock <- SO.socket (SO.addrFamily addr) SO.Stream SO.defaultProtocol
SO.connect sock (SO.addrAddress addr)
handle <- SO.socketToHandle sock ReadWriteMode
hSetBuffering handle NoBuffering
return $ StreamV handle
_putstr str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
_putbytes str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
_getline (TupleV []) = _fgetline (StreamV stdin)
_print v = _putbytes $ StrV $ T.pack (show v) `T.snoc` '\n'
_repr v = return . StrV $ T.pack $ show v
_itos (IntV i) = return $ StrV $ T.pack $ show i
_itos v = error $ "itos: not an int: " ++ show v
_stoi (StrV s) = return $ IntV $ read $ T.unpack s
_stoi v = error $ "stoi: not a string: " ++ show v
_ord (StrV s) = return $ IntV $ toInteger $ fromEnum $ T.head s
_ord v = error $ "ord: not a string: " ++ show v
_chr (IntV i) = return $ StrV $ T.singleton (toEnum (fromInteger i) :: Char)
_chr v = error $ "chr: not an integer: " ++ show v
_ref v = RefV <$> liftIO (newTVarIO v)
_readRef (RefV r) = liftIO $ atomically $ readTVar r
_setRef (TupleV [RefV r, v]) =
liftIO (atomically $ writeTVar r v) >> return v
_time (TupleV []) = fmap IntV $ liftIO $ round <$> getPOSIXTime
_sleep (IntV milliseconds) = liftIO (threadDelay (fromInteger $ 1000 * milliseconds)) >> return unitv
_loop args@(TupleV [fn@(FnV _ _), arg]) = do
v <- apply fn arg
if v /= BoolV False then
_loop $ TupleV [fn, v]
else return arg
_eval (TupleV [StrV code, DictV env]) = do
let trySome :: IO a -> IO (Either SomeException a)
trySome = try
state = [fromDict env]
ret <- liftIO . trySome $ evalStateT (evalString code) state
case ret of
Left err -> return $ TupleV [StrV (T.pack "err"), StrV $ T.pack (show err)]
Right v -> return v
_eval (TupleV [code@(StrV _), (ListV env)]) =
let env' = map (\(TupleV [k,v]) -> (k,v)) env in
_eval (TupleV [code, DictV $ M.fromList env'])
_eval _ = error "eval: invalid args (want code and environment)"
_thread f@FnV{} = do
state <- get
fmap Thread $ liftIO $ forkIO $ (evalStateT (apply f unitv) state >> return ())
_thread _ = error "thread!: need a function"
_kill (Thread thread) = liftIO (killThread thread) >> return unitv
_kill _ = error "kill!: need a thread"
-- returns a dictionary of a new environment with only the standard
-- default-imported functions
_newStdEnv (TupleV []) = do
let [stdEnv] = initialState
return $ toDict stdEnv
_globals (TupleV []) = do
env <- get
return $ toDict (last env)
_locals (TupleV []) = do
locals:_ <- get
return $ toDict locals
-- import a module name as a module
_Import (StrV modname) = do
env <- get -- save current state
put initialState
(path,modname) <- liftIO $ findModule $ T.unpack modname -- find the module file
evalFile path -- evaluate the module file
[modenv] <- get -- get the module env
let [initialEnv] = initialState
--let modenv' = M.difference modenv initialEnv -- subtract prelude stuff
let mod = toDict modenv
let env' = bind env (T.pack modname) mod -- bind it
put env' -- restore state
return mod -- return module value
where
findModule :: FilePath -> IO (FilePath, String)
findModule modname = do
execPath <- fmap takeDirectory getExecutablePath
findModuleIn [".", execPath </> "mods"] -- search paths for modules
where
findModuleIn [] = error $ "module " ++ modname ++ " couldn't be found"
findModuleIn (dir:xs) = do
let path = dir </> modname ++ ".lamb"
exists <- doesFileExist path
if exists then return (path, takeBaseName path)
else findModuleIn xs
bif = Builtin . BIF
initialState = [M.fromList $ map (\(k,v) -> (T.pack k, v)) $ [
("id", FnV emptyEnv [(VarP (T.pack "x"), Var (T.pack "x"))]),
("loop", bif _loop),
("ref!", bif _ref),
("readRef!", bif _readRef),
("setRef!", bif _setRef),
("time!", bif _time),
("sleep!", bif _sleep),
("repr", bif _repr),
("stdout", StreamV stdout),
("stdin", StreamV stdin),
("print", bif _print),
("putstr", bif _putstr),
("putstrln", bif (\x -> _putstr $ x +$ StrV (T.singleton '\n'))),
("getline", bif _getline),
("fgetline", bif _fgetline),
("putbytes", bif _putbytes),
("fputbytes", bif _fputstr),
("fputstr", bif _fputstr),
("freadbytes", bif _freadbytes),
("freadcontents", bif _freadcontents),
("feof", bif _feof),
("fclose", bif _fclose),
("fopen", bif _fopen),
("sockopen", bif _sockopen),
("itos", bif _itos),
("stoi", bif _stoi),
("ord", bif _ord),
("chr", bif _chr),
("globals", bif _globals),
("locals", bif _locals),
("newStdEnv", bif _newStdEnv),
("thread!", bif _thread),
("kill!", bif _kill),
("eval", bif _eval),
("import", bif _Import)]]
eval :: AST -> InterpState Value
eval (IntConst i) = return $ IntV i
eval (StrConst s) = return $ StrV s
eval (BoolConst b) = return $ BoolV b
eval (Block body) = foldr1 (>>) $ map eval body
eval (Cons a b) = do
a' <- eval a
b' <- eval b
case b' of
ListV v' -> return $ ListV $ a':v'
StrV v' ->
case a' of
StrV c | T.length c == 1 -> return $ StrV $ T.cons (T.head c) v'
_ -> error "cons: LHS must be a char"
_ -> error "cons: RHS must be a list or string"
eval (ListConst v) = ListV <$> mapM eval v
eval (TupleConst v) = TupleV <$> mapM eval v
eval (IfExpr c t e) = eval c >>= \cond ->
case cond of
BoolV True -> eval t
BoolV False -> eval e
_ -> error "if: condition must be a boolean"
eval (Var var) = get >>= \env ->
maybe (error $ "unbound variable " ++ T.unpack var) return (lookup env var)
eval (Defun name fn) = do
env <- get
case lookup env name of
Nothing -> -- bind new fn
eval fn >>= \fn' ->
put (bind env name fn') >> return fn'
Just oldfn -> -- add pattern to old fn
let FnV cls oldpats = oldfn
Lambda [(pat, body)] = fn
newfn = FnV cls (oldpats ++ [(pat, body)]) in
put (bind env name newfn) >> return newfn
eval (Def pat v') = do
v <- eval v'
locals:xs <- get
case patternBindings pat v of
Nothing -> error $ "pattern binding doesn't satisfy: " ++ show v ++ " with " ++ show pat
Just bindings -> do
put $ (M.union bindings locals):xs -- update our local bindings
return v
eval (Lambda pats) = do
env <- get
if length env == 1 then -- if in global env just use [], denoting the current global scope
return $ FnV [] pats
else return $ FnV env pats
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 }
eval (Equals l r) = do { l <- eval l; r <- eval r; return $ l ==$ r }
eval (NotEquals l r) = do { l <- eval l; r <- eval r; return $ l !=$ r }
eval (LessThan l r) = do { l <- eval l; r <- eval r; return $ l <$ r }
eval (GreaterThan l r) = do { l <- eval l; r <- eval r; return $ l >$ r }
eval (BitAnd l r) = do { l <- eval l; r <- eval r; return $ l &$ r }
eval (BitOr l r) = do { l <- eval l; r <- eval r; return $ l |$ r }
eval (BitShift l r dir) = do { l <- eval l; r <- eval r; return $ (if dir then (<<$) else (>>$)) l r }
eval (BitNot v) = do { v <- eval v; return $ bitNot v }
eval (Access left (Var right)) = do
lhs <- eval left
case lhs of
DictV dict ->
case M.lookup (StrV right) dict of
Just (FnV [] fn) -> -- use the module's global scope
return $ FnV (mapToEnv dict) fn
Just v -> return v
Nothing -> return $ TupleV [StrV (T.pack "nothing")]
_ -> error $ "op/: need a dict, got " ++ show lhs
where
mapToEnv :: M.Map Value Value -> Env
mapToEnv m = [fromDict m]
eval (Access _ _) = error "op/: RHS must be an identifier"
eval (Call lhs arg) = do
env <- get
v <- eval lhs
case v of
fn@(FnV cls _) -> do
arg' <- eval arg
let cls' = if cls == [] then [last env] else cls -- if [], use current global env
put cls' -- enter closure env
v <- apply fn arg'
put env -- restore env
return v
fn@(Builtin _) -> eval arg >>= apply fn
_ -> error $ "call: " ++ show v ++ " is not a function"
eval x = error $ "eval: unhandled: " ++ show x
patternBindings :: Pattern -> Value -> Maybe (M.Map T.Text Value)
patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
patternBindings (IntP n) (IntV v)
| v == n = Just M.empty
| otherwise = Nothing
patternBindings (IntP n) _ = Nothing
patternBindings (BoolP b) (BoolV v)
| v == b = Just M.empty
| otherwise = Nothing
patternBindings (StrP x) (StrV y)
| x == y = Just M.empty
| otherwise = Nothing
patternBindings (StrP _) _ = Nothing
-- cons on strings
-- x:[] matches with y:""
patternBindings (ConsP x (ListP [])) (StrV str) =
case T.uncons str of
Just (y, ys) | T.null ys -> -- str matches y:[]
patternBindings x (StrV $ T.singleton y)
_ -> Nothing
-- "xy":xs pattern
patternBindings (ConsP (StrP xp) xsp) (StrV str) =
let len = T.length xp in
if T.take len str == xp then -- matches
patternBindings xsp $ StrV (T.drop len str) -- match the rest of the string
else Nothing -- no match
patternBindings (ConsP xp xsp) (StrV str) =
case T.uncons str of
Just (x, xs) -> do
xe <- patternBindings xp (StrV $ T.singleton x)
xse <- patternBindings xsp $ StrV xs
Just $ M.union xe xse
_ -> Nothing
-- cons on lists
patternBindings (ConsP x (ListP [])) (ListV (y:[])) = patternBindings x y
patternBindings (ConsP xp xsp) (ListV (x:xs)) =
do
xe <- patternBindings xp x
xse <- patternBindings xsp $ ListV xs
Just $ M.union xe xse
patternBindings (ConsP _ _) _ = Nothing
-- lists
patternBindings (ListP []) (ListV (x:_)) = 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
patternBindings (ListP _) _ = Nothing -- not a list
-- 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
patternBindings p x = error $ "patternBindings failure: matching " ++ show x ++ " with pattern " ++ show p
-- applies a function
apply :: Value -> Value -> InterpState Value
apply (FnV _ pats) arg =
apply' pats
where
apply' [] = error $ "argument " ++ show arg ++ " doesn't satisfy any patterns"
apply' ((pat, body):xs) =
case patternBindings pat arg of
Just bindings -> -- satisfies
do
env <- get
let newenv = bindings:env
put newenv
eval body
Nothing -> -- doesn't satisfy this pattern
apply' xs
apply (Builtin (BIF fn)) arg = fn arg
-- some helper programs for evaluation
-- sets up stdin/stdout for binary mode and makes them unbuffered
initIO :: IO ()
initIO = do
hSetBinaryMode stdin True
hSetBinaryMode stdout True
hSetBuffering stdout NoBuffering
-- Takes an interpreter state and evaluates it with the empty initial state.
interpret :: InterpState a -> IO a
interpret state = evalStateT state initialState
evalProgram :: [AST] -> InterpState Value
evalProgram nodes = foldl1' (>>) $ map eval nodes
evalString :: T.Text -> InterpState Value
evalString program =
case parseProgram program of
Left err -> error $ show err
Right prg -> evalProgram prg
isLiterate :: FilePath -> Bool
isLiterate path = snd (splitExtension path) == ".lilamb"
-- Takes the lines of a literate program and returns the lines for a new executable program
-- from lines beginning with four spaces.
parseLiterate :: [T.Text] -> [T.Text]
parseLiterate lns = [T.drop 4 line | line <- lns, T.take 4 line == T.pack " "]
evalFile :: FilePath -> InterpState Value
evalFile path = do
contents <- liftIO $ if path == "-" then TIO.getContents else TIO.readFile path
if isLiterate path then
evalString . T.unlines . parseLiterate . T.lines $ contents
else evalString contents
evalFileV :: FilePath -> IO Value
evalFileV = interpret . evalFile