10 changed files with 14 additions and 313 deletions
--- a/AST.hs
+++ b/AST.hs
@ -13,10 +13,6 @@ data AST = Add AST AST
 		 | NotEquals AST AST
 		 | LessThan AST AST
 		 | GreaterThan AST AST
-		 | BitAnd AST AST
-		 | BitOr AST AST
-		 | BitNot AST
-		 | BitShift AST AST Bool
 		 | Block [AST]
 		 | FunDef T.Text (Pattern, AST)
 		 | Defun T.Text AST
@ -41,4 +37,4 @@ data Pattern = VarP T.Text
 			 | ConsP Pattern Pattern
 			 | TupleP [Pattern]
 			 | ListP [Pattern]
-	 deriving (Show, Eq)
+	 deriving (Show, Eq)
--- a/Interp.hs
+++ b/Interp.hs
@ -3,24 +3,20 @@
 -- 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.ByteString.Char8 as BSC
 import qualified Network.Socket as SO
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 import Data.List (intercalate, foldl1')
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.Bits
 import Control.Applicative ((<$>))
 import Control.Exception (try, SomeException)
-import Control.Concurrent (ThreadId, forkIO, threadDelay, killThread)
-import Control.Concurrent.STM (atomically)
-import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put)
 import System.IO (Handle, hPutStr, hGetLine, hClose, hIsEOF, hSetBuffering,
 		hSetBinaryMode, openBinaryFile, IOMode(..), BufferMode(NoBuffering), stdout, stdin)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import System.Directory (doesFileExist)
 import System.FilePath (FilePath, splitExtension, takeBaseName, takeDirectory, (</>))
 import System.Environment (getExecutablePath)
@ -40,8 +36,7 @@ data Value = IntV Integer
 		   | TupleV [Value]
 		   | ListV [Value]
 		   | DictV (M.Map Value Value)
-		   | RefV (TVar Value)
-		   | Thread ThreadId
+		   | RefV (IORef Value)
 		   | Builtin BIF
 		   | FnV Env [(Pattern, AST)] -- closure pattern->body bindings
 		   deriving (Eq)
@ -88,7 +83,6 @@ instance Show Value where
 	show (StreamV _) = "<stream>"
 	show (Builtin _) = "<built-in>"
 	show (RefV _) = "<ref>"
-	show (Thread t) = "<thread " ++ show t ++ ">"

 -- value operators
 (IntV l) +$ (IntV r) = IntV (l + r)
@ -111,21 +105,6 @@ 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)

@ -149,9 +128,6 @@ _fgetline (StreamV handle) = do
 _freadbytes (TupleV [StreamV handle, IntV n]) = do
 	liftIO $ StrV . T.take (fromIntegral n) <$> TIO.hGetContents handle

-_freadcontents (StreamV handle) = do
-	liftIO $ StrV <$> TIO.hGetContents handle
-
 _fopen (TupleV [StrV path, StrV mode]) = do
 	let mode' = case T.unpack mode of
 		"r" -> ReadMode
@ -184,25 +160,12 @@ _repr v = return . StrV $ T.pack $ show v
 _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
