Fix somehow-missing LICENSE with zlib license text

Generalised the allExist function to findMissing.

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,30 +13,32 @@ 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)
+		 | FunDef T.Text (Pattern, AST)
-		 | Defun String 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]
-	 deriving (Show, Eq)
+	 deriving (Show, Eq)

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 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 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 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
+		   | StrV T.Text
-		   | UnitV
 		   | 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 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]
+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 =
+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 :: 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
+_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
 
-_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
-	(handles,env) <- get
+	let mode' = case T.unpack mode of
-	let mode' = case mode of
 		"r" -> ReadMode
 		"w" -> WriteMode
 		"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
-	(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
 		SO.connect sock (SO.addrAddress addr)
 		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
 
+_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
+	[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
 	
 	where
 		findModule :: FilePath -> IO (FilePath, String)
 		findModule modname = do
-			let path = modname ++ ".lamb"
+			execPath <- fmap takeDirectory getExecutablePath
-			exists <- doesFileExist path
+			findModuleIn [".", execPath </> "mods"] -- search paths for modules
-			if exists then
+			where
-				return (path, takeBaseName path)
+				findModuleIn [] = error $ "module " ++ modname ++ " couldn't be found"
-			else 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],
+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
 
@@ -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) =
+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 ->
 	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) ->
+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
-	(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 ->
+		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
 
-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
 
 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
+	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
-patternBindings (ConsP xp xsp) (StrV (x:xs)) =
+patternBindings (ConsP xp xsp) (StrV str) =
-	do
+	case T.uncons str of
-		xe <- patternBindings xp (StrV [x])
+		Just (x, xs) -> do
-		xse <- patternBindings xsp $ StrV xs
+			xe <- patternBindings xp (StrV $ T.singleton x)
-		Just $ M.union xe xse
+			xse <- patternBindings xsp $ StrV xs
+			Just $ M.union xe xse
+		_ -> Nothing
 
 -- cons on lists
 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 :: [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 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

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.

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
+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
 	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
-			mapM_ evalFileV args
+		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

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
+  / expr? { fromMaybe (TupleConst []) $1 } 
-  				Just x -> x
-  				Nothing -> UnitConst }
 
 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
+  / pattern? { fromMaybe (TupleP []) $1 }
-  					Just x -> x
-  					Nothing -> UnitP }
 
 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 "*" 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 :: 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
+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
   = [0-9] [0-9]* { read ($1 : $2) }

examples/association_list.lamb

@@ -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).

examples/ref.lamb

@@ -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

lamb.cabal

@@ -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

mods/std/base64.lamb

@@ -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.
+

mods/std/basic.lamb

@@ -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)).

mods/std/http.lamb

@@ -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))).

mods/std/list.lamb

@@ -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).

mods/std/math.lamb

@@ -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.

mods/std/op.lamb

@@ -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.

mods/std/str.lamb

@@ -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).