From e6be95fb9e1fe4e27200a34c6e6868e71557231f Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Tue, 28 Oct 2014 13:22:11 +0100
Subject: [PATCH] Basic QQ data types and parsing.

---
 servant.cabal         |  3 +++
 src/Servant/API/QQ.hs | 59 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 62 insertions(+)
 create mode 100644 src/Servant/API/QQ.hs

diff --git a/servant.cabal b/servant.cabal
index b5f73840..01650b1f 100644
--- a/servant.cabal
+++ b/servant.cabal
@@ -26,6 +26,7 @@ library
     Servant.API.Put
     Servant.API.QueryParam
     Servant.API.ReqBody
+    Servant.API.QQ
     Servant.API.Raw
     Servant.API.Sub
     Servant.API.Union
@@ -39,12 +40,14 @@ library
     , bytestring
     , exceptions
     , string-conversions
+    , split
     , http-client
     , http-types
     , network-uri
     , wai
     , warp
     , transformers
+    , template-haskell
     , text
     , lens
     , unordered-containers
diff --git a/src/Servant/API/QQ.hs b/src/Servant/API/QQ.hs
new file mode 100644
index 00000000..5a37cedc
--- /dev/null
+++ b/src/Servant/API/QQ.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Servant.API.QQ where
+
+import Control.Applicative
+import Data.List.Split (splitOn)
+--import Language.Haskell.TH.Quote
+import Language.Haskell.TH
+
+import Servant.API.Capture
+import Servant.API.Get
+import Servant.API.Post
+import Servant.API.Put
+import Servant.API.Delete
+import Servant.API.Sub
+
+class ExpSYM repr' repr | repr -> repr', repr' -> repr where
+    simplePath :: String -> repr'
+    capture    :: String -> String -> repr'
+    conj       :: repr' -> repr' -> repr'
+    get        :: String -> repr' -> repr
+    post       :: String -> repr' -> repr
+    put        :: String -> repr' -> repr
+    delete     :: String -> repr' -> repr
+
+instance ExpSYM Type Type where
+    simplePath name  = LitT (StrTyLit name)
+    capture name typ = AppT (AppT (ConT ''Capture) (simplePath name))
+                            (ConT $ mkName typ)
+    conj f s         = AppT (AppT (ConT ''(:>)) f) s
+    get  typ r       = AppT (AppT (ConT ''(:>)) r)
+                            (AppT (ConT ''Get) (ConT $ mkName typ))
+    post typ r       = AppT (AppT (ConT ''(:>)) r)
+                            (AppT (ConT ''Post) (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 []     = Nothing
+readEntry (met:typ:xs) = case met of
+    "GET"    -> get  typ <$> readEntry' xs
+    "POST"   -> post typ <$> readEntry' xs
+    "PUT"    -> put  typ <$> readEntry' xs
+    "DELETE" -> delete typ <$> readEntry' xs
+    x        -> error $ "Unknown method: " ++ x
+readEntry x    = error $ "Wrong number of elems in line: " ++ show x
+
+readEntry' :: ExpSYM r' r => [String] -> Maybe r'
+readEntry' [] = Nothing
+readEntry' [xs] = Just $ foldr1 conj $ tRepr <$> splitOn "/" xs
+    where tRepr y | [x] <- splitOn ":" y   = simplePath x
+                  | x:[y] <- splitOn ":" y = capture x y
+                  | otherwise              = error "Only one ':' per section"
+readEntry' _ = Nothing
+