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

Compare commits

base: uplime:master
Branches Tags
uplime:master
uplime:str-text
uplime:unic
uplime:modules3
..
compare: uplime:unic
Branches Tags
uplime:master
uplime:str-text
uplime:unic
uplime:modules3

No commits in common. "master" and "unic" have entirely different histories.
master ... unic

15 changed files with 196 additions and 707 deletions
Show Stats Expand all files Collapse all files

21
AST.hs
View File

@ -3,7 +3,6 @@
-- Licensed under the terms of the zlib license, see LICENSE for details
module AST where
import qualified Data.Text as T
data AST = Add AST AST
| Sub AST AST
@ -13,32 +12,30 @@ data AST = Add AST AST
| NotEquals AST AST
| LessThan AST AST
| GreaterThan AST AST
| BitAnd AST AST
| BitOr AST AST
| BitNot AST
| BitShift AST AST Bool
| Block [AST]
| FunDef T.Text (Pattern, AST)
| Defun T.Text AST
| FunDef String (Pattern, AST)
| Defun String AST
| Def Pattern AST
| Var T.Text
| Var String
| Lambda [(Pattern, AST)]
| Call AST AST
| Access AST AST
| UnitConst
| Cons AST AST
| IfExpr AST AST AST
| TupleConst [AST]
| ListConst [AST]
| BoolConst Bool
| StrConst T.Text
| StrConst String
| IntConst Integer
deriving (Show, Eq)
data Pattern = VarP T.Text
data Pattern = VarP String
| IntP Integer
| StrP T.Text
| StrP String
| BoolP Bool
| UnitP
| ConsP Pattern Pattern
| TupleP [Pattern]
| ListP [Pattern]
deriving (Show, Eq)
deriving (Show, Eq)

414
Interp.hs
View File

