1.0 Release!

Added standard leeb !

Stdleeb contains a lot of the usual delicious Lisp functionality such as
the various breeds of _fold_, _map_ and _filter_, _reduce_. As well as
some true hotness in the form of _curry_ and _apply_. I've left off the
pile of _cdddddr_ and _caaaadr_ functions for the time being.

Author: mankyKitty

README.md

@@ -34,14 +34,19 @@ car, cdr, and friends are there. As well as _cons_, _if_, _cond_, _case_, a whol
 
 ### UPDATES
 
-- 01/11/2013 Added support for loading text files as source files and the following file functions:
--- ```open-input-file```
--- ```open-output-file```
--- ```close-input-port```
--- ```close-output-port```
--- ```read```
--- ```write```
--- ```read-contents```
--- ```read-all```
+- 01/11/2013 ADDED A STANDARD LIBRARY! OMG!! This was incredibly exciting. Now it really feels like a Lisp! (There is even closure support and everything. o.O). After pulling the cord on the REPL just run the following ```(load "leebs/stdleeb.leesp")``` or ```path/to/leeb/stdleeb.leesp``` and you should have everything in the stdleeb!
+- 01/11/2013 Added support for loading text files as source files and the following file functions:```open-input-file```, ```open-output-file```, ```close-input-port```, ```close-output-port```, ```read```, ```write```, ```read-contents```, ```read-all```.
 - 01/11/2013 Added the ability to create and store functions using ```define``` and ```lambda```.
 - 31/10/2013 Added persistent variables from scheme, namely: ```define``` and ```set!```.
