From 108f24a5e72d3e603df5a449367ae14e9382ceea Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Thu, 13 Nov 2014 18:22:26 +0100
Subject: [PATCH] Allow comments in API QQ.

        Closes #29.
---
 src/Servant/Utils/ApiQuasiQuoting.hs      | 22 ++++++++++++---
 test/Servant/Utils/ApiQuasiQuotingSpec.hs | 34 +++++++++++++++++++++++
 2 files changed, 52 insertions(+), 4 deletions(-)

diff --git a/src/Servant/Utils/ApiQuasiQuoting.hs b/src/Servant/Utils/ApiQuasiQuoting.hs
index a3396854..e768c73e 100644
--- a/src/Servant/Utils/ApiQuasiQuoting.hs
+++ b/src/Servant/Utils/ApiQuasiQuoting.hs
@@ -90,9 +90,11 @@ data Typ = Val String
 
 parseTyp :: Parser Typ
 parseTyp = do
-    f <- many (noneOf "-#\n\r")
+    f <- many (noneOf "-{\n\r")
     spaces
-    s <- optionMaybe parseRet
+    s <- optionMaybe (try parseRet)
+    try $ optional inlineComment
+    try $ optional blockComment
     case s of
         Nothing -> return $ Val (stripTr f)
         Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
@@ -101,7 +103,7 @@ parseTyp = do
     parseRet = do
         string "->"
         spaces
-        many (noneOf "#\n\r")
+        many (noneOf "-{\n\r")
     stripTr = reverse . dropWhile (== ' ') . reverse
 
 
@@ -116,6 +118,18 @@ parseEntry = do
         Val s -> return $ url (met s)
         ReqArgVal i o -> return $ url $ reqBody i (met o)
 
+blockComment :: Parser ()
+blockComment = do
+    string "{-"
+    manyTill anyChar (try $ string "-}")
+    return ()
+
+inlineComment :: Parser ()
+inlineComment = do
+    string "--"
+    manyTill anyChar (try $ lookAhead eol)
+    return ()
+
 eol :: Parser String
 eol =   try (string "\n\r")
     <|> try (string "\r\n")
@@ -124,7 +138,7 @@ eol =   try (string "\n\r")
     <?> "end of line"
 
 eols :: Parser ()
-eols = skipMany $ void eol
+eols = skipMany $ void eol <|> blockComment <|> inlineComment
 
 parseAll :: Parser Type
 parseAll = do
diff --git a/test/Servant/Utils/ApiQuasiQuotingSpec.hs b/test/Servant/Utils/ApiQuasiQuotingSpec.hs
index 39876bfc..7dd3bfc1 100644
--- a/test/Servant/Utils/ApiQuasiQuotingSpec.hs
+++ b/test/Servant/Utils/ApiQuasiQuotingSpec.hs
@@ -83,6 +83,34 @@ POST hello  Bool
 GET  hello  Bool
 |]
 type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool)
+
+type WithInlineComments = [sitemap|
+GET  hello  Bool   -- This is a comment
+|]
+type WithInlineComments' = "hello" :> Get Bool
+
+type WithInlineComments2 = [sitemap|
+GET  hello  Bool
+-- This is a comment
+|]
+type WithInlineComments2' = "hello" :> Get Bool
+
+
+type WithBlockComments = [sitemap|
+GET  hello  Bool   {-
+POST hello  Bool
+-}
+|]
+type WithBlockComments' = "hello" :> Get Bool
+
+type WithBlockComments2 = [sitemap|
+GET  hello  Bool   {-
+POST hello  Bool
+-}
+POST hello Bool
+|]
+type WithBlockComments2' = ("hello" :> Get Bool) :<|> ("hello" :> Post Bool)
+
 --------------------------------------------------------------------------
 -- Spec
 --------------------------------------------------------------------------
@@ -118,6 +146,12 @@ spec = do
             (u::SimpleQueryParam) ~= (u::SimpleQueryParam''') ~> False
         it "Handles multiples paths" $ do
             (u::TwoPaths) ~= (u::TwoPaths') ~> True
+        it "Ignores inline comments" $ do
+            (u::WithInlineComments) ~= (u::WithInlineComments') ~> True
+            (u::WithInlineComments2) ~= (u::WithInlineComments2') ~> True
+        it "Ignores inline comments" $ do
+            (u::WithBlockComments) ~= (u::WithBlockComments') ~> True
+            (u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True
 
 
 --------------------------------------------------------------------------