Basic QQ data types and parsing.

This commit is contained in:
Julian K. Arni 2014-10-28 13:22:11 +01:00
parent 90ea56534b
commit e6be95fb9e
2 changed files with 62 additions and 0 deletions

View file

@ -26,6 +26,7 @@ library
Servant.API.Put Servant.API.Put
Servant.API.QueryParam Servant.API.QueryParam
Servant.API.ReqBody Servant.API.ReqBody
Servant.API.QQ
Servant.API.Raw Servant.API.Raw
Servant.API.Sub Servant.API.Sub
Servant.API.Union Servant.API.Union
@ -39,12 +40,14 @@ library
, bytestring , bytestring
, exceptions , exceptions
, string-conversions , string-conversions
, split
, http-client , http-client
, http-types , http-types
, network-uri , network-uri
, wai , wai
, warp , warp
, transformers , transformers
, template-haskell
, text , text
, lens , lens
, unordered-containers , unordered-containers

59
src/Servant/API/QQ.hs Normal file
View file

@ -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