Fix somehow-missing LICENSE with zlib license text

AST.hs

@@ -13,6 +13,10 @@ 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
@@ -37,4 +41,4 @@ data Pattern = VarP T.Text
 			 | ConsP Pattern Pattern
 			 | TupleP [Pattern]
 			 | ListP [Pattern]
-	 deriving (Show, Eq)
+	 deriving (Show, Eq)

Interp.hs

@@ -3,20 +3,24 @@
 -- 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)
@@ -36,7 +40,8 @@ data Value = IntV Integer
 		   | TupleV [Value]
 		   | ListV [Value]
 		   | DictV (M.Map Value Value)
-		   | RefV (IORef Value)
+		   | RefV (TVar Value)
+		   | Thread ThreadId
 		   | Builtin BIF
 		   | FnV Env [(Pattern, AST)] -- closure pattern->body bindings
 		   deriving (Eq)
@@ -83,6 +88,7 @@ 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)
@@ -105,6 +111,21 @@ 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)
 
@@ -128,6 +149,9 @@ _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
@@ -160,12 +184,25 @@ _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
 
-_ref v = RefV <$> liftIO (newIORef v)
+_stoi (StrV s) = return $ IntV $ read $ T.unpack s
+_stoi v = error $ "stoi: not a string: " ++ show v
 
-_readRef (RefV r) = liftIO $ readIORef r
+_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 (writeIORef r v) >> return 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
@@ -188,6 +225,14 @@ _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
@@ -210,8 +255,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
@@ -236,6 +281,8 @@ 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),
@@ -248,14 +295,20 @@ 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)]]
 
@@ -272,7 +325,11 @@ 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) = ListV <$> mapM eval v
 eval (TupleConst v) = TupleV <$> mapM eval v
@@ -323,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
@@ -423,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 =
@@ -480,4 +544,4 @@ evalFile path = do
 	else evalString contents
 
 evalFileV :: FilePath -> IO Value
-evalFileV = interpret . evalFile
+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.

Parser.hs

@@ -76,10 +76,15 @@ 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)]) }
@@ -124,6 +129,7 @@ escChar :: Char
   / 'n' { '\n' }
   / 'r' { '\r' }
   / 't' { '\t' }
+  / '0' { '\0' }
 
 identifier ::: T.Text
   = [a-zA-Z_] [a-zA-Z0-9_'?!]* { T.pack ($1 : $2) }

lamb.cabal

@@ -5,8 +5,9 @@ author:                darkf
 build-type:            Simple
 cabal-version:         >= 1.8
 
-executable main
+executable lamb
   main-is:             Lamb.hs
-  build-depends:       base, peggy, containers, transformers, directory, filepath, bytestring, network, text
+  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/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

@@ -10,14 +10,17 @@ 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))
@@ -26,7 +29,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) ->
@@ -36,6 +39,7 @@ 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

mods/std/op.lamb

@@ -15,6 +15,9 @@ 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.
 

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