add basic quasiquote and unquote behaviour

2 files changed, 20 insertions, 11 deletions

diff --git a/src/Error/Base.hs b/src/Error/Base.hs
index ef32d52..747904a 100644
--- a/src/Error/Base.hs
+++ b/src/Error/Base.hs
@@ -24,7 +24,7 @@ literal v = "`" <> v <> "`"
 
 instance Show LispError where
     show (Parse e)              = "Parser Error: " ++ show e
-    show (BadForm s expr)       = "Bad Form: " ++ literal s ++ ": " ++ show expr
+    show (BadForm s expr)       = "Bad Form: " ++ s ++ ": " ++ show expr
     -- TODO: clean this up
     show (ArgCount fn n es)
       | null es = "Invalid arity, " ++ literal fn ++ " expects " ++ show n ++ " or more expression(s)!"
diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index e3bf697..1cc9edd 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -1,5 +1,7 @@
 module Evaluator (eval) where
 
+import           Control.Applicative           ((*>))
+import           Control.Arrow                 ((&&&))
 import           Control.Monad.Except
 import           Environment
 import           Error.Base                    (LispError (..), LispResult (..),
@@ -14,6 +16,19 @@ apply fn args = maybe
     ($ args)
     (lookup fn primitives)
 
+evalUnquote :: Env -> Expr -> IOResult Expr
+evalUnquote env (List [Id "unquote", vs]) = eval env vs
+evalUnquote env (List [Id "quote", vs]) =
+    liftM (List . ([Id "quote"] ++ ) . (: [])) (evalUnquote env vs)
+evalUnquote env (List vs)   = liftM List $ mapM (evalUnquote env) vs
+evalUnquote env (Vector vs) = liftM Vector $ mapM (evalUnquote env) vs
+evalUnquote env literal = return literal
+
+evalQuasiQuote :: Env -> Expr -> IOResult Expr
+evalQuasiQuote env v@(Vector _) = evalUnquote env v
+evalQuasiQuote env q@(List _)   = evalUnquote env q -- list of atoms which may be quoted or unquoted
+evalQuasiQuote env literal      = return literal -- just behave like quote otherwise
+
 eval :: Env -> Expr -> IOResult Expr
 eval _ v@(StringLiteral s) = return v
 eval _ v@(IntLiteral i)    = return v
@@ -22,16 +37,10 @@ eval env (Id l)            = getVar env l
 eval _ v@(FloatLiteral f)  = return v
 eval env v@(Vector xs)     = liftM Vector $ mapM (eval env) xs
 eval env (List[Id "quote", val])      = return val
-eval env (List[Id "quasiquote", val]) = undefined
-eval env (List[Id "unquote", val])    = eval env val
-eval env (List [Id "set!", Id var, val]) = do
-    e <- eval env val
-    setVar env var e
-    return e
-eval env (List [Id "define", Id var, val]) = do
-    e <- eval env val
-    defineVar env var e
-    return e
+eval env (List[Id "quasiquote", val]) = evalQuasiQuote env val
+eval env v@(List[Id "unquote", val])    = throwError $ BadForm "Cannot use `unquote` form outside quasiquote context" v
+eval env (List [Id "set!", Id var, val]) = eval env val >>= uncurry (*>) . ((setVar env var) &&& pure)
+eval env (List [Id "define", Id var, val]) = eval env val >>= uncurry (*>) . ((defineVar env var) &&& pure)
 eval env (List (Id fn : args))        = mapM (eval env) args >>= liftLispResult . apply fn
 eval env NoReturn = throwError $ BadForm "Invalid usage of non-returning expression" NoReturn