+
+## TODO
+
+* Add concurrency and parallel processing primitives (__selfTodo__: read Hoare's CSP paper, Actor Model papers, learn more Erlang)
+* MACROS! Yeah that's right.. I went there.
+* add granular imports for leeb functionality (only, except)
+* try to implement more leebrary support (include, import, require)
+* add load process for REPL to include files (like stdleeb)
+* make it emit compilable code (ooooooo!)
+* clean up the core source
+* add support for comments. This is inexplicably annoying.
+* ~~add standard library~~

leebs/stdleeb.leesp

@@ -0,0 +1,100 @@
+(define (not x) (if x #f #t))
+(define (null? obj) (if (eqv? obj '()) #t #f))
+(define (list . objs) objs)
+(define (id x) x)
+(define (curry func arg1) (lambda (arg) (func arg1 arg)))
+(define zero? (curry = 0))
+(define positive? (curry < 0))
+(define negative? (curry > 0))
+(define (odd? num) (= (mod num 2) 1))
+(define (even? num) (= (mod num 2) 0))
+
+(define (flip func)
+  (lambda (arg1 arg2)
+    (func arg2 arg1)))
+
+(define (compose f g)
+  (lambda (arg)
+    (f (g arg))))
+
+(define (sum . lst)
+  (fold + 0 lst))
+
+(define (product . lst)
+  (fold * 1 lst))
+
+(define (and . lst)
+  (fold && #t lst))
+
+(define (or . lst)
+  (fold || #f lst))
+
+(define (max first . num-list)
+  (fold
+    (lambda (old new) (if (> old new) old new))
+    first
+    num-list))
+
+(define (min first . num-list)
+  (fold
+    (lambda (old new) (if (< old new) old new))
+    first
+    num-list))
+
+(define (length lst)
+  (fold
+    (lambda (x y) (+ x 1))
+    0
+    lst))
+
+(define (reverse lst)
+  (fold (flip cons) '() lst))
+
+(define (mem-helper pred op)
+  (lambda (acc next)
+    (if (and (not acc)
+      (pred (op next)))
+    next
+    acc)))
+
+(define (memq obj lst)
+  (fold (mem-helper (curry eq? obj) id) #f lst))
+
+(define (memv obj lst)
+  (fold (mem-helper (curry eqv? obj) id) #f lst))
+
+(define (member obj lst)
+  (fold (mem-helper (curry equal? obj) id) #f lst))
+
+(define (assq obj alist)
+  (fold (mem-helper (curry eqv? obj) car) #f alist))
+
+(define (assv obj alist)
+  (fold (mem-helper (curry eqv? obj) car) #f alist))
+
+(define (assoc obj alist)
+  (fold (mem-helper (curry equal? obj) car) #f alist))
+
+(define (map func lst)
+  (foldr (lambda (x y) (cons (func x) y)) '() lst))
+
+(define (filter pred lst)
+  (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
+
+(define (foldr func end lst)
+  (if (null? lst)
+    end
+    (func (car lst) (foldr func end (cdr lst)))))
+
+(define (foldl func accum lst)
+  (if (null? lst)
+    accum
+    (foldl func (func accum (car lst)) (cdr lst))))
+
+(define (unfold func init pred)
+  (if (pred init)
+    (cons init '())
+    (cons init (unfold func (func init) pred))))
+
+(define fold foldl)
+(define reduce fold)

src/leespparser.hs

@@ -102,7 +102,7 @@ parseExpr = parseAtom
         <|> try parseCharacter
         <|> parseQuoted
         <|> do char '('
-               x <- try parseList <|> parseDottedList
+               x <- (try parseList) <|> parseDottedList
                char ')'
                return x
 

src/leesptypes.hs

@@ -53,7 +53,7 @@ showError (UnboundVar message varname)  = message ++ ":" ++ varname
 showError (BadSpecialForm message form) = message ++ ":" ++ show form
 showError (NotFunction message func)    = message ++ ":" ++ show func
 showError (NumArgs expected found)      = "Expected " ++ show expected ++ " args: found values " ++ unWordsList found
-showError (TypeMismatch expected found) = "Invalid trype: expected " ++ expected ++ ", found " ++ show found
+showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
 showError (TypeMismatches expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ unWordsList found
 showError (Parser parseErr)             = "Parse error at " ++ show parseErr
 showError (Default message)             = message
@@ -69,7 +69,7 @@ showVal (List contents)        = "(" ++ unWordsList contents ++ ")"
 showVal (DottedList head tail) = "(" ++ unWordsList head ++ " . " ++ showVal tail ++ ")"
 showVal (Keyword kword)        = kword
 showVal (PrimitiveFunc _)      = "<PrimitiveFunc>"
-showVal (Func {params          = args, vararg = varargs, body = body, closure = env}) =
+showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
     "(lambda (" ++ unwords (map show args) ++ (case varargs of
         Nothing -> ""
         Just arg -> " . " ++ arg) ++ ") ...)"

src/main.hs

@@ -70,11 +70,6 @@ readExpr = readOrThrow parseExpr
 readExprList :: String -> ThrowsError [LispVal]
 readExprList = readOrThrow (endBy parseExpr spaces)
 
---readExpr :: String -> ThrowsError LispVal
---readExpr input = case parse parseExpr "lisp" input of
---  Left err  -> throwError $ Parser err
---  Right val -> return val
-
 apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
 apply (PrimitiveFunc func) args = liftThrows $ func args
 apply (Func params varargs body closure) args =
@@ -83,7 +78,7 @@ apply (Func params varargs body closure) args =
     else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
   where
     remainingArgs = drop (length params) args
-    num = L.genericLength
+    num = toInteger . length
     evalBody env = liftM last $ mapM (eval env) body
     bindVarArgs arg env = case arg of
       Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
@@ -97,18 +92,22 @@ eval env val@(Bool _)                          = return val
 eval env val@(Character _)                     = return val
 eval env val@(Keyword _)                       = return val
 eval env (Atom id)                             = getVar env id
+-- Handled Quoting.
+eval env (List [Atom "quote", val])            = return val
 -- Load a file and eval the contents
 eval env (List [Atom "load", String filename]) =
   load filename >>= liftM last . mapM (eval env)
--- Handled Quoting.
-eval env (List [Atom "quote", val])            = return val
 -- Flow Control Functions.
-eval env (List [Atom "if", pred, conseq, alt]) = myIfFun env pred conseq alt
-eval env (List (Atom "cond" : items))          = myCondFun env items
-eval env (List (Atom "case" : sel : choices))  =
+eval env (List [Atom "if", pred, conseq, alt]) =
+  myIfFun env pred conseq alt
+eval env (List (Atom "cond" : items)) =
+  myCondFun env items
+eval env (List (Atom "case" : sel : choices)) =
   eval env sel >>= myCaseFun env choices
-eval env (List [Atom "set!", Atom var, form])  = eval env form >>= setVar env var
-eval env (List [Atom "define", Atom var, form])= eval env form >>= defineVar env var
+eval env (List [Atom "set!", Atom var, form]) =
+  eval env form >>= setVar env var
+eval env (List [Atom "define", Atom var, form]) =
+  eval env form >>= defineVar env var
 eval env (List (Atom "define" : List (Atom var : params) : body)) =
   makeNormalFunc env params body >>= defineVar env var
 eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
@@ -124,7 +123,7 @@ eval env (List (function : args)) = do
   argVals <- mapM (eval env) args
   apply func argVals
 -- Yer done gone f**ked up.
-eval env badForm                               =
+eval env badForm =
   throwError $ BadSpecialForm "Unrecognised special form" badForm
 
 myCaseFun :: Env -> [LispVal] -> LispVal -> IOThrowsError LispVal
@@ -160,14 +159,15 @@ myCondFun env (pred:conseq:rest) = do
     otherwise  -> liftThrows . throwError $ TypeMismatch "boolean" pred
 
 primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
-primitives = [("+", numericBinop (+)),
+primitives =
         -- Basic Maths Functions
-			  ("-", numericBinop (-)),
-			  ("*", numericBinop (*)),
-			  ("/", numericBinop div),
-			  ("mod", numericBinop mod),
-			  ("quotient", numericBinop quot),
-			  ("remainder", numericBinop rem),
+        [("+", numericBinop (+)),
+        ("-", numericBinop (-)),
+        ("*", numericBinop (*)),
+        ("/", numericBinop div),
+        ("mod", numericBinop mod),
+        ("quotient", numericBinop quot),
+        ("remainder", numericBinop rem),
         -- Comparison Functions
         ("=", numBoolBinop (==)),
         ("<", numBoolBinop (<)),
@@ -252,9 +252,9 @@ stringLength badArgList   = throwError $ NumArgs 1 badArgList
 
 makeStringN :: [LispVal] -> ThrowsError LispVal
 makeStringN [Number n, Character c] = (return . String . L.genericTake n) $ repeat c
-makeStringN [Number n, _] = (return . String . L.genericTake n) ['a'..]
-makeStringN [bad, _] = throwError $ TypeMismatch "number [char]" bad
-makeStringN badArgList = throwError $ NumArgs 1 badArgList
+makeStringN [Number n, _]           = (return . String . L.genericTake n) ['a'..]
+makeStringN [bad, _]                = throwError $ TypeMismatch "number [char]" bad
+makeStringN badArgList              = throwError $ NumArgs 1 badArgList
 
 numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
 numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
@@ -311,7 +311,7 @@ eqv [Number arg1, Number arg2]         = return $ Bool $ arg1 == arg2
 eqv [String arg1, String arg2]         = return $ Bool $ arg1 == arg2
 eqv [Atom arg1, Atom arg2]             = return $ Bool $ arg1 == arg2
 eqv [DottedList xs x, DottedList ys y] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
-eqv [List arg1, List arg2]              = return
+eqv [List arg1, List arg2]             = return
   $ Bool
   $ (length arg1 == length arg2) && and (zipWith (curry eqvPair) arg1 arg2)
   where