Fixing scopes, removing AQuote in read syntax and adding quote evaluation

example/fib.lisp

@@ -0,0 +1,4 @@
+(define (fib x)
+	(cond ((eq? x 0) 0)
+	      ((eq? x 1) 1)
+	      (#t (+ (fib (- x 1)) (fib (- x 2))))))

example/sort.lisp

@@ -0,0 +1,21 @@
+(define (null? l) (eq? l '()))
+
+(define (merge-lists l1 l2)
+	(cond ((null? l1) l2)
+	      ((null? l2) l1)
+	      ((< (car l1) (car l2)) (cons (car l1) (merge-lists (cdr l1) l2)))
+	      (#t                    (cons (car l2) (merge-lists l1 (cdr l2))))))
+
+(define (split-half l l1 l2)
+	(cond ((null? l) (cons l1 l2))
+	      ((null? (cdr l)) (split-half (cdr l) (cons (car l) l1) l2))
+	      (#t (split-half (cdr (cdr l))
+	                      (cons (car l) l1)
+	                      (cons (car (cdr l)) l2)))))
+
+(define (merge-sort lst)
+	(cond ((null? lst) '())
+	      ((null? (cdr lst)) lst)
+	      (#t (let ((lsts (split-half lst '() '())))
+	               (merge-lists (merge-sort (car lsts))
+	                            (merge-sort (cdr lsts)))))))

src/Evaluator.hs

@@ -3,10 +3,12 @@ import Expressions
 
 eval :: Statement -> LispEnv -> Either String (Atom, LispEnv)
 eval (Expr expr) env = evalS expr env
+eval (Atom (ASymbol "env")) env = Right (AString $ unwords (fst <$> env), env)
 eval (Atom (ASymbol symb)) env =
     case getSymbolValue symb env of
          Just v  -> Right (v, env)
          Nothing -> Left $ "**Error: Variable not bound " ++ symb ++ "**"
+eval (Atom (AQuote quoted)) env = Right (quoted, env)
 eval (Atom atom) env = Right (atom, env)
 
 getSymbolValue :: String ->  LispEnv -> Maybe Atom
@@ -25,9 +27,13 @@ evalS (SExpr ((Atom (ASymbol "let")):xs)) env = evalLet xs env
 evalS (SExpr ((Atom (ASymbol "cond")):xs)) env = evalCond xs env
 evalS (SExpr ((Atom (AProcedure n dArgs body)):args)) env = do
     localEnv <- setupLocalVars dArgs args env
-    evalS body localEnv
+    (ret, _) <- evalS body localEnv
+    return (ret, env)
 evalS (SExpr ((Atom (ABuiltin n func)):args)) env = evalBuiltin func args env
-evalS (SExpr ((Atom (ASymbol name)):xs)) env = evalSymbol name xs env
+evalS (SExpr ((Atom (ASymbol name)):xs)) env = 
+    case getSymbolValue name env of
+         Just atom -> evalS (SExpr (Atom atom:xs)) env
+         Nothing   -> Left $ "**Error: Variable not bound " ++ name ++ "**"
 evalS (SExpr (Expr nested:args)) env = do
     (atom, nEnv) <- evalS nested env
     evalS (SExpr (Atom atom:args)) nEnv
@@ -58,7 +64,7 @@ evalBuiltin func args env = do
 
 
 showType :: Atom -> String
-showType (AQuote v)      = "(Quote" ++ show v ++ ")"
+showType (AQuote v)      = "(Quote " ++ show v ++ ")"
 showType (AString v)     = "(String " ++ v ++ ")"
 showType (ASymbol v)     = "(Symbol " ++ v ++ ")"
 showType (AInt v)        = "(Int " ++ show v ++ ")"

src/LispParser.hs

@@ -1,7 +1,7 @@
 module LispParser where
 
 import BasicParser
-    ( Parser, pCharIf, pUntil, pInt, pFloat, tokenify, pToken, pString )
+    ( Parser (Parser, parse), pCharIf, pUntil, pInt, pFloat, tokenify, pToken, pString )
 import Expressions ( SExpr(..), Atom(..), Statement(..) )
 import Control.Applicative ( Alternative(some, many, (<|>)) )
 
@@ -38,18 +38,24 @@ pQuotedAtom = ANil <$ pString "()"
 pConsReadExpr :: Parser Atom
 pConsReadExpr =
     do
-        fs <- tokenify pQuotedAtom
+        fs <- tokenify $ unquote pQuotedAtom
         se <- tokenify pConsReadExpr
         return $ ACons fs se
     <|> do
-        fs <- tokenify pQuotedAtom
+        fs <- tokenify $ unquote pQuotedAtom
         tokenify $ pCharIf (== '.')
-        se <- tokenify pQuotedAtom
+        se <- tokenify $ unquote pQuotedAtom
         return $ ACons fs se
     <|> do
-        fs <- tokenify pQuotedAtom
+        fs <- tokenify $ unquote pQuotedAtom
         return $ ACons fs ANil
 
+unquote :: Parser Atom -> Parser Atom
+unquote p = Parser $ \x -> 
+    case parse p x of
+         (Just (AQuote q), lo) -> (Just q, lo)
+         ret -> ret
+
 pSExpr :: Parser SExpr
 pSExpr = pCharIf (== '(')
       *> (SExpr <$> some (tokenify pStatement))

src/Maths.hs

@@ -65,4 +65,4 @@ evalLessThan [AInt f, AInt s] env = Right (_fromBool (f < s), env)
 evalLessThan [AFloat f, AFloat s] env = Right (_fromBool (f < s), env)
 evalLessThan [AFloat f, AInt s] env = Right (_fromBool (f < fromIntegral s), env)
 evalLessThan [AInt f, AFloat s] env = Right (_fromBool (fromIntegral f < s), env)
-evalLessThan _ _ = Left "**Error: Invalid arguments in <.**"
+evalLessThan args _ = Left $ "**Error: Invalid arguments (" ++ unwords (showType <$> args) ++ ") in <.**"