+_ref v = RefV <$> liftIO (newIORef 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
+_readRef (RefV r) = liftIO $ readIORef 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
+	liftIO (writeIORef r v) >> return v

 _loop args@(TupleV [fn@(FnV _ _), arg]) = do
 	v <- apply fn arg
@ -225,14 +188,6 @@ _eval (TupleV [code@(StrV _), (ListV 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
@ -255,8 +210,8 @@ _Import (StrV modname) = do
 	evalFile path -- evaluate the module file
 	[modenv] <- get -- get the module env
 	let [initialEnv] = initialState
-	--let modenv' = M.difference modenv initialEnv -- subtract prelude stuff
-	let mod = toDict modenv
+	let modenv' = M.difference modenv initialEnv -- subtract prelude stuff
+	let mod = toDict modenv'
 	let env' = bind env (T.pack modname) mod -- bind it
 	put env' -- restore state
 	return mod -- return module value
@ -281,8 +236,6 @@ initialState = [M.fromList $ map (\(k,v) -> (T.pack k, v)) $ [
                            ("ref!", bif _ref),
                            ("readRef!", bif _readRef),
                            ("setRef!", bif _setRef),
-                            ("time!", bif _time),
-                            ("sleep!", bif _sleep),
                            ("repr", bif _repr),
                            ("stdout", StreamV stdout),
                            ("stdin", StreamV stdin),
@ -295,20 +248,14 @@ initialState = [M.fromList $ map (\(k,v) -> (T.pack k, v)) $ [
                            ("fputbytes", bif _fputstr),
                            ("fputstr", bif _fputstr),
                            ("freadbytes", bif _freadbytes),
-                            ("freadcontents", bif _freadcontents),
                            ("feof", bif _feof),
                            ("fclose", bif _fclose),
                            ("fopen", bif _fopen),
                            ("sockopen", bif _sockopen),
                            ("itos", bif _itos),
-                            ("stoi", bif _stoi),
-			    ("ord", bif _ord),
-			    ("chr", bif _chr),
                            ("globals", bif _globals),
                            ("locals", bif _locals),
                            ("newStdEnv", bif _newStdEnv),
-                            ("thread!", bif _thread),
-                            ("kill!", bif _kill),
                            ("eval", bif _eval),
                            ("import", bif _Import)]]

@ -325,11 +272,7 @@ eval (Cons a b) = do
 	b' <- eval b
 	case b' of
 		ListV v' -> return $ ListV $ a':v'
-		StrV v' ->
-			case a' of
-				StrV c | T.length c == 1 -> return $ StrV $ T.cons (T.head c) v'
-				_ -> error "cons: LHS must be a char"
-		_ -> error "cons: RHS must be a list or string"
+		_ -> error "cons: RHS must be a list"

 eval (ListConst v) = ListV <$> mapM eval v
 eval (TupleConst v) = TupleV <$> mapM eval v
@ -380,11 +323,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
@ -485,8 +423,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 =
@ -544,4 +480,4 @@ evalFile path = do
 	else evalString contents

 evalFileV :: FilePath -> IO Value
-evalFileV = interpret . evalFile
+evalFileV = interpret . evalFile
--- a/17
+++ b/17
@ -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.
--- a/Parser.hs
+++ b/Parser.hs
@ -76,15 +76,10 @@ 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)]) }
@ -129,7 +124,6 @@ escChar :: Char
  / 'n' { '\n' }
  / 'r' { '\r' }
  / 't' { '\t' }
-  / '0' { '\0' }

 identifier ::: T.Text
  = [a-zA-Z_] [a-zA-Z0-9_'?!]* { T.pack ($1 : $2) }
--- a/lamb.cabal
+++ b/lamb.cabal
@ -5,9 +5,8 @@ author:                darkf
 build-type:            Simple
 cabal-version:         >= 1.8

-executable lamb
+executable main
  main-is:             Lamb.hs
-  build-depends:       base, peggy, containers, transformers, directory, filepath, bytestring, network, text, time, stm
+  build-depends:       base, peggy, containers, transformers, directory, filepath, bytestring, network, text
  hs-source-dirs:      .
  extensions:          DoAndIfThenElse
-  other-modules:       AST, Interp, Parser
--- a/mods/std/base64.lamb
+++ b/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.
-
--- a/mods/std/http.lamb
+++ b/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))).
--- a/mods/std/list.lamb
+++ b/mods/std/list.lamb
@ -10,17 +10,14 @@ memberOf?(x::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))
@ -29,7 +26,7 @@ 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).
+length(lst) -> foldl(\_,y -> 1 + y, 0, lst).

 filter(f, []) -> [].
 filter(f, x::xs) ->
@ -39,7 +36,6 @@ filter(f, x::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
--- a/mods/std/op.lamb
+++ b/mods/std/op.lamb
@ -15,9 +15,6 @@ 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.

--- a/mods/std/str.lamb
+++ b/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).