AST.hs

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

Interp.hs

@@ -3,27 +3,16 @@
 -- 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.Strict as M
+import qualified Data.Map as M
 import qualified Data.ByteString.Char8 as BSC
 import qualified Network.Socket as SO
-import qualified Data.Text as T
+import Data.List (intercalate)
-import qualified Data.Text.IO as TIO
+import Control.Monad.Trans (lift)
-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, hClose, hIsEOF, hSetBuffering,
+import System.IO (Handle, hPutStr, hGetLine, hFlush, hClose, hIsEOF, openBinaryFile, hSetBinaryMode, IOMode(..), stdout, stdin)
-		hSetBinaryMode, openBinaryFile, IOMode(..), BufferMode(NoBuffering), stdout, stdin)
 import System.Directory (doesFileExist)
-import System.FilePath (FilePath, splitExtension, takeBaseName, takeDirectory, (</>))
+import System.FilePath (FilePath, splitExtension, takeBaseName)
-import System.Environment (getExecutablePath)
 import AST
 import Parser (parseProgram)
 
@@ -34,14 +23,13 @@ instance Eq BIF where a == b = False
 instance Ord BIF where compare a b = if a == b then EQ else LT
 
 data Value = IntV Integer
-		   | StrV T.Text
+		   | StrV String
+		   | UnitV
 		   | BoolV Bool
-		   | StreamV Handle
+		   | StreamV Int
 		   | TupleV [Value]
 		   | ListV [Value]
 		   | DictV (M.Map Value Value)
-		   | RefV (TVar Value)
-		   | Thread ThreadId
 		   | Builtin BIF
 		   | FnV Env [(Pattern, AST)] -- closure pattern->body bindings
 		   deriving (Eq)
@@ -52,47 +40,44 @@ instance Ord Value where
 	compare (BoolV a) (BoolV b) = compare a b
 	compare (TupleV a) (TupleV b) = compare a b
 	compare (ListV a) (ListV b) = compare a b
-	compare (StreamV a) (StreamV b) = if a == b then EQ else LT
+	compare (StreamV a) (StreamV b) = compare a b
 	compare (Builtin a) (Builtin b) = compare a b
 	compare (FnV a b) (FnV x y) = if a == x && b == y then EQ else LT
 	compare (DictV a) (DictV b) = compare a b
 	compare _ _ = error "compare: not valid"
 
