Flip fixity of TH sub.

And do some general cleanup.

example/greet.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 import Control.Concurrent (forkIO, killThread)
@@ -49,11 +50,16 @@ instance ToSample Greet where
     where g = Greet "Hello, haskeller!"
 
 -- API specification
-type TestApi = 
+type TestApi =
        "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
   :<|> "greet" :> ReqBody Greet :> Post Greet
   :<|> "delete" :> Capture "greetid" Text :> Delete
 
+type TestApi2 = [sitemap|
+GET   Bool  something/capt:Int
+POST  Bool  something
+|]
+
 testApi :: Proxy TestApi
 testApi = Proxy
 

src/Servant/API.hs

@@ -23,6 +23,10 @@ module Servant.API (
   module Servant.API.Delete,
   -- | PUT requests
   module Servant.API.Put,
+
+  -- * Utilities
+  -- | QuasiQuotes for endpoints
+  module Servant.API.QQ,
   ) where
 
 import Servant.API.Capture
@@ -31,6 +35,7 @@ import Servant.API.Get
 import Servant.API.Post
 import Servant.API.Put
 import Servant.API.QueryParam
+import Servant.API.QQ
 import Servant.API.ReqBody
 import Servant.API.Sub
 import Servant.API.Union

src/Servant/API/QQ.hs

@@ -2,11 +2,14 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Servant.API.QQ where
 
 import Control.Applicative
 import Data.List.Split (splitOn)
---import Language.Haskell.TH.Quote
+import Data.Maybe (mapMaybe)
+import Language.Haskell.TH.Quote
 import Language.Haskell.TH
 
 import Servant.API.Capture
@@ -15,45 +18,60 @@ import Servant.API.Post
 import Servant.API.Put
 import Servant.API.Delete
 import Servant.API.Sub
+import Servant.API.Union
 
 class ExpSYM repr' repr | repr -> repr', repr' -> repr where
-    simplePath :: String -> repr'
+    lit        :: String -> repr' -> repr
-    capture    :: String -> String -> repr'
+    capture    :: String -> String -> repr -> repr
-    conj       :: repr' -> repr' -> repr'
+    conj       :: repr' -> repr -> repr
-    get        :: String -> repr' -> repr
+    get        :: String -> repr
-    post       :: String -> repr' -> repr
+    post       :: String -> repr
-    put        :: String -> repr' -> repr
+    put        :: String -> repr
-    delete     :: String -> repr' -> repr
+    delete     :: String -> repr
+
+infixr 6 >:
+
+(>:) :: Type -> Type -> Type
+(>:) = conj
 
 instance ExpSYM Type Type where
-    simplePath name  = LitT (StrTyLit name)
+    lit name r         = (LitT (StrTyLit name)) >: r
-    capture name typ = AppT (AppT (ConT ''Capture) (simplePath name))
+    capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
-                            (ConT $ mkName typ)
+                               (ConT $ mkName typ)) >: r
-    conj f s         = AppT (AppT (ConT ''(:>)) f) s
+    conj x y         = AppT (AppT (ConT ''(:>)) x) y
-    get  typ r       = AppT (AppT (ConT ''(:>)) r)
+    get  typ         = AppT (ConT ''Get) (ConT $ mkName typ)
-                            (AppT (ConT ''Get) (ConT $ mkName typ))
+    post typ         = AppT (ConT ''Post) (ConT $ mkName typ)
-    post typ r       = AppT (AppT (ConT ''(:>)) r)
+    put typ          = AppT (ConT ''Put) (ConT $ mkName typ)
-                            (AppT (ConT ''Post) (ConT $ mkName typ))
+    delete typ       = AppT (ConT ''Delete) (ConT $ mkName typ)
-    put typ r        = AppT (AppT (ConT ''(:>)) r)
-                            (AppT (ConT ''Put) (ConT $ mkName typ))
-    delete typ r     = AppT (AppT (ConT ''(:>)) r)
-                            (AppT (ConT ''Delete) (ConT $ mkName typ))
 
-readEntry :: ExpSYM r' r => [String] -> Maybe r
+readEntry :: ExpSYM r r => [String] -> Maybe r
 readEntry []     = Nothing
 readEntry (met:typ:xs) = case met of
-    "GET"    -> get  typ <$> readEntry' xs
+    "GET"    -> readEntry' xs $ get typ
-    "POST"   -> post typ <$> readEntry' xs
+    "POST"   -> readEntry' xs $ post typ
-    "PUT"    -> put  typ <$> readEntry' xs
+    "PUT"    -> readEntry' xs $ put typ
-    "DELETE" -> delete typ <$> readEntry' xs
+    "DELETE" -> readEntry' xs $ delete typ
     x        -> error $ "Unknown method: " ++ x
 readEntry x    = error $ "Wrong number of elems in line: " ++ show x
 
-readEntry' :: ExpSYM r' r => [String] -> Maybe r'
+readEntry' :: ExpSYM r r => [String] -> r -> Maybe r
-readEntry' [] = Nothing
+readEntry' []   _ = Nothing
-readEntry' [xs] = Just $ foldr1 conj $ tRepr <$> splitOn "/" xs
+readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
-    where tRepr y | [x] <- splitOn ":" y   = simplePath x
+    where
-                  | x:[y] <- splitOn ":" y = capture x y
+          tRepr y | [x] <- splitOn ":" y   = lit x
+                  | a:[b] <- splitOn ":" y = capture a b
                   | otherwise              = error "Only one ':' per section"
-readEntry' _ = Nothing
+readEntry' _  _   = Nothing
+
+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
+
+sitemap :: QuasiQuoter
+sitemap = QuasiQuoter { quoteExp = undefined
+                      , quotePat = undefined
+                      , quoteType = return . readAll
+                      , quoteDec = undefined
+                      }