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
|
-- Licensed under the terms of the zlib license, see LICENSE for details
|
||||||
|
|
||||||
module AST where
|
module AST where
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
data AST = Add AST AST
|
data AST = Add AST AST
|
||||||
| Sub AST AST
|
| Sub AST AST
|
||||||
|
@ -12,29 +13,31 @@ data AST = Add AST AST
|
||||||
| NotEquals AST AST
|
| NotEquals AST AST
|
||||||
| LessThan AST AST
|
| LessThan AST AST
|
||||||
| GreaterThan AST AST
|
| GreaterThan AST AST
|
||||||
|
| BitAnd AST AST
|
||||||
|
| BitOr AST AST
|
||||||
|
| BitNot AST
|
||||||
|
| BitShift AST AST Bool
|
||||||
| Block [AST]
|
| Block [AST]
|
||||||
| FunDef String (Pattern, AST)
|
| FunDef T.Text (Pattern, AST)
|
||||||
| Defun String AST
|
| Defun T.Text AST
|
||||||
| Def Pattern AST
|
| Def Pattern AST
|
||||||
| Var String
|
| Var T.Text
|
||||||
| Lambda [(Pattern, AST)]
|
| Lambda [(Pattern, AST)]
|
||||||
| Call AST AST
|
| Call AST AST
|
||||||
| Access AST AST
|
| Access AST AST
|
||||||
| UnitConst
|
|
||||||
| Cons AST AST
|
| Cons AST AST
|
||||||
| IfExpr AST AST AST
|
| IfExpr AST AST AST
|
||||||
| TupleConst [AST]
|
| TupleConst [AST]
|
||||||
| ListConst [AST]
|
| ListConst [AST]
|
||||||
| BoolConst Bool
|
| BoolConst Bool
|
||||||
| StrConst String
|
| StrConst T.Text
|
||||||
| IntConst Integer
|
| IntConst Integer
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data Pattern = VarP String
|
data Pattern = VarP T.Text
|
||||||
| IntP Integer
|
| IntP Integer
|
||||||
| StrP String
|
| StrP T.Text
|
||||||
| BoolP Bool
|
| BoolP Bool
|
||||||
| UnitP
|
|
||||||
| ConsP Pattern Pattern
|
| ConsP Pattern Pattern
|
||||||
| TupleP [Pattern]
|
| TupleP [Pattern]
|
||||||
| ListP [Pattern]
|
| ListP [Pattern]
|
||||||
|
|
402
Interp.hs
402
Interp.hs
|
@ -3,16 +3,27 @@
|
||||||
-- Licensed under the terms of the zlib license, see LICENSE for details
|
-- Licensed under the terms of the zlib license, see LICENSE for details
|
||||||
|
|
||||||
module Interp where
|
module Interp where
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup, (<$))
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map.Strict 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 Data.List (intercalate)
|
import qualified Data.Text as T
|
||||||
import Control.Monad.Trans (lift)
|
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 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.Directory (doesFileExist)
|
||||||
import System.FilePath (FilePath, splitExtension, takeBaseName)
|
import System.FilePath (FilePath, splitExtension, takeBaseName, takeDirectory, (</>))
|
||||||
|
import System.Environment (getExecutablePath)
|
||||||
import AST
|
import AST
|
||||||
import Parser (parseProgram)
|
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
|
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
|
||||||
| UnitV
|
|
||||||
| BoolV Bool
|
| BoolV Bool
|
||||||
| StreamV Int
|
| StreamV Handle
|
||||||
| TupleV [Value]
|
| TupleV [Value]
|
||||||
| ListV [Value]
|
| ListV [Value]
|
||||||
| DictV (M.Map Value Value)
|
| DictV (M.Map Value Value)
|
||||||
|
| RefV (TVar Value)
|
||||||
|
| Thread ThreadId
|
||||||
| Builtin BIF
|
| Builtin BIF
|
||||||
| FnV Env [(Pattern, AST)] -- closure pattern->body bindings
|
| FnV Env [(Pattern, AST)] -- closure pattern->body bindings
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
@ -40,44 +52,47 @@ instance Ord Value where
|
||||||
compare (BoolV a) (BoolV b) = compare a b
|
compare (BoolV a) (BoolV b) = compare a b
|
||||||
compare (TupleV a) (TupleV b) = compare a b
|
compare (TupleV a) (TupleV b) = compare a b
|
||||||
compare (ListV a) (ListV 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 (Builtin a) (Builtin b) = compare a b
|
||||||
compare (FnV a b) (FnV x y) = if a == x && b == y then EQ else LT
|
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 (DictV a) (DictV b) = compare a b
|
||||||
compare _ _ = error "compare: not valid"
|
compare _ _ = error "compare: not valid"
|
||||||
|
|
||||||
type Env = [M.Map String Value] -- lexical environment (linked list)
|
type Env = [M.Map T.Text Value] -- lexical environment (linked list)
|
||||||
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
|
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]
|
emptyEnv = [M.empty]
|
||||||
|
unitv = TupleV []
|
||||||
|
|
||||||
-- look up a binding from the bottom up
|
-- look up a binding from the bottom up
|
||||||
lookup :: Env -> String -> Maybe Value
|
lookup :: Env -> T.Text -> Maybe Value
|
||||||
lookup [] _ = Nothing
|
lookup [] _ = Nothing
|
||||||
lookup (env:xs) name =
|
lookup (env:xs) name = maybe (lookup xs name) Just (M.lookup name env)
|
||||||
case M.lookup name env of
|
|
||||||
Nothing -> lookup xs name
|
|
||||||
Just x -> Just x
|
|
||||||
|
|
||||||
-- bind in the local environment
|
-- 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
|
bind (env:xs) name value = (M.insert name value env):xs
|
||||||
|
|
||||||
instance Show Value where
|
instance Show Value where
|
||||||
show (IntV i) = show i
|
show (IntV i) = show i
|
||||||
show (StrV s) = show s
|
show (StrV s) = show s
|
||||||
show (BoolV b) = show b
|
show (BoolV b) = show b
|
||||||
|
show (TupleV []) = "(,)"
|
||||||
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
||||||
show (ListV v) = show v
|
show (ListV v) = show v
|
||||||
show (DictV d) = "<dict " ++ show d ++ ">"
|
show (DictV d) = "<dict " ++ show d ++ ">"
|
||||||
show (FnV _ _) = "<fn>"
|
show (FnV _ _) = "<fn>"
|
||||||
show (StreamV _) = "<stream>"
|
show (StreamV _) = "<stream>"
|
||||||
show (Builtin _) = "<built-in>"
|
show (Builtin _) = "<built-in>"
|
||||||
show UnitV = "()"
|
show (RefV _) = "<ref>"
|
||||||
|
show (Thread t) = "<thread " ++ show t ++ ">"
|
||||||
|
|
||||||
-- 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
|
||||||
|
|
||||||
|
@ -96,132 +111,206 @@ l <$ r = error $ "cannot < " ++ show l ++ " and " ++ show r
|
||||||
(IntV l) >$ (IntV r) = BoolV (l > r)
|
(IntV l) >$ (IntV r) = BoolV (l > r)
|
||||||
l >$ r = error $ "cannot > " ++ show l ++ " and " ++ show 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)
|
||||||
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
|
-- some built-in functions
|
||||||
|
|
||||||
_fputbytes (TupleV [StreamV h, StrV str]) = do
|
_fputstr (TupleV [StreamV handle, StrV str]) =
|
||||||
(handles,_) <- get
|
liftIO $ TIO.hPutStr handle str >> return unitv
|
||||||
let handle = handles !! h
|
|
||||||
io <- lift $ hPutStr handle str >> hFlush handle
|
|
||||||
return UnitV
|
|
||||||
|
|
||||||
_fputstr (TupleV [StreamV h, StrV str]) = do
|
_fgetline (StreamV handle) = do
|
||||||
(handles,_) <- get
|
str <- liftIO $ TIO.hGetLine handle
|
||||||
let handle = handles !! h
|
if T.last str == '\r' then -- remove trailing CR
|
||||||
io <- lift $ hPutStr handle str >> hFlush handle
|
return . StrV $ T.init str
|
||||||
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
|
else return $ StrV str
|
||||||
|
|
||||||
_freadbytes (TupleV [StreamV h, IntV n]) = do
|
_freadbytes (TupleV [StreamV handle, IntV n]) = do
|
||||||
(handles,_) <- get
|
liftIO $ StrV . T.take (fromIntegral n) <$> TIO.hGetContents handle
|
||||||
let handle = handles !! h
|
|
||||||
str <- lift $ BSC.hGet handle (fromIntegral n :: Int)
|
_freadcontents (StreamV handle) = do
|
||||||
return . StrV $ BSC.unpack str
|
liftIO $ StrV <$> TIO.hGetContents handle
|
||||||
|
|
||||||
_fopen (TupleV [StrV path, StrV mode]) = do
|
_fopen (TupleV [StrV path, StrV mode]) = do
|
||||||
(handles,env) <- get
|
let mode' = case T.unpack mode of
|
||||||
let mode' = case mode of
|
|
||||||
"r" -> ReadMode
|
"r" -> ReadMode
|
||||||
"w" -> WriteMode
|
"w" -> WriteMode
|
||||||
"rw" -> ReadWriteMode
|
"rw" -> ReadWriteMode
|
||||||
handle <- lift $ openBinaryFile path mode'
|
StreamV <$> liftIO (openBinaryFile (T.unpack path) mode')
|
||||||
put (handles ++ [handle], env)
|
|
||||||
return . StreamV $ length handles
|
|
||||||
|
|
||||||
_feof (StreamV h) = do
|
_feof (StreamV handle) = do
|
||||||
(handles,_) <- get
|
BoolV <$> liftIO (hIsEOF handle)
|
||||||
let handle = handles !! h
|
|
||||||
isEof <- lift $ hIsEOF handle
|
|
||||||
return $ BoolV isEof
|
|
||||||
|
|
||||||
_fclose handle@(StreamV h) = do
|
_fclose (StreamV handle) = do
|
||||||
(handles,_) <- get
|
liftIO (hClose handle) >> return unitv
|
||||||
let handle = handles !! h
|
|
||||||
lift $ hClose handle
|
|
||||||
return UnitV
|
|
||||||
|
|
||||||
_sockopen (TupleV [StrV host, IntV port]) = do
|
_sockopen (TupleV [StrV host, IntV port]) = do
|
||||||
(handles,env) <- get
|
liftIO $ SO.withSocketsDo $ do
|
||||||
handle <- lift $ SO.withSocketsDo $ do
|
addr:_ <- SO.getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port)
|
||||||
addr:_ <- SO.getAddrInfo Nothing (Just 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
|
||||||
return handle
|
hSetBuffering handle NoBuffering
|
||||||
put (handles ++ [handle], env)
|
return $ StreamV handle
|
||||||
return . StreamV $ length handles
|
|
||||||
|
|
||||||
_putstr str@(StrV _) = _fputstr $ TupleV [StreamV 0, str]
|
_putstr str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
|
||||||
_putbytes str@(StrV _) = _fputbytes $ TupleV [StreamV 0, str]
|
_putbytes str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
|
||||||
_getline UnitV = _fgetline (StreamV 1)
|
_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
|
||||||
|
|
||||||
|
_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
|
_loop args@(TupleV [fn@(FnV _ _), arg]) = do
|
||||||
v <- apply fn arg
|
v <- apply fn arg
|
||||||
if v /= BoolV False then
|
if v /= BoolV False then
|
||||||
_loop $ TupleV [fn, v]
|
_loop $ TupleV [fn, v]
|
||||||
else return arg
|
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 a module name as a module
|
||||||
_Import (StrV modname) = do
|
_Import (StrV modname) = do
|
||||||
(h,env) <- get -- save current state
|
env <- get -- save current state
|
||||||
put initialState
|
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
|
evalFile path -- evaluate the module file
|
||||||
(_,[modenv]) <- get -- get the module env
|
[modenv] <- get -- get the module env
|
||||||
let (_, [initialEnv]) = initialState
|
let [initialEnv] = initialState
|
||||||
let modenv' = M.difference modenv initialEnv -- subtract prelude stuff
|
--let modenv' = M.difference modenv initialEnv -- subtract prelude stuff
|
||||||
-- convert String to StrV in env keys
|
let mod = toDict modenv
|
||||||
let modenv'' = map (\(k,v) -> (StrV k, v)) $ M.toAscList modenv'
|
let env' = bind env (T.pack modname) mod -- bind it
|
||||||
let mod = DictV (M.fromAscList modenv'') -- package module into a dict
|
put env' -- restore state
|
||||||
let env' = bind env modname mod -- bind it
|
|
||||||
put (h,env') -- restore state
|
|
||||||
return mod -- return module value
|
return mod -- return module value
|
||||||
|
|
||||||
where
|
where
|
||||||
findModule :: FilePath -> IO (FilePath, String)
|
findModule :: FilePath -> IO (FilePath, String)
|
||||||
findModule modname = do
|
findModule modname = do
|
||||||
let path = modname ++ ".lamb"
|
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
|
exists <- doesFileExist path
|
||||||
if exists then
|
if exists then return (path, takeBaseName path)
|
||||||
return (path, takeBaseName path)
|
else findModuleIn xs
|
||||||
else error $ "module " ++ modname ++ " couldn't be found"
|
|
||||||
|
|
||||||
initialState = ([stdout, stdin],
|
bif = Builtin . BIF
|
||||||
[M.fromList [("id", FnV emptyEnv [(VarP "x", Var "x")]),
|
initialState = [M.fromList $ map (\(k,v) -> (T.pack k, v)) $ [
|
||||||
("loop", Builtin $ BIF _loop),
|
("id", FnV emptyEnv [(VarP (T.pack "x"), Var (T.pack "x"))]),
|
||||||
("repr", Builtin $ BIF _repr),
|
("loop", bif _loop),
|
||||||
("stdout", StreamV 0),
|
("ref!", bif _ref),
|
||||||
("stdin", StreamV 1),
|
("readRef!", bif _readRef),
|
||||||
("print", Builtin $ BIF _print),
|
("setRef!", bif _setRef),
|
||||||
("putstr", Builtin $ BIF _putstr),
|
("time!", bif _time),
|
||||||
("putstrln", Builtin $ BIF (\x -> _putstr $ x +$ StrV "\n")),
|
("sleep!", bif _sleep),
|
||||||
("getline", Builtin $ BIF _getline),
|
("repr", bif _repr),
|
||||||
("fgetline", Builtin $ BIF _fgetline),
|
("stdout", StreamV stdout),
|
||||||
("putbytes", Builtin $ BIF _putbytes),
|
("stdin", StreamV stdin),
|
||||||
("fputbytes", Builtin $ BIF _fputbytes),
|
("print", bif _print),
|
||||||
("fputstr", Builtin $ BIF _fputstr),
|
("putstr", bif _putstr),
|
||||||
("freadbytes", Builtin $ BIF _freadbytes),
|
("putstrln", bif (\x -> _putstr $ x +$ StrV (T.singleton '\n'))),
|
||||||
("feof", Builtin $ BIF _feof),
|
("getline", bif _getline),
|
||||||
("fclose", Builtin $ BIF _fclose),
|
("fgetline", bif _fgetline),
|
||||||
("fopen", Builtin $ BIF _fopen),
|
("putbytes", bif _putbytes),
|
||||||
("sockopen", Builtin $ BIF _sockopen),
|
("fputbytes", bif _fputstr),
|
||||||
("itos", Builtin $ BIF _itos),
|
("fputstr", bif _fputstr),
|
||||||
("import", Builtin $ BIF _Import)]])
|
("freadbytes", bif _freadbytes),
|
||||||
|
("freadcontents", bif _freadcontents),
|
||||||
|
("feof", bif _feof),
|
||||||
|
("fclose", bif _fclose),
|
||||||
|
("fopen", bif _fopen),
|
||||||
|
("sockopen", bif _sockopen),
|
||||||
|
("itos", bif _itos),
|
||||||
|
("stoi", bif _stoi),
|
||||||
|
("ord", bif _ord),
|
||||||
|
("chr", bif _chr),
|
||||||
|
("globals", bif _globals),
|
||||||
|
("locals", bif _locals),
|
||||||
|
("newStdEnv", bif _newStdEnv),
|
||||||
|
("thread!", bif _thread),
|
||||||
|
("kill!", bif _kill),
|
||||||
|
("eval", bif _eval),
|
||||||
|
("import", bif _Import)]]
|
||||||
|
|
||||||
eval :: AST -> InterpState Value
|
eval :: AST -> InterpState Value
|
||||||
|
|
||||||
|
@ -229,8 +318,6 @@ eval (IntConst i) = return $ IntV i
|
||||||
eval (StrConst s) = return $ StrV s
|
eval (StrConst s) = return $ StrV s
|
||||||
eval (BoolConst b) = return $ BoolV b
|
eval (BoolConst b) = return $ BoolV b
|
||||||
|
|
||||||
eval UnitConst = return UnitV
|
|
||||||
|
|
||||||
eval (Block body) = foldr1 (>>) $ map eval body
|
eval (Block body) = foldr1 (>>) $ map eval body
|
||||||
|
|
||||||
eval (Cons a b) = do
|
eval (Cons a b) = do
|
||||||
|
@ -238,13 +325,14 @@ eval (Cons a b) = do
|
||||||
b' <- eval b
|
b' <- eval b
|
||||||
case b' of
|
case b' of
|
||||||
ListV v' -> return $ ListV $ a':v'
|
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) =
|
eval (ListConst v) = ListV <$> mapM eval v
|
||||||
mapM eval v >>= \xs ->
|
eval (TupleConst v) = TupleV <$> mapM eval v
|
||||||
return $ ListV xs
|
|
||||||
|
|
||||||
eval (TupleConst v) = mapM eval v >>= return . TupleV
|
|
||||||
|
|
||||||
eval (IfExpr c t e) = eval c >>= \cond ->
|
eval (IfExpr c t e) = eval c >>= \cond ->
|
||||||
case cond of
|
case cond of
|
||||||
|
@ -252,34 +340,32 @@ eval (IfExpr c t e) = eval c >>= \cond ->
|
||||||
BoolV False -> eval e
|
BoolV False -> eval e
|
||||||
_ -> error "if: condition must be a boolean"
|
_ -> error "if: condition must be a boolean"
|
||||||
|
|
||||||
eval (Var var) = get >>= \(_,env) ->
|
eval (Var var) = get >>= \env ->
|
||||||
case lookup env var of
|
maybe (error $ "unbound variable " ++ T.unpack var) return (lookup env var)
|
||||||
Just v -> return v
|
|
||||||
Nothing -> error $ "unbound variable " ++ var
|
|
||||||
|
|
||||||
eval (Defun name fn) = do
|
eval (Defun name fn) = do
|
||||||
(s,env) <- get
|
env <- get
|
||||||
case lookup env name of
|
case lookup env name of
|
||||||
Nothing -> -- bind new fn
|
Nothing -> -- bind new fn
|
||||||
eval fn >>= \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
|
Just oldfn -> -- add pattern to old fn
|
||||||
let FnV cls oldpats = oldfn
|
let FnV cls oldpats = oldfn
|
||||||
Lambda [(pat, body)] = fn
|
Lambda [(pat, body)] = fn
|
||||||
newfn = FnV cls (oldpats ++ [(pat, body)]) in
|
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
|
eval (Def pat v') = do
|
||||||
v <- eval v'
|
v <- eval v'
|
||||||
(s,locals:xs) <- get
|
locals:xs <- get
|
||||||
case patternBindings pat v of
|
case patternBindings pat v of
|
||||||
Nothing -> error $ "pattern binding doesn't satisfy: " ++ show v ++ " with " ++ show pat
|
Nothing -> error $ "pattern binding doesn't satisfy: " ++ show v ++ " with " ++ show pat
|
||||||
Just bindings ->
|
Just bindings -> do
|
||||||
put (s, (M.union bindings locals):xs) >> -- update our local bindings
|
put $ (M.union bindings locals):xs -- update our local bindings
|
||||||
return v
|
return v
|
||||||
|
|
||||||
eval (Lambda pats) =
|
eval (Lambda pats) = do
|
||||||
get >>= \(_,env) ->
|
env <- get
|
||||||
if length env == 1 then -- if in global env just use [], denoting the current global scope
|
if length env == 1 then -- if in global env just use [], denoting the current global scope
|
||||||
return $ FnV [] pats
|
return $ FnV [] pats
|
||||||
else return $ FnV env pats
|
else return $ FnV env pats
|
||||||
|
@ -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 (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 (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
|
eval (Access left (Var right)) = do
|
||||||
lhs <- eval left
|
lhs <- eval left
|
||||||
case lhs of
|
case lhs of
|
||||||
|
@ -302,30 +393,30 @@ eval (Access left (Var right)) = do
|
||||||
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 = [fromDict 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
|
||||||
(h,env) <- get
|
env <- get
|
||||||
v <- eval lhs
|
v <- eval lhs
|
||||||
case v of
|
case v of
|
||||||
fn@(FnV cls _) -> do
|
fn@(FnV cls _) -> do
|
||||||
arg' <- eval arg
|
arg' <- eval arg
|
||||||
let cls' = if cls == [] then [last env] else cls -- if [], use current global env
|
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'
|
v <- apply fn arg'
|
||||||
put (h,env) -- restore env
|
put env -- restore env
|
||||||
return v
|
return v
|
||||||
fn@(Builtin _) -> eval arg >>= apply fn
|
fn@(Builtin _) -> eval arg >>= apply fn
|
||||||
_ -> error $ "call: " ++ show v ++ " is not a function"
|
_ -> error $ "call: " ++ show v ++ " is not a function"
|
||||||
|
|
||||||
eval x = error $ "eval: unhandled: " ++ show x
|
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 (VarP n) v = Just $ M.fromList [(n, v)]
|
||||||
|
|
||||||
patternBindings (IntP n) (IntV v)
|
patternBindings (IntP n) (IntV v)
|
||||||
|
@ -337,27 +428,31 @@ patternBindings (BoolP b) (BoolV v)
|
||||||
| v == b = Just M.empty
|
| v == b = Just M.empty
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
|
|
||||||
patternBindings UnitP UnitV = Just M.empty
|
|
||||||
patternBindings UnitP _ = Nothing
|
|
||||||
|
|
||||||
patternBindings (StrP x) (StrV y)
|
patternBindings (StrP x) (StrV y)
|
||||||
| x == y = Just M.empty
|
| 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 = T.length xp in
|
||||||
if take len str == xp then -- matches
|
if T.take len str == 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
|
||||||
|
xe <- patternBindings xp (StrV $ T.singleton x)
|
||||||
xse <- patternBindings xsp $ StrV xs
|
xse <- patternBindings xsp $ StrV xs
|
||||||
Just $ M.union xe xse
|
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
|
||||||
|
@ -390,6 +485,8 @@ patternBindings (TupleP (x:xs)) (TupleV (y:ys)) =
|
||||||
Just $ M.union env' env
|
Just $ M.union env' env
|
||||||
patternBindings (TupleP _) _ = Nothing -- not a tuple
|
patternBindings (TupleP _) _ = Nothing -- not a tuple
|
||||||
|
|
||||||
|
patternBindings p x = error $ "patternBindings failure: matching " ++ show x ++ " with pattern " ++ show p
|
||||||
|
|
||||||
-- applies a function
|
-- applies a function
|
||||||
apply :: Value -> Value -> InterpState Value
|
apply :: Value -> Value -> InterpState Value
|
||||||
apply (FnV _ pats) arg =
|
apply (FnV _ pats) arg =
|
||||||
|
@ -400,9 +497,9 @@ apply (FnV _ pats) arg =
|
||||||
case patternBindings pat arg of
|
case patternBindings pat arg of
|
||||||
Just bindings -> -- satisfies
|
Just bindings -> -- satisfies
|
||||||
do
|
do
|
||||||
(s,env) <- get
|
env <- get
|
||||||
let newenv = bindings:env
|
let newenv = bindings:env
|
||||||
put (s, newenv)
|
put newenv
|
||||||
eval body
|
eval body
|
||||||
Nothing -> -- doesn't satisfy this pattern
|
Nothing -> -- doesn't satisfy this pattern
|
||||||
apply' xs
|
apply' xs
|
||||||
|
@ -411,16 +508,21 @@ apply (Builtin (BIF fn)) arg = fn arg
|
||||||
|
|
||||||
-- some helper programs for evaluation
|
-- 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 :: IO ()
|
||||||
initIO = do
|
initIO = do
|
||||||
hSetBinaryMode stdin True
|
hSetBinaryMode stdin True
|
||||||
hSetBinaryMode stdout 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 :: [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 =
|
evalString program =
|
||||||
case parseProgram program of
|
case parseProgram program of
|
||||||
Left err -> error $ show err
|
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
|
-- Takes the lines of a literate program and returns the lines for a new executable program
|
||||||
-- from lines beginning with four spaces.
|
-- from lines beginning with four spaces.
|
||||||
parseLiterate :: [String] -> [String]
|
parseLiterate :: [T.Text] -> [T.Text]
|
||||||
parseLiterate lns = [drop 4 line | line <- lns, take 4 line == " "]
|
parseLiterate lns = [T.drop 4 line | line <- lns, T.take 4 line == T.pack " "]
|
||||||
|
|
||||||
evalFile :: FilePath -> InterpState Value
|
evalFile :: FilePath -> InterpState Value
|
||||||
evalFile path = do
|
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
|
if isLiterate path then
|
||||||
evalString . unlines . parseLiterate . lines $ contents
|
evalString . T.unlines . parseLiterate . T.lines $ contents
|
||||||
else evalString contents
|
else evalString contents
|
||||||
|
|
||||||
evalFileV :: FilePath -> IO Value
|
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.Environment (getArgs)
|
||||||
import System.Directory (doesFileExist)
|
import System.Directory (doesFileExist)
|
||||||
import System.FilePath (FilePath, splitExtension)
|
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
|
exists :: FilePath -> IO Bool
|
||||||
allExist :: [FilePath] -> IO (Maybe FilePath)
|
exists "-" = return True
|
||||||
allExist [] = return Nothing
|
exists path = not <$> doesFileExist path
|
||||||
allExist ("-":xs) = allExist xs
|
|
||||||
allExist (x:xs) = do
|
findMissing :: [FilePath] -> IO [FilePath]
|
||||||
exists <- doesFileExist x
|
findMissing = filterM exists
|
||||||
if exists then allExist xs
|
|
||||||
else return $ Just x
|
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
|
main = do
|
||||||
args <- getArgs
|
args <- getArgs
|
||||||
exist <- allExist args
|
if null args
|
||||||
case exist of
|
then do -- no arguments, launch REPL
|
||||||
Just file -> putStrLn $ "error: file " ++ file ++ " doesn't exist"
|
initIO
|
||||||
Nothing ->
|
repl'
|
||||||
initIO >>
|
else do
|
||||||
|
missing <- findMissing args
|
||||||
|
if null missing
|
||||||
|
then do
|
||||||
|
initIO
|
||||||
mapM_ evalFileV args
|
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 #-}
|
{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}
|
||||||
|
|
||||||
module Parser where
|
module Parser where
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
import Text.Peggy hiding (space)
|
import Text.Peggy hiding (space)
|
||||||
|
import qualified Data.Text as T
|
||||||
import AST
|
import AST
|
||||||
|
|
||||||
[peggy|
|
[peggy|
|
||||||
|
@ -21,9 +23,7 @@ semistatements :: [AST]
|
||||||
|
|
||||||
args :: AST
|
args :: AST
|
||||||
= expr ("," expr)+ { TupleConst ($1 : $2) }
|
= expr ("," expr)+ { TupleConst ($1 : $2) }
|
||||||
/ expr? { case $1 of
|
/ expr? { fromMaybe (TupleConst []) $1 }
|
||||||
Just x -> x
|
|
||||||
Nothing -> UnitConst }
|
|
||||||
|
|
||||||
patternlist :: Pattern
|
patternlist :: Pattern
|
||||||
= pattern ("," pattern)+ { ListP ($1 : $2) }
|
= pattern ("," pattern)+ { ListP ($1 : $2) }
|
||||||
|
@ -42,14 +42,12 @@ pattern :: Pattern
|
||||||
/ patterntuple
|
/ patterntuple
|
||||||
/ "true" { BoolP True } / "false" { BoolP False }
|
/ "true" { BoolP True } / "false" { BoolP False }
|
||||||
/ identifier { VarP $1 }
|
/ identifier { VarP $1 }
|
||||||
/ stringlit { StrP $1 }
|
/ stringlit { StrP (T.pack $1) }
|
||||||
/ integer { IntP $1 }
|
/ integer { IntP $1 }
|
||||||
|
|
||||||
funpattern :: Pattern
|
funpattern :: Pattern
|
||||||
= pattern ("," pattern)+ { TupleP ($1 : $2) }
|
= pattern ("," pattern)+ { TupleP ($1 : $2) }
|
||||||
/ pattern? { case $1 of
|
/ pattern? { fromMaybe (TupleP []) $1 }
|
||||||
Just x -> x
|
|
||||||
Nothing -> UnitP }
|
|
||||||
|
|
||||||
listseq :: AST
|
listseq :: AST
|
||||||
= expr ("," expr)+ { ListConst ($1 : $2) }
|
= expr ("," expr)+ { ListConst ($1 : $2) }
|
||||||
|
@ -78,29 +76,41 @@ expr :: AST
|
||||||
= expr "::" expr { Cons $1 $2 }
|
= expr "::" expr { Cons $1 $2 }
|
||||||
/ expr "+" fact { Add $1 $2 }
|
/ expr "+" fact { Add $1 $2 }
|
||||||
/ expr "-" fact { Sub $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 { Equals $1 $2 }
|
||||||
/ expr "!=" fact { NotEquals $1 $2 }
|
/ expr "!=" fact { NotEquals $1 $2 }
|
||||||
/ expr "<" fact { LessThan $1 $2 }
|
/ expr "<" fact { LessThan $1 $2 }
|
||||||
/ expr ">" fact { GreaterThan $1 $2 }
|
/ expr ">" fact { GreaterThan $1 $2 }
|
||||||
|
/ "~" expr { BitNot $1 }
|
||||||
/ def
|
/ def
|
||||||
/ lambda
|
/ lambda
|
||||||
/ identifier "(" funpattern ")" "->" expr { Defun $1 (Lambda [($2, $3)]) }
|
/ identifier "(" funpattern ")" "->" expr { Defun $1 (Lambda [($2, $3)]) }
|
||||||
/ fact
|
/ fact
|
||||||
|
|
||||||
fact :: AST
|
fact :: AST
|
||||||
= fact "*" term { Mul $1 $2 }
|
= fact "*" call { Mul $1 $2 }
|
||||||
/ fact "/" term { Div $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
|
||||||
|
|
||||||
term :: AST
|
term :: AST
|
||||||
= term "(" args ")" { Call $1 $2 }
|
= tuple
|
||||||
/ tuple
|
|
||||||
/ "(" expr ")"
|
/ "(" expr ")"
|
||||||
/ "[" listseq "]"
|
/ "[" listseq "]"
|
||||||
/ ifcond
|
/ ifcond
|
||||||
/ doblock
|
/ doblock
|
||||||
/ "true" { BoolConst True } / "false" { BoolConst False }
|
/ "true" { BoolConst True } / "false" { BoolConst False }
|
||||||
/ stringlit { StrConst $1 }
|
/ stringlit { StrConst (T.pack $1) }
|
||||||
/ integer { IntConst $1 }
|
/ integer { IntConst $1 }
|
||||||
/ identifier { Var $1 }
|
/ identifier { Var $1 }
|
||||||
|
|
||||||
|
@ -119,9 +129,10 @@ escChar :: Char
|
||||||
/ 'n' { '\n' }
|
/ 'n' { '\n' }
|
||||||
/ 'r' { '\r' }
|
/ 'r' { '\r' }
|
||||||
/ 't' { '\t' }
|
/ 't' { '\t' }
|
||||||
|
/ '0' { '\0' }
|
||||||
|
|
||||||
identifier ::: String
|
identifier ::: T.Text
|
||||||
= [a-zA-Z_] [a-zA-Z0-9_'?!]* { $1 : $2 }
|
= [a-zA-Z_] [a-zA-Z0-9_'?!]* { T.pack ($1 : $2) }
|
||||||
|
|
||||||
integer ::: Integer
|
integer ::: Integer
|
||||||
= [0-9] [0-9]* { read ($1 : $2) }
|
= [0-9] [0-9]* { read ($1 : $2) }
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
map_insert(assoc, pair) -> pair :: assoc.
|
map_insert(assoc, pair) -> pair :: assoc.
|
||||||
|
|
||||||
-- lookup by key
|
-- lookup by key
|
||||||
map_lookup([], _) -> ("nothing").
|
map_lookup([], _) -> ("nothing",).
|
||||||
map_lookup((k,v)::xs, key) ->
|
map_lookup((k,v)::xs, key) ->
|
||||||
if k == key then ("just", v)
|
if k == key then ("just", v)
|
||||||
else map_lookup(xs, key).
|
else map_lookup(xs, key).
|
||||||
|
@ -21,5 +21,5 @@ m = map_insert(m, ("ready", "go")).
|
||||||
print(m).
|
print(m).
|
||||||
print(map_remove(m, "k")).
|
print(map_remove(m, "k")).
|
||||||
("just", x) = map_lookup(m, "hi").
|
("just", x) = map_lookup(m, "hi").
|
||||||
("nothing") = map_lookup(m, "foo").
|
("nothing",) = map_lookup(m, "foo").
|
||||||
print(x).
|
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