uplime/lamb
uplime
/
lamb
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

switch StrV to use Data.Text

This commit is contained in:
darkf 2014-11-01 05:14:38 -07:00
parent aab89f838b
commit df693a83f7
2 changed files with 46 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
Interp.hs
View File

@ -7,7 +7,10 @@ import Prelude hiding (lookup)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Char8 as BSC
import qualified Network.Socket as SO import qualified Network.Socket as SO
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.List (intercalate) import Data.List (intercalate)
import Control.Applicative ((<$>))
import Control.Exception (try, SomeException) import Control.Exception (try, SomeException)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put) import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put)
@ -27,7 +30,7 @@ instance Eq BIF where a == b = False
instance Ord BIF where compare a b = if a == b then EQ else LT instance Ord BIF where compare a b = if a == b then EQ else LT
data Value = IntV Integer data Value = IntV Integer
| StrV String | StrV T.Text
| BoolV Bool | BoolV Bool
| StreamV Handle | StreamV Handle
| TupleV [Value] | TupleV [Value]
@ -80,7 +83,7 @@ instance Show Value where
-- value operators -- value operators
(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 `T.append` r)
(ListV l) +$ (ListV r) = ListV (l ++ r) (ListV l) +$ (ListV r) = ListV (l ++ r)
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
@ -104,40 +107,41 @@ l !=$ r = BoolV (l /= r)
toDict :: M.Map String Value -> Value toDict :: M.Map String Value -> Value
toDict m = toDict m =
let wrapped = map (\(k,v) -> (StrV k, v)) $ M.toAscList m in let wrapped = map (\(k,v) -> (StrV (T.pack k), v)) $ M.toAscList m in
DictV $ M.fromAscList wrapped DictV $ M.fromAscList wrapped
fromDict :: M.Map Value Value -> M.Map String Value fromDict :: M.Map Value Value -> M.Map String Value
fromDict m = fromDict m =
let unwrapped = map (\(StrV k,v) -> (k, v)) $ M.toAscList m in let unwrapped = map (\(StrV k,v) -> (T.unpack k, v)) $ M.toAscList m in
M.fromAscList unwrapped M.fromAscList unwrapped
-- some built-in functions -- some built-in functions
_fputbytes (TupleV [StreamV handle, StrV str]) = do _fputbytes (TupleV [StreamV handle, StrV str]) = do
io <- liftIO $ hPutStr handle str io <- liftIO $ TIO.hPutStr handle str
return unitv return unitv
_fputstr (TupleV [StreamV handle, StrV str]) = do _fputstr (TupleV [StreamV handle, StrV str]) = do
io <- liftIO $ hPutStr handle str io <- liftIO $ TIO.hPutStr handle str
return unitv return unitv
_fgetline (StreamV handle) = do _fgetline (StreamV handle) = do
str <- liftIO $ hGetLine handle str <- liftIO $ TIO.hGetLine handle
if last str == '\r' then -- remove trailing CR if T.last str == '\r' then -- remove trailing CR
return . StrV $ init str return . StrV $ T.init str
else return $ StrV str else return $ StrV str
_freadbytes (TupleV [StreamV handle, IntV n]) = do _freadbytes (TupleV [StreamV handle, IntV n]) = do
str <- liftIO $ BSC.hGet handle (fromIntegral n :: Int) --str <- liftIO $ BSC.hGet handle (fromIntegral n :: Int)
return . StrV $ BSC.unpack str --return . StrV $ BSC.unpack str
liftIO $ StrV . T.take (fromIntegral n) <$> TIO.hGetContents handle
_fopen (TupleV [StrV path, StrV mode]) = do _fopen (TupleV [StrV path, StrV mode]) = do
let mode' = case mode of let mode' = case T.unpack mode of
"r" -> ReadMode "r" -> ReadMode
"w" -> WriteMode "w" -> WriteMode
"rw" -> ReadWriteMode "rw" -> ReadWriteMode
handle <- liftIO $ openBinaryFile path mode' handle <- liftIO $ openBinaryFile (T.unpack path) mode'
return $ StreamV handle return $ StreamV handle
_feof (StreamV handle) = do _feof (StreamV handle) = do
@ -150,7 +154,7 @@ _fclose (StreamV handle) = do
_sockopen (TupleV [StrV host, IntV port]) = do _sockopen (TupleV [StrV host, IntV port]) = do
liftIO $ SO.withSocketsDo $ do liftIO $ SO.withSocketsDo $ do
addr:_ <- SO.getAddrInfo Nothing (Just host) (Just $ show port) addr:_ <- SO.getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port)
sock <- SO.socket (SO.addrFamily addr) SO.Stream SO.defaultProtocol sock <- SO.socket (SO.addrFamily addr) SO.Stream SO.defaultProtocol
SO.connect sock (SO.addrAddress addr) SO.connect sock (SO.addrAddress addr)
handle <- SO.socketToHandle sock ReadWriteMode handle <- SO.socketToHandle sock ReadWriteMode
@ -161,10 +165,10 @@ _putstr str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
_putbytes str@(StrV _) = _fputbytes $ TupleV [StreamV stdout, str] _putbytes str@(StrV _) = _fputbytes $ TupleV [StreamV stdout, str]
_getline (TupleV []) = _fgetline (StreamV stdin) _getline (TupleV []) = _fgetline (StreamV stdin)
_print v = _putbytes $ StrV $ show v ++ "\n" _print v = _putbytes $ StrV $ T.pack (show v) `T.snoc` '\n'
_repr v = return . StrV $ show v _repr v = return . StrV $ T.pack $ show v
_itos (IntV i) = return $ StrV $ show i _itos (IntV i) = return $ StrV $ T.pack $ show i
_itos v = error $ "itos: not an int: " ++ show v _itos v = error $ "itos: not an int: " ++ show v
_ref v = do _ref v = do
@ -189,9 +193,9 @@ _eval (TupleV [StrV code, DictV env]) = do
let trySome :: IO a -> IO (Either SomeException a) let trySome :: IO a -> IO (Either SomeException a)
trySome = try trySome = try
state = [fromDict env] state = [fromDict env]
ret <- liftIO. trySome $ evalStateT (evalString code) state ret <- liftIO . trySome $ evalStateT (evalString $ T.unpack code) state
case ret of case ret of
Left err -> return $ TupleV [StrV "err", StrV (show err)] Left err -> return $ TupleV [StrV (T.pack "err"), StrV $ T.pack (show err)]
Right v -> return v Right v -> return v
_eval (TupleV [code@(StrV _), (ListV env)]) = _eval (TupleV [code@(StrV _), (ListV env)]) =
let env' = map (\(TupleV [k,v]) -> (k,v)) env in let env' = map (\(TupleV [k,v]) -> (k,v)) env in
@ -216,7 +220,7 @@ _locals (TupleV []) = do
_Import (StrV modname) = do _Import (StrV modname) = do
env <- get -- save current state env <- get -- save current state
put initialState put initialState
(path,modname) <- liftIO $ findModule modname -- find the module file (path,modname) <- liftIO $ findModule $ T.unpack modname -- find the module file
evalFile path -- evaluate the module file evalFile path -- evaluate the module file
[modenv] <- get -- get the module env [modenv] <- get -- get the module env
let [initialEnv] = initialState let [initialEnv] = initialState
@ -251,7 +255,7 @@ initialState = [M.fromList [
("stdin", StreamV stdin), ("stdin", StreamV stdin),
("print", bif _print), ("print", bif _print),
("putstr", bif _putstr), ("putstr", bif _putstr),
("putstrln", bif (\x -> _putstr $ x +$ StrV "\n")), ("putstrln", bif (\x -> _putstr $ x +$ StrV (T.singleton '\n'))),
("getline", bif _getline), ("getline", bif _getline),
("fgetline", bif _fgetline), ("fgetline", bif _fgetline),
("putbytes", bif _putbytes), ("putbytes", bif _putbytes),
@ -272,7 +276,7 @@ initialState = [M.fromList [
eval :: AST -> InterpState Value eval :: AST -> InterpState Value
eval (IntConst i) = return $ IntV i eval (IntConst i) = return $ IntV i
eval (StrConst s) = return $ StrV s eval (StrConst s) = return $ StrV $ T.pack s
eval (BoolConst b) = return $ BoolV b eval (BoolConst b) = return $ BoolV b
eval (Block body) = foldr1 (>>) $ map eval body eval (Block body) = foldr1 (>>) $ map eval body
@ -337,15 +341,15 @@ eval (Access left (Var right)) = do
lhs <- eval left lhs <- eval left
case lhs of case lhs of
DictV dict -> DictV dict ->
case M.lookup (StrV right) dict of case M.lookup (StrV $ T.pack right) dict of
Just (FnV [] fn) -> -- use the module's global scope Just (FnV [] fn) -> -- use the module's global scope
return $ FnV (mapToEnv dict) fn return $ FnV (mapToEnv dict) fn
Just v -> return v Just v -> return v
Nothing -> return $ TupleV [StrV "nothing"] Nothing -> return $ TupleV [StrV (T.pack "nothing")]
_ -> error $ "op/: need a dict, got " ++ show lhs _ -> error $ "op/: need a dict, got " ++ show lhs
where where
mapToEnv :: M.Map Value Value -> Env mapToEnv :: M.Map Value Value -> Env
mapToEnv m = [M.fromAscList $ map (\(StrV k,v) -> (k,v)) (M.toAscList m)] mapToEnv m = [M.fromAscList $ map (\(StrV k,v) -> (T.unpack k,v)) (M.toAscList m)]
eval (Access _ _) = error "op/: RHS must be an identifier" eval (Access _ _) = error "op/: RHS must be an identifier"
eval (Call lhs arg) = do eval (Call lhs arg) = do
@ -377,23 +381,30 @@ patternBindings (BoolP b) (BoolV v)
| otherwise = Nothing | otherwise = Nothing
patternBindings (StrP x) (StrV y) patternBindings (StrP x) (StrV y)
| x == y = Just M.empty | T.pack x == y = Just M.empty
| otherwise = Nothing | otherwise = Nothing
patternBindings (StrP _) _ = Nothing patternBindings (StrP _) _ = Nothing
-- cons on strings -- cons on strings
patternBindings (ConsP x (ListP [])) (StrV (y:[])) = patternBindings x (StrV [y]) -- 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 -- "xy":xs pattern
patternBindings (ConsP (StrP xp) xsp) (StrV str) = patternBindings (ConsP (StrP xp) xsp) (StrV str) =
let len = length xp in let len = length xp in
if take len str == xp then -- matches if T.take len str == T.pack xp then -- matches
patternBindings xsp $ StrV (drop len str) -- match the rest of the string patternBindings xsp $ StrV (T.drop len str) -- match the rest of the string
else Nothing -- no match else Nothing -- no match
patternBindings (ConsP xp xsp) (StrV (x:xs)) = patternBindings (ConsP xp xsp) (StrV str) =
do case T.uncons str of
xe <- patternBindings xp (StrV [x]) Just (x, xs) -> do
xse <- patternBindings xsp $ StrV xs xe <- patternBindings xp (StrV $ T.singleton x)
Just $ M.union xe xse xse <- patternBindings xsp $ StrV xs
Just $ M.union xe xse
_ -> Nothing
-- cons on lists -- cons on lists
patternBindings (ConsP x (ListP [])) (ListV (y:[])) = patternBindings x y patternBindings (ConsP x (ListP [])) (ListV (y:[])) = patternBindings x y

2
lamb.cabal
View File

@ -7,6 +7,6 @@ cabal-version: >= 1.8
executable main executable main
main-is: Lamb.hs main-is: Lamb.hs
build-depends: base, peggy, containers, transformers, directory, filepath, bytestring, network build-depends: base, peggy, containers, transformers, directory, filepath, bytestring, network, text
hs-source-dirs: . hs-source-dirs: .
extensions: DoAndIfThenElse extensions: DoAndIfThenElse