@ -3,27 +3,16 @@
-- 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 Prelude hiding (lookup)
import qualified Data.Map 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 Data.List (intercalate)
import Control.Monad.Trans (lift)
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.IO (Handle, hPutStr, hGetLine, hFlush, hClose, hIsEOF, openBinaryFile, hSetBinaryMode, IOMode(..), stdout, stdin)
import System.Directory (doesFileExist)
import System.FilePath (FilePath, splitExtension, takeBaseName, takeDirectory, (</>))
import System.Environment (getExecutablePath)
import System.FilePath (FilePath, splitExtension, takeBaseName)
import AST
import Parser (parseProgram)
@ -34,14 +23,13 @@ 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
| StrV String
| UnitV
| BoolV Bool
| StreamV Handle
| StreamV Int
| 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)
@ -52,47 +40,44 @@ instance Ord Value where
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 (StreamV a) (StreamV b) = compare a b
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
type Env = [M.Map String Value] -- lexical environment (linked list)
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
emptyEnv = [M.empty]
unitv = TupleV []
-- look up a binding from the bottom up
lookup :: Env -> T.Text -> Maybe Value
lookup :: Env -> String -> Maybe Value
lookup [] _ = Nothing
lookup (env:xs) name = maybe (lookup xs name) Just (M.lookup name env)
lookup (env:xs) name =
case M.lookup name env of
Nothing -> lookup xs name
Just x -> Just x
-- bind in the local environment
bind :: Env -> T.Text -> Value -> Env
bind :: Env -> String -> 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 ++ ">"
show UnitV = "()"
-- value operators
(IntV l) +$ (IntV r) = IntV (l + r)
(StrV l) +$ (StrV r) = StrV (l `T.append` r)
(StrV l) +$ (StrV r) = StrV (l ++ r)
(ListV l) +$ (ListV r) = ListV (l ++ r)
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
@ -111,206 +96,132 @@ 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
_fputbytes (TupleV [StreamV h, StrV str]) = do
(handles,_) <- get
let handle = handles !! h
io <- lift $ hPutStr handle str >> hFlush handle
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
_fputstr (TupleV [StreamV h, StrV str]) = do
(handles,_) <- get
let handle = handles !! h
io <- lift $ hPutStr handle str >> hFlush handle
return UnitV
_fgetline (StreamV h) = do
(handles,_) <- get
let handle = handles !! h
str <- lift $ hGetLine handle
if last str == '\r' then -- remove trailing CR
return . StrV $ 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
_freadbytes (TupleV [StreamV h, IntV n]) = do
(handles,_) <- get
let handle = handles !! h
str <- lift $ BSC.hGet handle (fromIntegral n :: Int)
return . StrV $ BSC.unpack str
_fopen (TupleV [StrV path, StrV mode]) = do
let mode' = case T.unpack mode of
(handles,env) <- get
let mode' = case mode of
"r" -> ReadMode
"w" -> WriteMode
"rw" -> ReadWriteMode
StreamV <$> liftIO (openBinaryFile (T.unpack path) mode')
handle <- lift $ openBinaryFile path mode'
put (handles ++ [handle], env)
return . StreamV $ length handles
_feof (StreamV handle) = do
BoolV <$> liftIO (hIsEOF handle)
_feof (StreamV h) = do
(handles,_) <- get
let handle = handles !! h
isEof <- lift $ hIsEOF handle
return $ BoolV isEof
_fclose (StreamV handle) = do
liftIO (hClose handle) >> return unitv
_fclose handle@(StreamV h) = do
(handles,_) <- get
let handle = handles !! h
lift $ 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)
(handles,env) <- get
handle <- lift $ SO.withSocketsDo $ do
addr:_ <- SO.getAddrInfo Nothing (Just 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
return handle
put (handles ++ [handle], env)
return . StreamV $ length handles
_putstr str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
_putbytes str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
_getline (TupleV []) = _fgetline (StreamV stdin)
_putstr str@(StrV _) = _fputstr $ TupleV [StreamV 0, str]
_putbytes str@(StrV _) = _fputbytes $ TupleV [StreamV 0, str]
_getline UnitV = _fgetline (StreamV 1)
_print v = _putbytes $ StrV $ T.pack (show v) `T.snoc` '\n'
_repr v = return . StrV $ T.pack $ show v
_print v = _putbytes $ StrV $ show v ++ "\n"
_repr v = return . StrV $ show v
_itos (IntV i) = return $ StrV $ T.pack $ show i
_itos (IntV i) = return $ StrV $ 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
(h,env) <- get -- save current state
put initialState
(path,modname) <- liftIO $ findModule $ T.unpack modname -- find the module file
(path,modname) <- lift $ findModule 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
(_,[modenv]) <- get -- get the module env
let (_, [initialEnv]) = initialState
let modenv' = M.difference modenv initialEnv -- subtract prelude stuff
-- convert String to StrV in env keys
let modenv'' = map (\(k,v) -> (StrV k, v)) $ M.toAscList modenv'
let mod = DictV (M.fromAscList modenv'') -- package module into a dict
let env' = bind env modname mod -- bind it
put (h,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
let path = modname ++ ".lamb"
exists <- doesFileExist path
if exists then
return (path, takeBaseName path)
else error $ "module " ++ modname ++ " couldn't be found"
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)]]
initialState = ([stdout, stdin],
[M.fromList [("id", FnV emptyEnv [(VarP "x", Var "x")]),
("loop", Builtin $ BIF _loop),
("repr", Builtin $ BIF _repr),
("stdout", StreamV 0),
("stdin", StreamV 1),
("print", Builtin $ BIF _print),
("putstr", Builtin $ BIF _putstr),
("putstrln", Builtin $ BIF (\x -> _putstr $ x +$ StrV "\n")),
("getline", Builtin $ BIF _getline),
("fgetline", Builtin $ BIF _fgetline),
("putbytes", Builtin $ BIF _putbytes),
("fputbytes", Builtin $ BIF _fputbytes),
("fputstr", Builtin $ BIF _fputstr),
("freadbytes", Builtin $ BIF _freadbytes),
("feof", Builtin $ BIF _feof),
("fclose", Builtin $ BIF _fclose),
("fopen", Builtin $ BIF _fopen),
("sockopen", Builtin $ BIF _sockopen),
("itos", Builtin $ BIF _itos),
("import", Builtin $ BIF _Import)]])
eval :: AST -> InterpState Value
@ -318,6 +229,8 @@ eval (IntConst i) = return $ IntV i
eval (StrConst s) = return $ StrV s
eval (BoolConst b) = return $ BoolV b
eval UnitConst = return UnitV
eval (Block body) = foldr1 (>>) $ map eval body
eval (Cons a b) = do
@ -325,14 +238,13 @@ eval (Cons a b) = do
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"
_ -> error "cons: RHS must be a list"
eval (ListConst v) = ListV <$> mapM eval v
eval (TupleConst v) = TupleV <$> mapM eval v
eval (ListConst v) =
mapM eval v >>= \xs ->
return $ ListV xs
eval (TupleConst v) = mapM eval v >>= return . TupleV
eval (IfExpr c t e) = eval c >>= \cond ->
case cond of
@ -340,35 +252,37 @@ eval (IfExpr c t e) = eval c >>= \cond ->
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 (Var var) = get >>= \(_,env) ->
case lookup env var of
Just v -> return v
Nothing -> error $ "unbound variable " ++ var
eval (Defun name fn) = do
env <- get
(s,env) <- get
case lookup env name of
Nothing -> -- bind new fn
eval fn >>= \fn' ->
put (bind env name fn') >> return fn'
put (s, 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
put (s, bind env name newfn) >> return newfn
eval (Def pat v') = do
v <- eval v'
locals:xs <- get
(s,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
Just bindings ->
put (s, (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 (Lambda pats) =
get >>= \(_,env) ->
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 }
@ -380,11 +294,6 @@ 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
@ -393,30 +302,30 @@ eval (Access left (Var right)) = do
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")]
Nothing -> return $ TupleV [StrV "nothing"]
_ -> error $ "op/: need a dict, got " ++ show lhs
where
mapToEnv :: M.Map Value Value -> Env
mapToEnv m = [fromDict m]
mapToEnv m = [M.fromAscList $ map (\(StrV k,v) -> (k,v)) (M.toAscList m)]
eval (Access _ _) = error "op/: RHS must be an identifier"
eval (Call lhs arg) = do
env <- get
(h,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
put (h,cls') -- enter closure env
v <- apply fn arg'
put env -- restore env
put (h,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 :: Pattern -> Value -> Maybe (M.Map String Value)
patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
patternBindings (IntP n) (IntV v)
@ -428,31 +337,27 @@ patternBindings (BoolP b) (BoolV v)
| v == b = Just M.empty
| otherwise = Nothing
patternBindings UnitP UnitV = Just M.empty
patternBindings UnitP _ = 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
patternBindings (ConsP x (ListP [])) (StrV (y:[])) = patternBindings x (StrV [y])
-- "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
let len = length xp in
if take len str == xp then -- matches
patternBindings xsp $ StrV (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
patternBindings (ConsP xp xsp) (StrV (x:xs)) =
do
xe <- patternBindings xp (StrV [x])
xse <- patternBindings xsp $ StrV xs
Just $ M.union xe xse
-- cons on lists
patternBindings (ConsP x (ListP [])) (ListV (y:[])) = patternBindings x y
@ -485,8 +390,6 @@ patternBindings (TupleP (x:xs)) (TupleV (y: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 =
@ -497,9 +400,9 @@ apply (FnV _ pats) arg =
case patternBindings pat arg of
Just bindings -> -- satisfies
do
env <- get
(s,env) <- get
let newenv = bindings:env
put newenv
put (s, newenv)
eval body
Nothing -> -- doesn't satisfy this pattern
apply' xs
@ -508,21 +411,16 @@ apply (Builtin (BIF fn)) arg = fn arg
-- some helper programs for evaluation
-- sets up stdin/stdout for binary mode and makes them unbuffered
-- sets up stdin/stdout for binary mode
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
evalProgram nodes = foldr1 (>>) $ map eval nodes
evalString :: T.Text -> InterpState Value
evalString :: String -> InterpState Value
evalString program =
case parseProgram program of
Left err -> error $ show err
@ -533,15 +431,15 @@ 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 " "]
parseLiterate :: [String] -> [String]
parseLiterate lns = [drop 4 line | line <- lns, take 4 line == " "]
evalFile :: FilePath -> InterpState Value
evalFile path = do
contents <- liftIO $ if path == "-" then TIO.getContents else TIO.readFile path
contents <- lift $ if path == "-" then getContents else readFile path
if isLiterate path then
evalString . T.unlines . parseLiterate . T.lines $ contents
evalString . unlines . parseLiterate . lines $ contents
else evalString contents
evalFileV :: FilePath -> IO Value
evalFileV = interpret . evalFile
evalFileV path = evalStateT (evalFile path) initialState

17
LICENSE
View File

@ -1,17 +0,0 @@
Copyright (c) 2013 darkf
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.

54
Lamb.hs
View File

@ -5,46 +5,22 @@
import System.Environment (getArgs)
import System.Directory (doesFileExist)
import System.FilePath (FilePath, splitExtension)
import Control.Applicative ((<$>))
import Control.Monad (filterM)
import Control.Monad.IO.Class (liftIO)
import Parser (parseProgram)
import Interp (evalFileV, evalProgram, initIO, interpret, InterpState, Value)
import Interp (evalFileV, initIO, Value(UnitV))
exists :: FilePath -> IO Bool
exists "-" = return True
exists path = not <$> doesFileExist path
findMissing :: [FilePath] -> IO [FilePath]
findMissing = filterM exists
repl :: InterpState Value
repl = do
liftIO $ putStr ">> "
line <- liftIO getLine
case parseProgram line of
Left err -> do
liftIO $ putStrLn $ "parse error: " ++ show err
Right prg -> do
ev <- evalProgram prg
liftIO $ print ev
repl
repl' :: IO ()
repl' = interpret repl >> return ()
-- returns Nothing if all files exist, or Just path for the first one that doesn't
allExist :: [FilePath] -> IO (Maybe FilePath)
allExist [] = return Nothing
allExist ("-":xs) = allExist xs
allExist (x:xs) = do
exists <- doesFileExist x
if exists then allExist xs
else return $ Just x
main = do
args <- getArgs
if null args
then do -- no arguments, launch REPL
initIO
repl'
else do
missing <- findMissing args
if null missing
then do
initIO
mapM_ evalFileV args
else do
let reportMissing file = putStrLn $ "error: file " ++ file ++ " doesn't exist"
mapM_ reportMissing missing
exist <- allExist args
case exist of
Just file -> putStrLn $ "error: file " ++ file ++ " doesn't exist"
Nothing ->
initIO >>
mapM_ evalFileV args

39
Parser.hs
View File

@ -1,9 +1,7 @@
{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}
module Parser where
import Data.Maybe (fromMaybe)
import Text.Peggy hiding (space)
import qualified Data.Text as T
import AST
[peggy|
@ -23,7 +21,9 @@ semistatements :: [AST]
args :: AST
= expr ("," expr)+ { TupleConst ($1 : $2) }
/ expr? { fromMaybe (TupleConst []) $1 }
/ expr? { case $1 of
Just x -> x
Nothing -> UnitConst }
patternlist :: Pattern
= pattern ("," pattern)+ { ListP ($1 : $2) }
@ -42,12 +42,14 @@ pattern :: Pattern
/ patterntuple
/ "true" { BoolP True } / "false" { BoolP False }
/ identifier { VarP $1 }
/ stringlit { StrP (T.pack $1) }
/ stringlit { StrP $1 }
/ integer { IntP $1 }
funpattern :: Pattern
= pattern ("," pattern)+ { TupleP ($1 : $2) }
/ pattern? { fromMaybe (TupleP []) $1 }
/ pattern? { case $1 of
Just x -> x
Nothing -> UnitP }
listseq :: AST
= expr ("," expr)+ { ListConst ($1 : $2) }
@ -76,41 +78,29 @@ expr :: AST
= expr "::" expr { Cons $1 $2 }
/ expr "+" fact { Add $1 $2 }
/ expr "-" fact { Sub $1 $2 }
/ expr "&" fact { BitAnd $1 $2 }
/ expr "|" fact { BitOr $1 $2 }
/ expr "<<" fact { BitShift $1 $2 True }
/ expr ">>" fact { BitShift $1 $2 False }
/ expr "==" fact { Equals $1 $2 }
/ expr "!=" fact { NotEquals $1 $2 }
/ expr "<" fact { LessThan $1 $2 }
/ expr ">" fact { GreaterThan $1 $2 }
/ "~" expr { BitNot $1 }
/ def
/ lambda
/ identifier "(" funpattern ")" "->" expr { Defun $1 (Lambda [($2, $3)]) }
/ fact
fact :: AST
= fact "*" call { Mul $1 $2 }
/ fact "/" call { Div $1 $2 }
/ call
call :: AST
= call "(" args ")" { Call $1 $2 }
/ access
access :: AST
= access "\\" identifier { Access $1 (Var $2) }
= fact "*" term { Mul $1 $2 }
/ fact "/" term { Div $1 $2 }
/ term
term :: AST
= tuple
= term "(" args ")" { Call $1 $2 }
/ tuple
/ "(" expr ")"
/ "[" listseq "]"
/ ifcond
/ doblock
/ "true" { BoolConst True } / "false" { BoolConst False }
/ stringlit { StrConst (T.pack $1) }
/ stringlit { StrConst $1 }
/ integer { IntConst $1 }
/ identifier { Var $1 }
@ -129,10 +119,9 @@ escChar :: Char
/ 'n' { '\n' }
/ 'r' { '\r' }
/ 't' { '\t' }
/ '0' { '\0' }
identifier ::: T.Text
= [a-zA-Z_] [a-zA-Z0-9_'?!]* { T.pack ($1 : $2) }
identifier ::: String
= [a-zA-Z_] [a-zA-Z0-9_'?!]* { $1 : $2 }
integer ::: Integer
= [0-9] [0-9]* { read ($1 : $2) }

4
examples/association_list.lamb
View File

@ -2,7 +2,7 @@
map_insert(assoc, pair) -> pair :: assoc.
-- lookup by key
map_lookup([], _) -> ("nothing",).
map_lookup([], _) -> ("nothing").
map_lookup((k,v)::xs, key) ->
if k == key then ("just", v)
else map_lookup(xs, key).
@ -21,5 +21,5 @@ m = map_insert(m, ("ready", "go")).
print(m).
print(map_remove(m, "k")).
("just", x) = map_lookup(m, "hi").
("nothing",) = map_lookup(m, "foo").
("nothing") = map_lookup(m, "foo").
print(x).

16
examples/ref.lamb
View File

@ -1,16 +0,0 @@
-- Refs are global mutable (changing) values.
-- They let you break referential transparency (purity) to make some things easier.
x = ref!(1337). -- Construct a new ref, set to the value 1337
print(x). -- Should print <ref>
print(readRef!(x)). -- Should print 1337
setRef!(x, 42). -- Set it to 42
print(readRef!(x)).
-- Apply a function on the current value in the reference and set it to the new value.
modifyRef!(ref, f) ->
setRef!(ref, f(readRef!(ref))).
modifyRef!(x, \v -> v*2). -- Double x
print(readRef!(x)). -- 84

13
lamb.cabal
View File

@ -1,13 +0,0 @@
name: lamb
version: 0.0.1
synopsis: The Lamb programming language
author: darkf
build-type: Simple
cabal-version: >= 1.8
executable lamb
main-is: Lamb.hs
build-depends: base, peggy, containers, transformers, directory, filepath, bytestring, network, text, time, stm
hs-source-dirs: .
extensions: DoAndIfThenElse
other-modules: AST, Interp, Parser

28
mods/std/base64.lamb
View File

@ -1,28 +0,0 @@
import("std/list").
import("std/str").
charset = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/".
_b64(n) ->
list\map(\shift -> list\at(charset, (n >> shift) & 63),
[18, 12, 6, 0]).
f([]) -> [].
f(a :: b :: c :: xs) -> do
v = (a << 16) | (b << 8) | c;
_b64(v) + f(xs)
end.
f(a :: b :: []) -> do
v = (a << 16) | (b << 8);
list\take(3, _b64(v)) + ["="]
end.
f(a :: []) -> do
v = a << 16;
list\take(2, _b64(v)) + ["=="]
end.
base64_encode(s) -> do
bytes = list\map(ord, s);
str\concat(f(bytes))
end.

6
mods/std/basic.lamb
View File

@ -1,6 +0,0 @@
-- Standard basic library for the Lamb programming language
-- Copyright (c) 2013 darkf
-- Licensed under the terms of the zlib license, see LICENSE for details
const(x) -> \_ -> x.
compose(f, g) -> \x -> f(g(x)).

146
mods/std/http.lamb
View File

@ -1,146 +0,0 @@
import("std/list").
fst((x, _)) -> x.
-- maybe stuff
is_just(("just", _)) -> true.
is_just(_) -> false.
is_nothing(("nothing",)) -> true.
is_nothing(_) -> false.
unwrap_maybe(("just", x)) -> x.
-- association list
-- insert a pair into a map
map_insert(assoc, key, value) -> (key, value) :: assoc.
-- lookup by key
map_lookup([], _) -> ("nothing",).
map_lookup((k,v)::xs, key) ->
if k == key then ("just", v)
else map_lookup(xs, key).
-- remove a key from a map
map_remove([], key) -> [].
map_remove((k,v)::xs, key) ->
if k == key then xs
else (k,v) :: map_remove(xs, key).
spanS(_, "") -> ("", "").
spanS(p, x::xs) ->
if p(x) then do
(ys, zs) = spanS(p, xs);
(x::ys, zs)
end
else
("", (x::xs)).
parse_uri("http://" :: rest) -> do
(host, request_) = spanS(\x -> x != "/", rest);
(hostname, port_) = spanS(\x -> x != ":", host);
request = if request_ == "" then "/" else request_;
port = if port_ == "" then 80 else do ":"::p = port_; stoi(p) end;
(hostname, port, request)
end.
parse_uri(uri) -> ("err", "invalid schema (URI: " + repr(uri) + ")").
-- print(parse_uri("http://localhost")).
-- print(parse_uri("http://localhost/foo/bar.html")).
-- print(parse_uri("http://localhost:123")).
-- print(parse_uri("http://localhost:123/foo/bar.html")).
-- print(spanS((\x -> x != "/"), "foobar/")).
-- TODO: fix recursive functions inside functions
get_response_body("\r\n\r\n"::body) -> body.
get_response_body(x::xs) -> get_response_body(xs).
concatS([]) -> "".
concatS(x::xs) -> x + concatS(xs).
concatMapS(f, xs) -> concatS(list\map(f, xs)).
initS(_::"") -> "".
initS(c::cs) -> c :: initS(cs).
lengthS("") -> 0.
lengthS(_::cs) -> 1 + lengthS(cs).
-- NOT complete by any means
urlencode("") -> "".
urlencode("&"::xs) -> "%26" + urlencode(xs).
urlencode(" "::xs) -> "+" :: urlencode(xs).
urlencode("\r"::xs) -> "%0D" + urlencode(xs).
urlencode("\n"::xs) -> "%0A" + urlencode(xs).
urlencode(c::xs) -> c :: urlencode(xs).
http_get(uri) -> do
f((hostname, port, request)) -> do
putstrln("hostname: " + repr(hostname) + " port: " + repr(port) + " request: " + repr(request));
sock = sockopen(hostname, port);
fputstr(sock, "GET " + request + " HTTP/1.0\r\n");
fputstr(sock, "Host: " + hostname + "\r\n");
fputstr(sock, "User-Agent: Mozilla/5.0 (Windows NT 6.2; WOW64) lamb\r\n");
fputstr(sock, "\r\n");
response = freadcontents(sock);
(code, _) = spanS(\x -> x != "\n", response);
putstrln("code: " + code);
resp = get_response_body(response);
("ok", resp)
end;
f(err) -> err;
f(parse_uri(uri))
end.
http_post(uri, data) -> do
f((hostname, port, request)) -> do
putstrln("hostname: " + repr(hostname) + " port: " + repr(port) + " request: " + repr(request));
--fputstr = (\_, s -> putstrln("SEND: " + s));
body_ = concatMapS(\(k,v) -> k + "=" + urlencode(v) + "&", data);
body = initS(body_);
sock = sockopen(hostname, port);
fputstr(sock, "POST " + request + " HTTP/1.0\r\n");
fputstr(sock, "Host: " + hostname + "\r\n");
fputstr(sock, "User-Agent: Mozilla/5.0 (Windows NT 6.2; WOW64) lamb\r\n");
fputstr(sock, "Content-Type: application/x-www-form-urlencoded\r\n");
fputstr(sock, "Content-Length: " + repr(lengthS(body)) + "\r\n");
fputstr(sock, "\r\n");
fputstr(sock, body);
response = freadcontents(sock);
(code, _) = spanS(\x -> x != "\n", response);
putstrln("code: " + code);
resp = get_response_body(response);
("ok", resp)
end;
f(err) -> err;
f(parse_uri(uri))
end.
-- print(http_get("http://127.0.0.1:123/foo/bar.html")).
-- print(http_get("nope://localhost:123/foo/bar.html")).
-- print(http_get("http://thefuckingweather.com/?where=12345")).
-- print(concatS(["foo", "bar"])).
-- print(http_post("http://127.0.0.1:123/foo/bar.html", [("foo", "bar")])).
-- print(http_post("http://ix.io", [("f:1", "hi from lamb! :D & goodbye!")])).
async_http_get(url, k) -> thread!(\_ -> k(http_get(url))).

77
mods/std/list.lamb
View File

@ -1,77 +0,0 @@
-- Standard List library for the Lamb programming language
-- Copyright (c) 2013 darkf
-- Licensed under the terms of the zlib license, see LICENSE for details
-- list membership test
memberOf?([], _) -> false.
memberOf?(x::xs, member) ->
if x == member then true
else memberOf?(xs, member).
-- map function: map(\x -> x*2, [1, 2, 3]) == [2, 4, 6]
map(f, []) -> [].
map(f, "") -> [].
map(f, x::xs) -> f(x) :: map(f, xs).
-- list folds
foldl(f, v, "") -> v.
foldl(f, v, []) -> v.
foldl(f, v, x::xs) -> do
foldl(f, f(v, x), xs)
end.
foldr(f, v, "") -> v.
foldr(f, v, []) -> v.
foldr(f, v, x::xs) -> do
f(x, foldr(f, v, xs))
end.
sum(lst) -> foldl(\x,y -> x + y, 0, lst).
product(lst) -> foldl(\x,y -> x * y, 1, lst).
reverse(lst) -> foldl(\x,xs -> x :: xs, [], lst).
length(lst) -> foldl(\y,_ -> 1 + y, 0, lst).
filter(f, []) -> [].
filter(f, x::xs) ->
if f(x) then x :: filter(f, xs)
else filter(f, xs).
-- index function
-- out of values (hey, this isn't the Circus of Values!)
at([], _) -> 0 - 1. -- (-1)
at("", _) -> 0 - 1. -- (-1)
-- we've hit our target item
at(x::_, 0) -> x.
-- we've got more to go, keep iterating
at(x::xs, i) -> at(xs, i-1).
-- find (linear search)
find'([], _, _) -> 0 - 1. -- (-1)
find'(x::xs, item, i) ->
if x == item then i
else find'(xs, item, i+1).
find(lst, item) -> find'(lst, item, 0).
takeWhile(f, []) -> [].
takeWhile(f, x::xs) -> do
if f(x) == true then x :: takeWhile(f, xs)
else []
end.
dropWhile(f, []) -> [].
dropWhile(f, x::xs) -> do
if f(x) == true then dropWhile(f, xs)
else x :: xs
end.
drop(0, x) -> x.
drop(n, []) -> [].
drop(n, _::xs) -> drop(n-1, xs).
take(0, _) -> [].
take(n, []) -> [].
take(n, x::xs) -> x :: take(n-1, xs).
intercalate(s, []) -> "".
intercalate(s, x::[]) -> x.
intercalate(s, x::xs) -> x + s + intercalate(s, xs).

9
mods/std/math.lamb
View File

@ -1,9 +0,0 @@
-- Standard math library for the Lamb programming language
-- Copyright (c) 2013 darkf
-- Licensed under the terms of the zlib license, see LICENSE for details
pow(base, 0) -> 1.
pow(base, exp) -> do
if exp < 0 then 1 / pow(base, neg(exp))
else base * pow(base, exp-1)
end.

33
mods/std/op.lamb
View File

@ -1,33 +0,0 @@
-- Standard operators library for the Lamb programming language
-- Copyright (c) 2013 darkf
-- Licensed under the terms of the zlib license, see LICENSE for details
-- binary operators
add(x,y) -> x+y.
mul(x,y) -> x*y.
div(x,y) -> x/y.
cons(x,y) -> x::y.
eq(x,y) -> x==y.
neq(x,y) -> x != y.
lt(x,y) -> x<y.
gt(x,y) -> x>y.
not(true) -> false.
not(false) -> true.
and(true,true) -> true.
and(_,_) -> false.
or(true, _) -> true.
or(_, true) -> true.
or(_, _) -> false.
xor(true, false) -> true.
xor(false, true) -> true.
xor(_, _) -> false.
-- unary operators
neg(x) -> 0-x.

26
mods/std/str.lamb
View File

@ -1,26 +0,0 @@
import("std/op").
takeWhileS(f, "") -> "".
takeWhileS(f, x::xs) -> do
if f(x) == true then x :: takeWhileS(f, xs)
else ""
end.
takeUntilS(f, xs) -> takeWhileS(\x -> op\not(f(x)), xs).
dropWhileS(f, "") -> "".
dropWhileS(f, x::xs) -> do
if f(x) == true then dropWhileS(f, xs)
else x :: xs
end.
dropS(0, x) -> x.
dropS(n, "") -> "".
dropS(n, _::xs) -> dropS(n-1, xs).
takeS(0, _) -> "".
takeS(n, "") -> "".
takeS(n, x::xs) -> x :: takeS(n-1, xs).
concat([]) -> "".
concat(x :: xs) -> x + concat(xs).