Flip fixity of TH sub.
And do some general cleanup.
This commit is contained in:
parent
e6be95fb9e
commit
21c8fcbea2
3 changed files with 61 additions and 32 deletions
|
@ -5,6 +5,7 @@
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
import Control.Concurrent (forkIO, killThread)
|
import Control.Concurrent (forkIO, killThread)
|
||||||
|
@ -54,6 +55,11 @@ type TestApi =
|
||||||
:<|> "greet" :> ReqBody Greet :> Post Greet
|
:<|> "greet" :> ReqBody Greet :> Post Greet
|
||||||
:<|> "delete" :> Capture "greetid" Text :> Delete
|
:<|> "delete" :> Capture "greetid" Text :> Delete
|
||||||
|
|
||||||
|
type TestApi2 = [sitemap|
|
||||||
|
GET Bool something/capt:Int
|
||||||
|
POST Bool something
|
||||||
|
|]
|
||||||
|
|
||||||
testApi :: Proxy TestApi
|
testApi :: Proxy TestApi
|
||||||
testApi = Proxy
|
testApi = Proxy
|
||||||
|
|
||||||
|
|
|
@ -23,6 +23,10 @@ module Servant.API (
|
||||||
module Servant.API.Delete,
|
module Servant.API.Delete,
|
||||||
-- | PUT requests
|
-- | PUT requests
|
||||||
module Servant.API.Put,
|
module Servant.API.Put,
|
||||||
|
|
||||||
|
-- * Utilities
|
||||||
|
-- | QuasiQuotes for endpoints
|
||||||
|
module Servant.API.QQ,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Servant.API.Capture
|
import Servant.API.Capture
|
||||||
|
@ -31,6 +35,7 @@ import Servant.API.Get
|
||||||
import Servant.API.Post
|
import Servant.API.Post
|
||||||
import Servant.API.Put
|
import Servant.API.Put
|
||||||
import Servant.API.QueryParam
|
import Servant.API.QueryParam
|
||||||
|
import Servant.API.QQ
|
||||||
import Servant.API.ReqBody
|
import Servant.API.ReqBody
|
||||||
import Servant.API.Sub
|
import Servant.API.Sub
|
||||||
import Servant.API.Union
|
import Servant.API.Union
|
||||||
|
|
|
@ -2,11 +2,14 @@
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
module Servant.API.QQ where
|
module Servant.API.QQ where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.List.Split (splitOn)
|
import Data.List.Split (splitOn)
|
||||||
--import Language.Haskell.TH.Quote
|
import Data.Maybe (mapMaybe)
|
||||||
|
import Language.Haskell.TH.Quote
|
||||||
import Language.Haskell.TH
|
import Language.Haskell.TH
|
||||||
|
|
||||||
import Servant.API.Capture
|
import Servant.API.Capture
|
||||||
|
@ -15,45 +18,60 @@ import Servant.API.Post
|
||||||
import Servant.API.Put
|
import Servant.API.Put
|
||||||
import Servant.API.Delete
|
import Servant.API.Delete
|
||||||
import Servant.API.Sub
|
import Servant.API.Sub
|
||||||
|
import Servant.API.Union
|
||||||
|
|
||||||
class ExpSYM repr' repr | repr -> repr', repr' -> repr where
|
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
|
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 [] = Nothing
|
||||||
readEntry (met:typ:xs) = case met of
|
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
|
x -> error $ "Unknown method: " ++ x
|
||||||
readEntry x = error $ "Wrong number of elems in line: " ++ show 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"
|
| 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
|
||||||
|
}
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue