Compare commits
48 Commits
Author | SHA1 | Date |
---|---|---|
darkf | 6750c3809e | |
darkf | 1ea120a387 | |
darkf | 1217fe951f | |
darkf | 55f393b4f1 | |
darkf | 904716b94f | |
darkf | 04a2bf046a | |
darkf | 03c8a89318 | |
darkf | 19dd48991e | |
darkf | 81496aae24 | |
darkf | d55c816533 | |
darkf | 7179a6d818 | |
darkf | 715efff347 | |
darkf | 1ded14b348 | |
darkf | 6f3b2e15c2 | |
darkf | c19a732bd9 | |
darkf | 7f16ca95e3 | |
darkf | f4c3747b19 | |
darkf | eef1c17def | |
darkf | 92594900b4 | |
darkf | e6b13b253f | |
darkf | 86be5ca06d | |
darkf | 87bf27b6d0 | |
darkf | eec9bda75b | |
darkf | df693a83f7 | |
darkf | aab89f838b | |
Anton Golov | 209c815f80 | |
darkf | 989db3dc10 | |
Anton Golov | c5a29ef171 | |
darkf | 02bc968e0c | |
darkf | 5bae5645ec | |
darkf | d180116931 | |
darkf | 13b1671662 | |
darkf | fe280dca78 | |
darkf | 32252b8d89 | |
darkf | f7890c07fe | |
darkf | cf2723d01f | |
darkf | 5097c855ce | |
darkf | a85db6aca7 | |
darkf | 347fc15ba8 | |
darkf | 89ee63597b | |
darkf | 014567f61b | |
darkf | f32b05c22b | |
darkf | b1a465f0e9 | |
darkf | 502c711c96 | |
darkf | 0651f34dce | |
darkf | 8ce39fa0e7 | |
darkf | 1d57fca6b4 | |
darkf | 0725c9735b |
19
AST.hs
19
AST.hs
|
@ -3,6 +3,7 @@
|
|||
-- 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
|
||||
|
@ -12,29 +13,31 @@ 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 String (Pattern, AST)
|
||||
| Defun String AST
|
||||
| FunDef T.Text (Pattern, AST)
|
||||
| Defun T.Text AST
|
||||
| Def Pattern AST
|
||||
| Var String
|
||||
| Var T.Text
|
||||
| Lambda [(Pattern, AST)]
|
||||
| Call AST AST
|
||||
| Access AST AST
|
||||
| UnitConst
|
||||
| Cons AST AST
|
||||
| IfExpr AST AST AST
|
||||
| TupleConst [AST]
|
||||
| ListConst [AST]
|
||||
| BoolConst Bool
|
||||
| StrConst String
|
||||
| StrConst T.Text
|
||||
| IntConst Integer
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Pattern = VarP String
|
||||
data Pattern = VarP T.Text
|
||||
| IntP Integer
|
||||
| StrP String
|
||||
| StrP T.Text
|
||||
| BoolP Bool
|
||||
| UnitP
|
||||
| ConsP Pattern Pattern
|
||||
| TupleP [Pattern]
|
||||
| ListP [Pattern]
|
||||
|
|
414
Interp.hs
414
Interp.hs
|
@ -3,16 +3,27 @@
|
|||
-- Licensed under the terms of the zlib license, see LICENSE for details
|
||||
|
||||
module Interp where
|
||||
import Prelude hiding (lookup)
|
||||
import qualified Data.Map as M
|
||||
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 Data.List (intercalate)
|
||||
import Control.Monad.Trans (lift)
|
||||
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, hFlush, hClose, hIsEOF, openBinaryFile, hSetBinaryMode, IOMode(..), stdout, stdin)
|
||||
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)
|
||||
import System.FilePath (FilePath, splitExtension, takeBaseName, takeDirectory, (</>))
|
||||
import System.Environment (getExecutablePath)
|
||||
import AST
|
||||
import Parser (parseProgram)
|
||||
|
||||
|
@ -23,13 +34,14 @@ 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 String
|
||||
| UnitV
|
||||
| StrV T.Text
|
||||
| BoolV Bool
|
||||
| StreamV Int
|
||||
| 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)
|
||||
|
@ -40,44 +52,47 @@ 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) = 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 String Value] -- lexical environment (linked list)
|
||||
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
|
||||
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 -> String -> Maybe Value
|
||||
lookup :: Env -> T.Text -> Maybe Value
|
||||
lookup [] _ = Nothing
|
||||
lookup (env:xs) name =
|
||||
case M.lookup name env of
|
||||
Nothing -> lookup xs name
|
||||
Just x -> Just x
|
||||
lookup (env:xs) name = maybe (lookup xs name) Just (M.lookup name env)
|
||||
|
||||
-- bind in the local environment
|
||||
bind :: Env -> String -> Value -> Env
|
||||
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 UnitV = "()"
|
||||
show (RefV _) = "<ref>"
|
||||
show (Thread t) = "<thread " ++ show t ++ ">"
|
||||
|
||||
-- value operators
|
||||
(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)
|
||||
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
|
||||
|
||||
|
@ -96,132 +111,206 @@ 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
|
||||
|
||||
_fputbytes (TupleV [StreamV h, StrV str]) = do
|
||||
(handles,_) <- get
|
||||
let handle = handles !! h
|
||||
io <- lift $ hPutStr handle str >> hFlush handle
|
||||
return UnitV
|
||||
_fputstr (TupleV [StreamV handle, StrV str]) =
|
||||
liftIO $ TIO.hPutStr handle str >> return unitv
|
||||
|
||||
_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
|
||||
_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 h, IntV n]) = do
|
||||
(handles,_) <- get
|
||||
let handle = handles !! h
|
||||
str <- lift $ BSC.hGet handle (fromIntegral n :: Int)
|
||||
return . StrV $ BSC.unpack 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
|
||||
(handles,env) <- get
|
||||
let mode' = case mode of
|
||||
let mode' = case T.unpack mode of
|
||||
"r" -> ReadMode
|
||||
"w" -> WriteMode
|
||||
"rw" -> ReadWriteMode
|
||||
handle <- lift $ openBinaryFile path mode'
|
||||
put (handles ++ [handle], env)
|
||||
return . StreamV $ length handles
|
||||
StreamV <$> liftIO (openBinaryFile (T.unpack path) mode')
|
||||
|
||||
_feof (StreamV h) = do
|
||||
(handles,_) <- get
|
||||
let handle = handles !! h
|
||||
isEof <- lift $ hIsEOF handle
|
||||
return $ BoolV isEof
|
||||
_feof (StreamV handle) = do
|
||||
BoolV <$> liftIO (hIsEOF handle)
|
||||
|
||||
_fclose handle@(StreamV h) = do
|
||||
(handles,_) <- get
|
||||
let handle = handles !! h
|
||||
lift $ hClose handle
|
||||
return UnitV
|
||||
_fclose (StreamV handle) = do
|
||||
liftIO (hClose handle) >> return unitv
|
||||
|
||||
_sockopen (TupleV [StrV host, IntV port]) = do
|
||||
(handles,env) <- get
|
||||
handle <- lift $ SO.withSocketsDo $ do
|
||||
addr:_ <- SO.getAddrInfo Nothing (Just host) (Just $ show port)
|
||||
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
|
||||
return handle
|
||||
put (handles ++ [handle], env)
|
||||
return . StreamV $ length handles
|
||||
hSetBuffering handle NoBuffering
|
||||
return $ StreamV handle
|
||||
|
||||
_putstr str@(StrV _) = _fputstr $ TupleV [StreamV 0, str]
|
||||
_putbytes str@(StrV _) = _fputbytes $ TupleV [StreamV 0, str]
|
||||
_getline UnitV = _fgetline (StreamV 1)
|
||||
_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 $ show v ++ "\n"
|
||||
_repr v = return . StrV $ show v
|
||||
_print v = _putbytes $ StrV $ T.pack (show v) `T.snoc` '\n'
|
||||
_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
|
||||
|
||||
_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
|
||||
(h,env) <- get -- save current state
|
||||
env <- get -- save current state
|
||||
put initialState
|
||||
(path,modname) <- lift $ findModule modname -- find the module file
|
||||
(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
|
||||
-- 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
|
||||
[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
|
||||
let path = modname ++ ".lamb"
|
||||
exists <- doesFileExist path
|
||||
if exists then
|
||||
return (path, takeBaseName path)
|
||||
else error $ "module " ++ modname ++ " couldn't be found"
|
||||
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
|
||||
|
||||
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)]])
|
||||
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
|
||||
|
||||
|
@ -229,8 +318,6 @@ 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
|
||||
|
@ -238,13 +325,14 @@ eval (Cons a b) = do
|
|||
b' <- eval b
|
||||
case b' of
|
||||
ListV v' -> return $ ListV $ a':v'
|
||||
_ -> error "cons: RHS must be a list"
|
||||
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) =
|
||||
mapM eval v >>= \xs ->
|
||||
return $ ListV xs
|
||||
|
||||
eval (TupleConst v) = mapM eval v >>= return . TupleV
|
||||
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
|
||||
|
@ -252,37 +340,35 @@ eval (IfExpr c t e) = eval c >>= \cond ->
|
|||
BoolV False -> eval e
|
||||
_ -> error "if: condition must be a boolean"
|
||||
|
||||
eval (Var var) = get >>= \(_,env) ->
|
||||
case lookup env var of
|
||||
Just v -> return v
|
||||
Nothing -> error $ "unbound variable " ++ var
|
||||
eval (Var var) = get >>= \env ->
|
||||
maybe (error $ "unbound variable " ++ T.unpack var) return (lookup env var)
|
||||
|
||||
eval (Defun name fn) = do
|
||||
(s,env) <- get
|
||||
env <- get
|
||||
case lookup env name of
|
||||
Nothing -> -- bind new fn
|
||||
eval fn >>= \fn' ->
|
||||
put (s, bind env name fn') >> return 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 (s, bind env name newfn) >> return newfn
|
||||
put (bind env name newfn) >> return newfn
|
||||
|
||||
eval (Def pat v') = do
|
||||
v <- eval v'
|
||||
(s,locals:xs) <- get
|
||||
locals:xs <- get
|
||||
case patternBindings pat v of
|
||||
Nothing -> error $ "pattern binding doesn't satisfy: " ++ show v ++ " with " ++ show pat
|
||||
Just bindings ->
|
||||
put (s, (M.union bindings locals):xs) >> -- update our local bindings
|
||||
Just bindings -> do
|
||||
put $ (M.union bindings locals):xs -- update our local bindings
|
||||
return v
|
||||
|
||||
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 (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 }
|
||||
|
@ -294,6 +380,11 @@ 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
|
||||
|
@ -302,30 +393,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 "nothing"]
|
||||
Nothing -> return $ TupleV [StrV (T.pack "nothing")]
|
||||
_ -> error $ "op/: need a dict, got " ++ show lhs
|
||||
where
|
||||
mapToEnv :: M.Map Value Value -> Env
|
||||
mapToEnv m = [M.fromAscList $ map (\(StrV k,v) -> (k,v)) (M.toAscList m)]
|
||||
mapToEnv m = [fromDict m]
|
||||
eval (Access _ _) = error "op/: RHS must be an identifier"
|
||||
|
||||
eval (Call lhs arg) = do
|
||||
(h,env) <- get
|
||||
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 (h,cls') -- enter closure env
|
||||
put cls' -- enter closure env
|
||||
v <- apply fn arg'
|
||||
put (h,env) -- restore env
|
||||
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 String Value)
|
||||
patternBindings :: Pattern -> Value -> Maybe (M.Map T.Text Value)
|
||||
patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
|
||||
|
||||
patternBindings (IntP n) (IntV v)
|
||||
|
@ -337,27 +428,31 @@ 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
|
||||
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
|
||||
patternBindings (ConsP (StrP xp) xsp) (StrV str) =
|
||||
let len = length xp in
|
||||
if take len str == xp then -- matches
|
||||
patternBindings xsp $ StrV (drop len str) -- match the rest of the string
|
||||
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 (x:xs)) =
|
||||
do
|
||||
xe <- patternBindings xp (StrV [x])
|
||||
xse <- patternBindings xsp $ StrV xs
|
||||
Just $ M.union xe xse
|
||||
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
|
||||
|
@ -390,6 +485,8 @@ 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 =
|
||||
|
@ -400,9 +497,9 @@ apply (FnV _ pats) arg =
|
|||
case patternBindings pat arg of
|
||||
Just bindings -> -- satisfies
|
||||
do
|
||||
(s,env) <- get
|
||||
env <- get
|
||||
let newenv = bindings:env
|
||||
put (s, newenv)
|
||||
put newenv
|
||||
eval body
|
||||
Nothing -> -- doesn't satisfy this pattern
|
||||
apply' xs
|
||||
|
@ -411,16 +508,21 @@ apply (Builtin (BIF fn)) arg = fn arg
|
|||
|
||||
-- some helper programs for evaluation
|
||||
|
||||
-- sets up stdin/stdout for binary mode
|
||||
-- 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 = foldr1 (>>) $ map eval nodes
|
||||
evalProgram nodes = foldl1' (>>) $ map eval nodes
|
||||
|
||||
evalString :: String -> InterpState Value
|
||||
evalString :: T.Text -> InterpState Value
|
||||
evalString program =
|
||||
case parseProgram program of
|
||||
Left err -> error $ show err
|
||||
|
@ -431,15 +533,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 :: [String] -> [String]
|
||||
parseLiterate lns = [drop 4 line | line <- lns, take 4 line == " "]
|
||||
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 <- lift $ if path == "-" then getContents else readFile path
|
||||
contents <- liftIO $ if path == "-" then TIO.getContents else TIO.readFile path
|
||||
if isLiterate path then
|
||||
evalString . unlines . parseLiterate . lines $ contents
|
||||
evalString . T.unlines . parseLiterate . T.lines $ contents
|
||||
else evalString contents
|
||||
|
||||
evalFileV :: FilePath -> IO Value
|
||||
evalFileV path = evalStateT (evalFile path) initialState
|
||||
evalFileV = interpret . evalFile
|
||||
|
|
17
LICENSE
17
LICENSE
|
@ -0,0 +1,17 @@
|
|||
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.
|
52
Lamb.hs
52
Lamb.hs
|
@ -5,22 +5,46 @@
|
|||
import System.Environment (getArgs)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath (FilePath, splitExtension)
|
||||
import Interp (evalFileV, initIO, Value(UnitV))
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (filterM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Parser (parseProgram)
|
||||
import Interp (evalFileV, evalProgram, initIO, interpret, InterpState, Value)
|
||||
|
||||
-- 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
|
||||
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 ()
|
||||
|
||||
main = do
|
||||
args <- getArgs
|
||||
exist <- allExist args
|
||||
case exist of
|
||||
Just file -> putStrLn $ "error: file " ++ file ++ " doesn't exist"
|
||||
Nothing ->
|
||||
initIO >>
|
||||
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
|
||||
|
|
39
Parser.hs
39
Parser.hs
|
@ -1,7 +1,9 @@
|
|||
{-# 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|
|
||||
|
@ -21,9 +23,7 @@ semistatements :: [AST]
|
|||
|
||||
args :: AST
|
||||
= expr ("," expr)+ { TupleConst ($1 : $2) }
|
||||
/ expr? { case $1 of
|
||||
Just x -> x
|
||||
Nothing -> UnitConst }
|
||||
/ expr? { fromMaybe (TupleConst []) $1 }
|
||||
|
||||
patternlist :: Pattern
|
||||
= pattern ("," pattern)+ { ListP ($1 : $2) }
|
||||
|
@ -42,14 +42,12 @@ pattern :: Pattern
|
|||
/ patterntuple
|
||||
/ "true" { BoolP True } / "false" { BoolP False }
|
||||
/ identifier { VarP $1 }
|
||||
/ stringlit { StrP $1 }
|
||||
/ stringlit { StrP (T.pack $1) }
|
||||
/ integer { IntP $1 }
|
||||
|
||||
funpattern :: Pattern
|
||||
= pattern ("," pattern)+ { TupleP ($1 : $2) }
|
||||
/ pattern? { case $1 of
|
||||
Just x -> x
|
||||
Nothing -> UnitP }
|
||||
/ pattern? { fromMaybe (TupleP []) $1 }
|
||||
|
||||
listseq :: AST
|
||||
= expr ("," expr)+ { ListConst ($1 : $2) }
|
||||
|
@ -78,29 +76,41 @@ 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 "*" term { Mul $1 $2 }
|
||||
/ fact "/" term { Div $1 $2 }
|
||||
= 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) }
|
||||
/ term
|
||||
|
||||
term :: AST
|
||||
= term "(" args ")" { Call $1 $2 }
|
||||
/ tuple
|
||||
= tuple
|
||||
/ "(" expr ")"
|
||||
/ "[" listseq "]"
|
||||
/ ifcond
|
||||
/ doblock
|
||||
/ "true" { BoolConst True } / "false" { BoolConst False }
|
||||
/ stringlit { StrConst $1 }
|
||||
/ stringlit { StrConst (T.pack $1) }
|
||||
/ integer { IntConst $1 }
|
||||
/ identifier { Var $1 }
|
||||
|
||||
|
@ -119,9 +129,10 @@ escChar :: Char
|
|||
/ 'n' { '\n' }
|
||||
/ 'r' { '\r' }
|
||||
/ 't' { '\t' }
|
||||
/ '0' { '\0' }
|
||||
|
||||
identifier ::: String
|
||||
= [a-zA-Z_] [a-zA-Z0-9_'?!]* { $1 : $2 }
|
||||
identifier ::: T.Text
|
||||
= [a-zA-Z_] [a-zA-Z0-9_'?!]* { T.pack ($1 : $2) }
|
||||
|
||||
integer ::: Integer
|
||||
= [0-9] [0-9]* { read ($1 : $2) }
|
||||
|
|
|
@ -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).
|
|
@ -0,0 +1,16 @@
|
|||
-- 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
|
|
@ -0,0 +1,13 @@
|
|||
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
|
|
@ -0,0 +1,28 @@
|
|||
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.
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
-- 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)).
|
|
@ -0,0 +1,146 @@
|
|||
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))).
|
|
@ -0,0 +1,77 @@
|
|||
-- 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).
|
|
@ -0,0 +1,9 @@
|
|||
-- 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.
|
|
@ -0,0 +1,33 @@
|
|||
-- 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.
|
|
@ -0,0 +1,26 @@
|
|||
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).
|
Loading…
Reference in New Issue