From 99e790492a3d34324f2452559c881ffce3244a6d Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Wed, 29 Oct 2014 14:54:13 +0100
Subject: [PATCH] QQ more tests and cleanup.

---
 example/greet.hs           |  6 -----
 src/Servant/API/QQ.hs      | 16 ++++++------
 test/Servant/API/QQSpec.hs | 52 +++++++++++++++++++++++++++++++++++++-
 3 files changed, 59 insertions(+), 15 deletions(-)

diff --git a/example/greet.hs b/example/greet.hs
index 08995168..5a6ae4dd 100644
--- a/example/greet.hs
+++ b/example/greet.hs
@@ -55,12 +55,6 @@ type TestApi =
   :<|> "greet" :> ReqBody Greet :> Post Greet
   :<|> "delete" :> Capture "greetid" Text :> Delete
 
-type TestApi2 = [sitemap|
-GET      hello/name:Text/?capital:Bool   () -> Greet
-POST     greet                           Greet -> Greet
-DELETE   delete/greetid:Text             ()
-|]
-
 testApi :: Proxy TestApi
 testApi = Proxy
 
diff --git a/src/Servant/API/QQ.hs b/src/Servant/API/QQ.hs
index 482bff46..72a3d5fa 100644
--- a/src/Servant/API/QQ.hs
+++ b/src/Servant/API/QQ.hs
@@ -41,13 +41,13 @@ infixr 6 >:
 
 
 instance ExpSYM Type Type where
-    lit name r         = (LitT (StrTyLit name)) >: r
-    capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
-                               (ConT $ mkName typ)) >: r
-    reqBody typ r      = (AppT (ConT ''ReqBody) (ConT $ mkName typ)) >: r
-    queryParam name typ r = (AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name)))
-                               (ConT $ mkName typ)) >: r
-    conj x y           = AppT (AppT (ConT ''(:>)) x) y
+    lit name r         = LitT (StrTyLit name) >: r
+    capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
+                               (ConT $ mkName typ) >: r
+    reqBody typ r      = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r
+    queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name)))
+                               (ConT $ mkName typ) >: r
+    conj x             = AppT (AppT (ConT ''(:>)) x)
     get  typ           = AppT (ConT ''Get) (ConT $ mkName typ)
     post typ           = AppT (ConT ''Post) (ConT $ mkName typ)
     put typ            = AppT (ConT ''Put) (ConT $ mkName typ)
@@ -84,7 +84,7 @@ readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
 readAll :: String -> Type
 readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
    where union :: Type -> Type -> Type
-         union a b = AppT (AppT (ConT ''(:<|>)) a) b
+         union a = AppT (AppT (ConT ''(:<|>)) a)
 
 sitemap :: QuasiQuoter
 sitemap = QuasiQuoter { quoteExp = undefined
diff --git a/test/Servant/API/QQSpec.hs b/test/Servant/API/QQSpec.hs
index e0afa90f..bb983e88 100644
--- a/test/Servant/API/QQSpec.hs
+++ b/test/Servant/API/QQSpec.hs
@@ -18,7 +18,7 @@ import Servant.API
 -- Types for testing
 --------------------------------------------------------------------------
 
-
+-- Methods ---------------------------------------------------------------
 type SimpleGet = [sitemap|
 GET  hello  ()
 |]
@@ -43,12 +43,47 @@ POST  hello  Bool
 type SimplePost2' = "hello" :> Post Bool
 type SimplePost2'' = "hello" :> Post ()
 
+type SimplePut = [sitemap|
+PUT  hello  ()
+|]
+type SimplePut' = "hello" :> Put ()
+type SimplePut'' = "hello" :> Put Bool
+
+type SimplePut2 = [sitemap|
+PUT  hello  Bool
+|]
+type SimplePut2' = "hello" :> Put Bool
+type SimplePut2'' = "hello" :> Put ()
+
+-- Parameters ------------------------------------------------------------
+
 type SimpleReqBody = [sitemap|
 POST  hello  () -> Bool
 |]
 type SimpleReqBody' = "hello" :> ReqBody () :> Post Bool
 type SimpleReqBody'' = "hello" :> ReqBody Bool :> Post ()
 
+type SimpleCapture = [sitemap|
+POST  hello/p:Int   Bool
+|]
+type SimpleCapture' = "hello" :> Capture "p" Int :> Post Bool
+type SimpleCapture'' = "hello" :> Capture "r" Int :> Post Bool
+type SimpleCapture''' = "hello" :> Capture "p" Bool :> Post Bool
+
+type SimpleQueryParam = [sitemap|
+POST  hello/?p:Int   Bool
+|]
+type SimpleQueryParam' = "hello" :> QueryParam "p" Int :> Post Bool
+type SimpleQueryParam'' = "hello" :> QueryParam "r" Int :> Post Bool
+type SimpleQueryParam''' = "hello" :> QueryParam "p" Bool :> Post Bool
+
+-- Combinations ----------------------------------------------------------
+
+type TwoPaths = [sitemap|
+POST hello  Bool
+GET  hello  Bool
+|]
+type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool)
 --------------------------------------------------------------------------
 -- Spec
 --------------------------------------------------------------------------
@@ -66,9 +101,24 @@ spec = do
             (u::SimplePost)  ~= (u::SimplePost'' ) ~> False
             (u::SimplePost2) ~= (u::SimplePost2' ) ~> True
             (u::SimplePost2) ~= (u::SimplePost2'') ~> False
+        it "Handles simple PUT types" $ do
+            (u::SimplePut)  ~= (u::SimplePut'  ) ~> True
+            (u::SimplePut)  ~= (u::SimplePut'' ) ~> False
+            (u::SimplePut2) ~= (u::SimplePut2' ) ~> True
+            (u::SimplePut2) ~= (u::SimplePut2'') ~> False
         it "Handles simple request body types" $ do
             (u::SimpleReqBody) ~= (u::SimpleReqBody' ) ~> True
             (u::SimpleReqBody) ~= (u::SimpleReqBody'') ~> False
+        it "Handles simple captures" $ do
+            (u::SimpleCapture) ~= (u::SimpleCapture' ) ~> True
+            (u::SimpleCapture) ~= (u::SimpleCapture'') ~> False
+            (u::SimpleCapture) ~= (u::SimpleCapture''') ~> False
+        it "Handles simple querystring parameters" $ do
+            (u::SimpleQueryParam) ~= (u::SimpleQueryParam' ) ~> True
+            (u::SimpleQueryParam) ~= (u::SimpleQueryParam'') ~> False
+            (u::SimpleQueryParam) ~= (u::SimpleQueryParam''') ~> False
+        it "Handles multiples paths" $ do
+            (u::TwoPaths) ~= (u::TwoPaths') ~> True
 
 
 --------------------------------------------------------------------------