From f68c7f7a140127320f9dadc57a3d2a485b86d3df Mon Sep 17 00:00:00 2001
From: Akshay <nerdy@peppe.rs>
Date: Sat, 17 Oct 2020 21:00:07 +0530
Subject: add basic evaluation of unquote-splicing in quasiquoted forms

---
 src/Evaluator.hs | 42 ++++++++++++++++++++++++++----------------
 src/Parser.hs    | 17 ++++++++---------
 2 files changed, 34 insertions(+), 25 deletions(-)

diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index 3d3be02..9e6632e 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -16,13 +16,20 @@ apply fn args = maybe
     ($ args)
     (lookup fn primitives)
 
+evalUnquoteSplicing :: Env -> Expr -> IOResult Expr
+evalUnquoteSplicing env (List xs) = List <$> mapM (eval env) xs
+evalUnquoteSplicing env literal   = return literal
+
 evalUnquote :: Env -> Expr -> IOResult Expr
-evalUnquote env (List [Id "unquote", vs]) = eval env vs
-evalUnquote env (List [Id "quote", vs]) =
-    fmap (List . ([Id "quote"] ++ ) . (: [])) (evalUnquote env vs)
-evalUnquote env (List vs)   = List <$> mapM (evalUnquote env) vs
-evalUnquote env (Vector vs) = Vector <$> mapM (evalUnquote env) vs
-evalUnquote env literal = return literal
+evalUnquote env (DottedList h t)                  = List . (:[]) <$> liftM2 DottedList (mapM (evalUnquote env) h) (evalUnquote env t)
+evalUnquote env (Vector vs)                       = List . (:[]) . Vector <$> mapM (evalUnquote env) vs
+evalUnquote env (List [Id "unquote", v])          = List . (:[]) <$> eval env v
+evalUnquote env (List [Id "unquote-splicing", v]) = eval env v
+evalUnquote env (List (Id "unquote-splicing":vs)) = List <$> mapM (eval env) vs
+evalUnquote env (List (Id "unquote":vs))          = List . (:[]) . List <$> mapM (eval env) vs
+evalUnquote env (List [Id "quote", vs])           = List . (:[]) <$> fmap (List . ([Id "quote"] ++ ) . (: [])) (evalUnquote env vs)
+evalUnquote env (List vs)                         = List . concat <$> mapM ((unwrapList <$>) . evalUnquote env) vs
+evalUnquote env literal                           = return $ List . (:[]) $ literal
 
 evalQuasiQuote :: Env -> Expr -> IOResult Expr
 evalQuasiQuote env v@(Vector _) = evalUnquote env v
@@ -30,20 +37,23 @@ evalQuasiQuote env q@(List _)   = evalUnquote env q -- list of atoms which may b
 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
-eval _ v@(BoolLiteral b)   = return v
-eval env (Id l)            = getVar env l
-eval _ v@(FloatLiteral f)  = return v
-eval env v@(Vector xs)     = Vector <$> mapM (eval env) xs
-eval env (List[Id "quote", val])      = return val
-eval env (List[Id "quasiquote", val]) = evalQuasiQuote env val
-eval env v@(List[Id "unquote", val])    = throwError $ BadForm "Cannot use `unquote` outside quasiquote form" v
+eval _ v@(StringLiteral s)                    = return v
+eval _ v@(IntLiteral i)                       = return v
+eval _ v@(BoolLiteral b)                      = return v
+eval env (Id l)                               = getVar env l
+eval _ v@(FloatLiteral f)                     = return v
+eval env v@(Vector xs)                        = Vector <$> mapM (eval env) xs
+eval env (List[Id "quote", val])              = return val
+eval env (List[Id "quasiquote", val])         = evalQuasiQuote env val
+eval env v@(List[Id "unquote", val])          = throwError $ BadForm "Cannot use `unquote` outside quasiquote form" v
+eval env v@(List[Id "unquote-splicing", val]) = throwError $ BadForm "Cannot use `unquote-splicing` outside quasiquote form" 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
 
 -- handle bad forms
 eval env invalidForm = throwError $ BadForm "lisk can't recognize this form" invalidForm
 
+unwrapList :: Expr -> [Expr]
+unwrapList (List x) = x
+unwrapList literal  = [literal]
diff --git a/src/Parser.hs b/src/Parser.hs
index 6ec4ba0..f83f4cc 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -21,7 +21,6 @@ data Expr = List [Expr]
           | FloatLiteral Double
           | BoolLiteral Bool
           | Id String
-          | NoReturn
           deriving (Eq)
 
 -- backslash double quote escapes a quote inside strings
@@ -83,15 +82,16 @@ optionalWhiteSpace :: Parser ()
 optionalWhiteSpace = skipMany $ oneOf [' ', '\n']
 
 type Alias = String
-parseModifier :: Char -> Alias -> Parser Expr
-parseModifier c alias = do
-    char c
+parseModifier :: String -> Alias -> Parser Expr
+parseModifier s alias = do
+    string s
     x <- parseLispValue
     return $ List [Id alias, x]
 
-parseQuote = parseModifier '\'' "quote"
-parseQuasiquote = parseModifier '`' "quasiquote"
-parseUnquote = parseModifier ',' "unquote"
+parseQuote           = parseModifier "'" "quote"
+parseQuasiquote      = parseModifier "`" "quasiquote"
+parseUnquote         = parseModifier "," "unquote"
+parseUnquoteSplicing = parseModifier ",@" "unquote-splicing"
 -- TODO: add modifier for unquote splicing: ,@
 
 parseLispValue :: Parser Expr
@@ -103,8 +103,8 @@ parseLispValue =
     <|> try parseId
     <|> parseQuote
     <|> parseQuasiquote
+    <|> try parseUnquoteSplicing
     <|> parseUnquote
-    -- handles lists and dotted lists
     <|> do
         char '(' >> optionalWhiteSpace
         x <- sepEndBy parseLispValue whiteSpace
@@ -127,4 +127,3 @@ instance Show Expr where
     show (BoolLiteral True)  = "#t"
     show (BoolLiteral False) = "#f"
     show (Id i)              = i
-    show NoReturn            = ";;; environment extension"
-- 
cgit v1.2.3