-type Env = [M.Map T.Text Value] -- lexical environment (linked list)
+type Env = [M.Map String Value] -- lexical environment (linked list)
-type InterpState = StateT Env IO -- interpreter state (open handles, global env)
+type InterpState = StateT ([Handle], 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 -> T.Text -> Maybe Value
+lookup :: Env -> String -> Maybe Value
 lookup [] _ = Nothing
-lookup (env:xs) name = maybe (lookup xs name) Just (M.lookup name env)
+lookup (env:xs) name =
+	case M.lookup name env of
+		Nothing -> lookup xs name
+		Just x -> Just x
 
 -- bind in the local environment
-bind :: Env -> T.Text -> Value -> Env
+bind :: Env -> String -> Value -> Env
 bind (env:xs) name value = (M.insert name value env):xs
 
 instance Show Value where
 	show (IntV i) = show i
 	show (StrV s) = show s
 	show (BoolV b) = show b
-	show (TupleV []) = "(,)"
 	show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
 	show (ListV v) = show v
 	show (DictV d) = "<dict " ++ show d ++ ">"
 	show (FnV _ _) = "<fn>"
 	show (StreamV _) = "<stream>"
 	show (Builtin _) = "<built-in>"
-	show (RefV _) = "<ref>"
+	show UnitV = "()"
-	show (Thread t) = "<thread " ++ show t ++ ">"
 
 -- value operators
 (IntV l) +$ (IntV r) = IntV (l + r)
-(StrV l) +$ (StrV r) = StrV (l `T.append` r)
+(StrV l) +$ (StrV r) = StrV (l ++ r)
 (ListV l) +$ (ListV r) = ListV (l ++ r)
 l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r
 
@@ -111,206 +96,132 @@ l <$ r = error $ "cannot < " ++ show l ++ " and " ++ show r
 (IntV l) >$ (IntV r) = BoolV (l > r)
 l >$ r = error $ "cannot > " ++ show l ++ " and " ++ show r
 
-(IntV l) &$ (IntV r) = IntV (l .&. r)
-l &$ r = error $ "cannot & " ++ show l ++ " and " ++ show r
-
-(IntV l) |$ (IntV r) = IntV (l .|. r)
-l |$ r = error $ "cannot | " ++ show l ++ " and " ++ show r
-
-(IntV l) <<$ (IntV r) = IntV (l `shiftL` fromInteger r)
-l <<$ r = error $ "cannot << " ++ show l ++ " and " ++ show r
-
-(IntV l) >>$ (IntV r) = IntV (l `shiftR` fromInteger r)
-l >>$ r = error $ "cannot >> " ++ show l ++ " and " ++ show r
-
-bitNot (IntV v) = IntV (complement v)
-bitNot v = error $ "cannot ~ " ++ show v
-
 l ==$ r = BoolV (l == r)
 l !=$ r = BoolV (l /= r)
 
-toDict :: StrDict -> Value
-toDict m = DictV (M.mapKeys StrV m) -- wrap keys in StrV
-
-fromDict :: ValueDict -> StrDict
-fromDict m = M.mapKeys (\(StrV k) -> k) m -- unwrap keys
-
 -- some built-in functions
 
-_fputstr (TupleV [StreamV handle, StrV str]) =
+_fputbytes (TupleV [StreamV h, StrV str]) = do
-	liftIO $ TIO.hPutStr handle str >> return unitv
+	(handles,_) <- get
+	let handle = handles !! h
+	io <- lift $ hPutStr handle str >> hFlush handle
+	return UnitV
 
-_fgetline (StreamV handle) = do
+_fputstr (TupleV [StreamV h, StrV str]) = do
-	str <- liftIO $ TIO.hGetLine handle
+	(handles,_) <- get
-	if T.last str == '\r' then -- remove trailing CR
+	let handle = handles !! h
-		return . StrV $ T.init str
+	io <- lift $ hPutStr handle str >> hFlush handle
+	return UnitV
+
+_fgetline (StreamV h) = do
+	(handles,_) <- get
+	let handle = handles !! h
+	str <- lift $ hGetLine handle
+	if last str == '\r' then -- remove trailing CR
+		return . StrV $ init str
 	else return $ StrV str
 
-_freadbytes (TupleV [StreamV handle, IntV n]) = do
+_freadbytes (TupleV [StreamV h, IntV n]) = do
-	liftIO $ StrV . T.take (fromIntegral n) <$> TIO.hGetContents handle
+	(handles,_) <- get
-
+	let handle = handles !! h
-_freadcontents (StreamV handle) = do
+	str <- lift $ BSC.hGet handle (fromIntegral n :: Int)
-	liftIO $ StrV <$> TIO.hGetContents handle
+	return . StrV $ BSC.unpack str
 
 _fopen (TupleV [StrV path, StrV mode]) = do
-	let mode' = case T.unpack mode of
+	(handles,env) <- get
+	let mode' = case mode of
 		"r" -> ReadMode
 		"w" -> WriteMode
 		"rw" -> ReadWriteMode
-	StreamV <$> liftIO (openBinaryFile (T.unpack path) mode')
+	handle <- lift $ openBinaryFile path mode'
+	put (handles ++ [handle], env)
+	return . StreamV $ length handles
 
-_feof (StreamV handle) = do
+_feof (StreamV h) = do
-	BoolV <$> liftIO (hIsEOF handle)
+	(handles,_) <- get
+	let handle = handles !! h
+	isEof <- lift $ hIsEOF handle
+	return $ BoolV isEof
 
-_fclose (StreamV handle) = do
+_fclose handle@(StreamV h) = do
-	liftIO (hClose handle) >> return unitv
+	(handles,_) <- get
+	let handle = handles !! h
+	lift $ hClose handle
+	return UnitV
 
 _sockopen (TupleV [StrV host, IntV port]) = do
-	liftIO $ SO.withSocketsDo $ do
+	(handles,env) <- get
-		addr:_ <- SO.getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port)
+	handle <- lift $ SO.withSocketsDo $ do
+		addr:_ <- SO.getAddrInfo Nothing (Just host) (Just $ show port)
 		sock <- SO.socket (SO.addrFamily addr) SO.Stream SO.defaultProtocol
 		SO.connect sock (SO.addrAddress addr)
 		handle <- SO.socketToHandle sock ReadWriteMode
-		hSetBuffering handle NoBuffering
+		return handle
-		return $ StreamV handle
+	put (handles ++ [handle], env)
+	return . StreamV $ length handles
 
-_putstr str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
+_putstr str@(StrV _) = _fputstr $ TupleV [StreamV 0, str]
-_putbytes str@(StrV _) = _fputstr $ TupleV [StreamV stdout, str]
+_putbytes str@(StrV _) = _fputbytes $ TupleV [StreamV 0, str]
-_getline (TupleV []) = _fgetline (StreamV stdin)
+_getline UnitV = _fgetline (StreamV 1)
 
-_print v = _putbytes $ StrV $ T.pack (show v) `T.snoc` '\n'
+_print v = _putbytes $ StrV $ show v ++ "\n"
-_repr v = return . StrV $ T.pack $ show v
+_repr v = return . StrV $ show v
 
-_itos (IntV i) = return $ StrV $ T.pack $ show i
+_itos (IntV i) = return $ StrV $ show i
 _itos v = error $ "itos: not an int: " ++ show v
 
-_stoi (StrV s) = return $ IntV $ read $ T.unpack s
-_stoi v = error $ "stoi: not a string: " ++ show v
-
-_ord (StrV s) = return $ IntV $ toInteger $ fromEnum $ T.head s
-_ord v = error $ "ord: not a string: " ++ show v
-
-_chr (IntV i) = return $ StrV $ T.singleton (toEnum (fromInteger i) :: Char)
-_chr v = error $ "chr: not an integer: " ++ show v
-
-_ref v = RefV <$> liftIO (newTVarIO v)
-
-_readRef (RefV r) = liftIO $ atomically $ readTVar r
-
-_setRef (TupleV [RefV r, v]) =
-	liftIO (atomically $  writeTVar r v) >> return v
-
-_time (TupleV []) = fmap IntV $ liftIO $ round <$> getPOSIXTime
-
-_sleep (IntV milliseconds) = liftIO (threadDelay (fromInteger $ 1000 * milliseconds)) >> return unitv
-
 _loop args@(TupleV [fn@(FnV _ _), arg]) = do
 	v <- apply fn arg
 	if v /= BoolV False then
 		_loop $ TupleV [fn, v]
 	else return arg
 
-_eval (TupleV [StrV code, DictV env]) = do
-	let trySome :: IO a -> IO (Either SomeException a)
-	    trySome = try
-	    state = [fromDict env]
-	ret <- liftIO . trySome $ evalStateT (evalString code) state
-	case ret of
-		Left err -> return $ TupleV [StrV (T.pack "err"), StrV $ T.pack (show err)]
-		Right v -> return v
-
-_eval (TupleV [code@(StrV _), (ListV env)]) =
-	let env' = map (\(TupleV [k,v]) -> (k,v)) env in
-	_eval (TupleV [code, DictV $ M.fromList env'])
-
-_eval _ = error "eval: invalid args (want code and environment)"
-
-_thread f@FnV{} = do
-	state <- get
-	fmap Thread $ liftIO $ forkIO $ (evalStateT (apply f unitv) state >> return ())
-_thread _ = error "thread!: need a function"
-
-_kill (Thread thread) = liftIO (killThread thread) >> return unitv
-_kill _ = error "kill!: need a thread"
-
--- returns a dictionary of a new environment with only the standard 
--- default-imported functions
-_newStdEnv (TupleV []) = do
-	let [stdEnv] = initialState
-	return $ toDict stdEnv
-
-_globals (TupleV []) = do
-	env <- get
-	return $ toDict (last env)
-
-_locals (TupleV []) = do
-	locals:_ <- get
-	return $ toDict locals
-
 -- import a module name as a module
 _Import (StrV modname) = do
-	env <- get -- save current state
+	(h,env) <- get -- save current state
 	put initialState
-	(path,modname) <- liftIO $ findModule $ T.unpack modname -- find the module file
+	(path,modname) <- lift $ findModule modname -- find the module file
 	evalFile path -- evaluate the module file
-	[modenv] <- get -- get the module env
+	(_,[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
-	let mod = toDict modenv
+	-- convert String to StrV in env keys
-	let env' = bind env (T.pack modname) mod -- bind it
+	let modenv'' = map (\(k,v) -> (StrV k, v)) $ M.toAscList modenv'
-	put env' -- restore state
+	let mod = DictV (M.fromAscList modenv'') -- package module into a dict
+	let env' = bind env modname mod -- bind it
+	put (h,env') -- restore state
 	return mod -- return module value
 	
 	where
 		findModule :: FilePath -> IO (FilePath, String)
 		findModule modname = do
-			execPath <- fmap takeDirectory getExecutablePath
+			let path = modname ++ ".lamb"
-			findModuleIn [".", execPath </> "mods"] -- search paths for modules
+			exists <- doesFileExist path
-			where
+			if exists then
-				findModuleIn [] = error $ "module " ++ modname ++ " couldn't be found"
+				return (path, takeBaseName path)
-				findModuleIn (dir:xs) = do
+			else error $ "module " ++ modname ++ " couldn't be found"
-					let path = dir </> modname ++ ".lamb"
-					exists <- doesFileExist path
-					if exists then return (path, takeBaseName path)
-					else findModuleIn xs
 
-bif = Builtin . BIF
+initialState = ([stdout, stdin],
-initialState = [M.fromList $ map (\(k,v) -> (T.pack k, v)) $ [
+					[M.fromList [("id", FnV emptyEnv [(VarP "x", Var "x")]),
-                            ("id", FnV emptyEnv [(VarP (T.pack "x"), Var (T.pack "x"))]),
+								("loop", Builtin $ BIF _loop),
-                            ("loop", bif _loop),
+						   		("repr", Builtin $ BIF _repr),
-                            ("ref!", bif _ref),
+						   		("stdout", StreamV 0),
-                            ("readRef!", bif _readRef),
+						   		("stdin", StreamV 1),
-                            ("setRef!", bif _setRef),
+						   		("print", Builtin $ BIF _print),
-                            ("time!", bif _time),
+						   		("putstr", Builtin $ BIF _putstr),
-                            ("sleep!", bif _sleep),
+						   		("putstrln", Builtin $ BIF (\x -> _putstr $ x +$ StrV "\n")),
-                            ("repr", bif _repr),
+						   		("getline", Builtin $ BIF _getline),
-                            ("stdout", StreamV stdout),
+						   		("fgetline", Builtin $ BIF _fgetline),
-                            ("stdin", StreamV stdin),
+						   		("putbytes", Builtin $ BIF _putbytes),
-                            ("print", bif _print),
+						   		("fputbytes", Builtin $ BIF _fputbytes),
-                            ("putstr", bif _putstr),
+						   		("fputstr", Builtin $ BIF _fputstr),
-                            ("putstrln", bif (\x -> _putstr $ x +$ StrV (T.singleton '\n'))),
+						   		("freadbytes", Builtin $ BIF _freadbytes),
-                            ("getline", bif _getline),
+						   		("feof", Builtin $ BIF _feof),
-                            ("fgetline", bif _fgetline),
+						   		("fclose", Builtin $ BIF _fclose),
-                            ("putbytes", bif _putbytes),
+						   		("fopen", Builtin $ BIF _fopen),
-                            ("fputbytes", bif _fputstr),
+						   		("sockopen", Builtin $ BIF _sockopen),
-                            ("fputstr", bif _fputstr),
+						   		("itos", Builtin $ BIF _itos),
-                            ("freadbytes", bif _freadbytes),
+						   		("import", Builtin $ BIF _Import)]])
-                            ("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
 
@@ -318,6 +229,8 @@ eval (IntConst i) = return $ IntV i
 eval (StrConst s) = return $ StrV s
 eval (BoolConst b) = return $ BoolV b
 
+eval UnitConst = return UnitV
+
 eval (Block body) = foldr1 (>>) $ map eval body
 
 eval (Cons a b) = do
@@ -325,14 +238,13 @@ eval (Cons a b) = do
 	b' <- eval b
 	case b' of
 		ListV v' -> return $ ListV $ a':v'
-		StrV v' ->
+		_ -> error "cons: RHS must be a list"
-			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) = ListV <$> mapM eval v
+eval (ListConst v) =
-eval (TupleConst v) = TupleV <$> mapM eval v
+	mapM eval v >>= \xs ->
+		return $ ListV xs
+
+eval (TupleConst v) = mapM eval v >>= return . TupleV
 
 eval (IfExpr c t e) = eval c >>= \cond ->
 	case cond of
@@ -340,35 +252,37 @@ eval (IfExpr c t e) = eval c >>= \cond ->
 		BoolV False -> eval e
 		_ -> error "if: condition must be a boolean"
 
-eval (Var var) = get >>= \env ->
+eval (Var var) = get >>= \(_,env) ->
-	maybe (error $ "unbound variable " ++ T.unpack var) return (lookup env var)
+  case lookup env var of
+    Just v -> return v
+    Nothing -> error $ "unbound variable " ++ var
 
 eval (Defun name fn) = do
-	env <- get
+	(s,env) <- get
 	case lookup env name of
             Nothing -> -- bind new fn
                     eval fn >>= \fn' ->
-                    	put (bind env name fn') >> return fn'
+                    	put (s, bind env name fn') >> return fn'
             Just oldfn -> -- add pattern to old fn
                     let FnV cls oldpats = oldfn
                         Lambda [(pat, body)] = fn
                         newfn = FnV cls (oldpats ++ [(pat, body)]) in
-                        put (bind env name newfn) >> return newfn
+                        put (s, bind env name newfn) >> return newfn
 
 eval (Def pat v') = do
 	v <- eval v'
-	locals:xs <- get
+	(s,locals:xs) <- get
 	case patternBindings pat v of
 		Nothing -> error $ "pattern binding doesn't satisfy: " ++ show v ++ " with " ++ show pat
-		Just bindings -> do
+		Just bindings ->
-			put $ (M.union bindings locals):xs -- update our local bindings
+			put (s, (M.union bindings locals):xs) >> -- update our local bindings
 			return v
 
-eval (Lambda pats) = do
+eval (Lambda pats) =
-	env <- get
+	get >>= \(_,env) ->
-	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 }
@@ -380,11 +294,6 @@ eval (NotEquals l r) = do { l <- eval l; r <- eval r; return $ l !=$ r }
 eval (LessThan l r) = do { l <- eval l; r <- eval r; return $ l <$ r }
 eval (GreaterThan l r) = do { l <- eval l; r <- eval r; return $ l >$ r }
 
-eval (BitAnd l r) = do { l <- eval l; r <- eval r; return $ l &$ r }
-eval (BitOr l r) = do { l <- eval l; r <- eval r; return $ l |$ r }
-eval (BitShift l r dir) = do { l <- eval l; r <- eval r; return $ (if dir then (<<$) else (>>$)) l r }
-eval (BitNot v) = do { v <- eval v; return $ bitNot v }
-
 eval (Access left (Var right)) = do
 	lhs <- eval left
 	case lhs of
@@ -393,30 +302,30 @@ eval (Access left (Var right)) = do
 				Just (FnV [] fn) -> -- use the module's global scope
 					return $ FnV (mapToEnv dict) fn
 				Just v -> return v
-				Nothing -> return $ TupleV [StrV (T.pack "nothing")]
+				Nothing -> return $ TupleV [StrV "nothing"]
 		_ -> error $ "op/: need a dict, got " ++ show lhs
 	where
 		mapToEnv :: M.Map Value Value -> Env
-		mapToEnv m = [fromDict m]
+		mapToEnv m = [M.fromAscList $ map (\(StrV k,v) -> (k,v)) (M.toAscList m)]
 eval (Access _ _) = error "op/: RHS must be an identifier"
 
 eval (Call lhs arg) = do
-	env <- get
+	(h,env) <- get
 	v <- eval lhs
 	case v of
 	  fn@(FnV cls _) -> do
 	  	arg' <- eval arg
 	  	let cls' = if cls == [] then [last env] else cls -- if [], use current global env
-	  	put cls' -- enter closure env
+	  	put (h,cls') -- enter closure env
 	  	v <- apply fn arg'
-	  	put env -- restore env
+	  	put (h,env) -- restore env
 	  	return v
 	  fn@(Builtin _) -> eval arg >>= apply fn
 	  _ -> error $ "call: " ++ show v ++ " is not a function"
 
 eval x = error $ "eval: unhandled: " ++ show x
 
-patternBindings :: Pattern -> Value -> Maybe (M.Map T.Text Value)
+patternBindings :: Pattern -> Value -> Maybe (M.Map String Value)
 patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
 
 patternBindings (IntP n) (IntV v)
@@ -428,31 +337,27 @@ patternBindings (BoolP b) (BoolV v)
 	| v == b = Just M.empty
 	| otherwise = Nothing
 
+patternBindings UnitP UnitV = Just M.empty
+patternBindings UnitP _ = Nothing
+
 patternBindings (StrP x) (StrV y)
 	| x == y = Just M.empty
 	| otherwise = Nothing
 patternBindings (StrP _) _ = Nothing
 
 -- cons on strings
--- x:[] matches with y:""
+patternBindings (ConsP x (ListP [])) (StrV (y:[])) = patternBindings x (StrV [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 = T.length xp in
+	let len = length xp in
-	if T.take len str == xp then -- matches
+	if take len str == xp then -- matches
-		patternBindings xsp $ StrV (T.drop len str) -- match the rest of the string
+		patternBindings xsp $ StrV (drop len str) -- match the rest of the string
 	else Nothing -- no match
-patternBindings (ConsP xp xsp) (StrV str) =
+patternBindings (ConsP xp xsp) (StrV (x:xs)) =
-	case T.uncons str of
+	do
-		Just (x, xs) -> do
+		xe <- patternBindings xp (StrV [x])
-			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
 patternBindings (ConsP x (ListP [])) (ListV (y:[])) = patternBindings x y
@@ -485,8 +390,6 @@ patternBindings (TupleP (x:xs)) (TupleV (y:ys)) =
 		Just $ M.union env' env
 patternBindings (TupleP _) _ = Nothing -- not a tuple
 
-patternBindings p x = error $ "patternBindings failure: matching " ++ show x ++ " with pattern " ++ show p
-
 -- applies a function
 apply :: Value -> Value -> InterpState Value
 apply (FnV _ pats) arg =
@@ -497,9 +400,9 @@ apply (FnV _ pats) arg =
 			case patternBindings pat arg of
 				Just bindings -> -- satisfies
 					do
-						env <- get
+						(s,env) <- get
 						let newenv = bindings:env
-						put newenv
+						put (s, newenv)
 						eval body
 				Nothing -> -- doesn't satisfy this pattern
 					apply' xs
@@ -508,21 +411,16 @@ apply (Builtin (BIF fn)) arg = fn arg
 
 -- some helper programs for evaluation
 
--- sets up stdin/stdout for binary mode and makes them unbuffered
+-- sets up stdin/stdout for binary mode
 initIO :: IO ()
 initIO = do
        hSetBinaryMode stdin True
        hSetBinaryMode stdout True
-       hSetBuffering stdout NoBuffering
-
--- Takes an interpreter state and evaluates it with the empty initial state.
-interpret :: InterpState a -> IO a
-interpret state = evalStateT state initialState
 
 evalProgram :: [AST] -> InterpState Value
-evalProgram nodes = foldl1' (>>) $ map eval nodes
+evalProgram nodes = foldr1 (>>) $ map eval nodes
 
-evalString :: T.Text -> InterpState Value
+evalString :: String -> InterpState Value
 evalString program =
 	case parseProgram program of
 		Left err -> error $ show err
@@ -533,15 +431,15 @@ isLiterate path = snd (splitExtension path) == ".lilamb"
 
 -- Takes the lines of a literate program and returns the lines for a new executable program
 -- from lines beginning with four spaces.
-parseLiterate :: [T.Text] -> [T.Text]
+parseLiterate :: [String] -> [String]
-parseLiterate lns = [T.drop 4 line | line <- lns, T.take 4 line == T.pack "    "]
+parseLiterate lns = [drop 4 line | line <- lns, take 4 line == "    "]
 
 evalFile :: FilePath -> InterpState Value
 evalFile path = do
-	contents <- liftIO $ if path == "-" then TIO.getContents else TIO.readFile path
+	contents <- lift $ if path == "-" then getContents else readFile path
 	if isLiterate path then
-		evalString . T.unlines . parseLiterate . T.lines $ contents
+		evalString . unlines . parseLiterate . lines $ contents
 	else evalString contents
 
 evalFileV :: FilePath -> IO Value
-evalFileV = interpret . evalFile
+evalFileV path = evalStateT (evalFile path) initialState

LICENSE

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

Lamb.hs

@@ -5,46 +5,22 @@
 import System.Environment (getArgs)
 import System.Directory (doesFileExist)
 import System.FilePath (FilePath, splitExtension)
-import Control.Applicative ((<$>))
+import Interp (evalFileV, initIO, Value(UnitV))
-import Control.Monad (filterM)
-import Control.Monad.IO.Class (liftIO)
-import Parser (parseProgram)
-import Interp (evalFileV, evalProgram, initIO, interpret, InterpState, Value)
 
-exists :: FilePath -> IO Bool
+-- returns Nothing if all files exist, or Just path for the first one that doesn't
-exists "-" = return True
+allExist :: [FilePath] -> IO (Maybe FilePath)
-exists path = not <$> doesFileExist path
+allExist [] = return Nothing
-
+allExist ("-":xs) = allExist xs
-findMissing :: [FilePath] -> IO [FilePath]
+allExist (x:xs) = do
-findMissing = filterM exists
+	exists <- doesFileExist x
-
+	if exists then allExist xs
-repl :: InterpState Value
+	else return $ Just x
-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
-	if null args
+	exist <- allExist args
-	then do -- no arguments, launch REPL
+	case exist of
-		initIO
+		Just file -> putStrLn $ "error: file " ++ file ++ " doesn't exist"
-		repl'
+		Nothing ->
-	else do
+			initIO >>
-		missing <- findMissing args
+			mapM_ evalFileV 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,9 +1,7 @@
 {-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}
 
 module Parser where
-import Data.Maybe (fromMaybe)
 import Text.Peggy hiding (space)
-import qualified Data.Text as T
 import AST
 
 [peggy|
@@ -23,7 +21,9 @@ semistatements :: [AST]
 
 args :: AST
   = expr ("," expr)+ { TupleConst ($1 : $2) }
-  / expr? { fromMaybe (TupleConst []) $1 } 
+  / expr? { case $1 of
+  				Just x -> x
+  				Nothing -> UnitConst }
 
 patternlist :: Pattern
   = pattern ("," pattern)+ { ListP ($1 : $2) }
@@ -42,12 +42,14 @@ pattern :: Pattern
   / patterntuple
   / "true" { BoolP True } / "false" { BoolP False }
   / identifier { VarP $1 }
-  / stringlit { StrP (T.pack $1) }
+  / stringlit { StrP $1 }
   / integer { IntP $1 }
 
 funpattern :: Pattern
   = pattern ("," pattern)+ { TupleP ($1 : $2) }
-  / pattern? { fromMaybe (TupleP []) $1 }
+  / pattern? { case $1 of
+  					Just x -> x
+  					Nothing -> UnitP }
 
 listseq :: AST
   = expr ("," expr)+ { ListConst ($1 : $2) }
@@ -76,41 +78,29 @@ expr :: AST
   = expr "::" expr { Cons $1 $2 }
   / expr "+" fact { Add $1 $2 }
   / expr "-" fact { Sub $1 $2 }
-  / expr "&" fact { BitAnd $1 $2 }
-  / expr "|" fact { BitOr $1 $2 }
-  / expr "<<" fact { BitShift $1 $2 True }
-  / expr ">>" fact { BitShift $1 $2 False }
   / expr "==" fact { Equals $1 $2 }
   / expr "!=" fact { NotEquals $1 $2 }
   / expr "<" fact { LessThan $1 $2 }
   / expr ">" fact { GreaterThan $1 $2 }
-  / "~" expr { BitNot $1 }
   / def
   / lambda
   / identifier "(" funpattern ")" "->" expr { Defun $1 (Lambda [($2, $3)]) }
   / fact
 
 fact :: AST
-  = fact "*" call { Mul $1 $2 }
+  = fact "*" term { Mul $1 $2 }
-  / fact "/" call { Div $1 $2 }
+  / fact "/" term { Div $1 $2 }
-  / call
-
-call :: AST
-  = call "(" args ")" { Call $1 $2 }
-  / access
-
-access :: AST
-  = access "\\" identifier { Access $1 (Var $2) }
   / term
 
 term :: AST
-  = tuple
+  = term "(" args ")" { Call $1 $2 }
+  / tuple
   / "(" expr ")"
   / "[" listseq "]"
   / ifcond
   / doblock
   / "true" { BoolConst True } / "false" { BoolConst False }
-  / stringlit { StrConst (T.pack $1) }
+  / stringlit { StrConst $1 }
   / integer { IntConst $1 }
   / identifier { Var $1 }
 
@@ -129,10 +119,9 @@ escChar :: Char
   / 'n' { '\n' }
   / 'r' { '\r' }
   / 't' { '\t' }
-  / '0' { '\0' }
 
-identifier ::: T.Text
+identifier ::: String
-  = [a-zA-Z_] [a-zA-Z0-9_'?!]* { T.pack ($1 : $2) }
+  = [a-zA-Z_] [a-zA-Z0-9_'?!]* { $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

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

lamb.cabal

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

mods/std/base64.lamb

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

mods/std/basic.lamb

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

mods/std/http.lamb

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

mods/std/list.lamb

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

mods/std/math.lamb

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

mods/std/op.lamb

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

mods/std/str.lamb

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