Remove QQ for now
This commit is contained in:
Julian K. Arni
parent
99374c5868
commit
5470297bdc
4 changed files with 0 additions and 561 deletions
|
|
@ -41,7 +41,6 @@ library
|
||||||
Servant.API.ReqBody
|
Servant.API.ReqBody
|
||||||
Servant.API.Sub
|
Servant.API.Sub
|
||||||
Servant.Common.Text
|
Servant.Common.Text
|
||||||
Servant.QQ
|
|
||||||
Servant.Utils.Links
|
Servant.Utils.Links
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.7 && <5
|
||||||
|
|
|
||||||
|
|
@ -38,8 +38,6 @@ module Servant.API (
|
||||||
module Servant.API.Raw,
|
module Servant.API.Raw,
|
||||||
|
|
||||||
-- * Utilities
|
-- * Utilities
|
||||||
-- | QuasiQuotes for endpoints
|
|
||||||
module Servant.QQ,
|
|
||||||
-- | Type-safe internal URIs
|
-- | Type-safe internal URIs
|
||||||
module Servant.Utils.Links,
|
module Servant.Utils.Links,
|
||||||
) where
|
) where
|
||||||
|
|
@ -59,5 +57,4 @@ import Servant.API.MatrixParam ( MatrixFlag, MatrixParams, MatrixParam )
|
||||||
import Servant.API.Raw ( Raw )
|
import Servant.API.Raw ( Raw )
|
||||||
import Servant.API.ReqBody ( ReqBody )
|
import Servant.API.ReqBody ( ReqBody )
|
||||||
import Servant.API.Sub ( (:>)(..) )
|
import Servant.API.Sub ( (:>)(..) )
|
||||||
import Servant.QQ ( sitemap )
|
|
||||||
import Servant.Utils.Links ( safeLink, URI(..), IsElem, IsElem', HasLink(..) )
|
import Servant.Utils.Links ( safeLink, URI(..), IsElem, IsElem', HasLink(..) )
|
||||||
|
|
|
||||||
|
|
@ -1,344 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
|
||||||
{-# LANGUAGE GADTs #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
|
||||||
-- | QuasiQuoting utilities for API types.
|
|
||||||
--
|
|
||||||
-- 'sitemap' allows you to write your type in a very natural way:
|
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- [sitemap|
|
|
||||||
-- PUT hello String -> ()
|
|
||||||
-- POST hello/p:Int String -> ()
|
|
||||||
-- GET hello/?name:String Int
|
|
||||||
-- |]
|
|
||||||
-- @
|
|
||||||
--
|
|
||||||
-- Will generate:
|
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- "hello" :> ReqBody String :> Put ()
|
|
||||||
-- :\<|> "hello" :> Capture "p" Int :> ReqBody String :> Post ()
|
|
||||||
-- :\<|> "hello" :> QueryParam "name" String :> Get Int
|
|
||||||
-- @
|
|
||||||
--
|
|
||||||
-- Note the @/@ before a @QueryParam@!
|
|
||||||
module Servant.QQ (sitemap) where
|
|
||||||
|
|
||||||
import Control.Applicative ( (<$>) )
|
|
||||||
import Control.Monad ( void )
|
|
||||||
import Data.Monoid ( Monoid(..), (<>) )
|
|
||||||
import Data.Maybe ( mapMaybe )
|
|
||||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
|
||||||
import Language.Haskell.TH
|
|
||||||
( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) )
|
|
||||||
import Text.ParserCombinators.Parsec
|
|
||||||
( try,
|
|
||||||
Parser,
|
|
||||||
manyTill,
|
|
||||||
endBy,
|
|
||||||
sepBy1,
|
|
||||||
optional,
|
|
||||||
optionMaybe,
|
|
||||||
string,
|
|
||||||
anyChar,
|
|
||||||
char,
|
|
||||||
spaces,
|
|
||||||
noneOf,
|
|
||||||
parse,
|
|
||||||
skipMany,
|
|
||||||
many,
|
|
||||||
lookAhead,
|
|
||||||
(<|>),
|
|
||||||
(<?>) )
|
|
||||||
import Servant.API.Capture ( Capture )
|
|
||||||
import Servant.API.Get ( Get )
|
|
||||||
import Servant.API.Post ( Post )
|
|
||||||
import Servant.API.Put ( Put )
|
|
||||||
import Servant.API.Delete ( Delete )
|
|
||||||
import Servant.API.QueryParam ( QueryParam )
|
|
||||||
import Servant.API.MatrixParam ( MatrixParam )
|
|
||||||
import Servant.API.ReqBody ( ReqBody )
|
|
||||||
import Servant.API.Sub ( (:>) )
|
|
||||||
import Servant.API.Alternative ( (:<|>) )
|
|
||||||
|
|
||||||
data MethodE
|
|
||||||
data PathElemE
|
|
||||||
data OptsE
|
|
||||||
data SitemapE
|
|
||||||
|
|
||||||
sitemap = undefined
|
|
||||||
{-
|
|
||||||
data Validation e a = Failure e
|
|
||||||
| Success a
|
|
||||||
|
|
||||||
instance Functor (Validation e) where
|
|
||||||
fmap _ (Failure e) = Failure e
|
|
||||||
fmap f (Success a) = Success (f a)
|
|
||||||
|
|
||||||
data Exp a where
|
|
||||||
Method :: String -> Exp MethodE
|
|
||||||
Slash :: Exp PathElemE -> Exp PathElemE -> Exp PathElemE
|
|
||||||
PathElem :: String -> Exp PathElemE
|
|
||||||
Opts :: String -> Exp OptsE
|
|
||||||
JoinOpts :: Exp OptsE -> Exp OptsE -> Exp OptsE
|
|
||||||
AddOpts :: Exp SitemapE -> Exp OptsE -> Exp SitemapE
|
|
||||||
Line :: Exp MethodE -> Exp PathElemE -> Exp SitemapE
|
|
||||||
Sitemap :: Exp SitemapE -> Exp SitemapE -> Exp SitemapE
|
|
||||||
|
|
||||||
data ParseError = ParseError Int String
|
|
||||||
|
|
||||||
parseEverything :: String -> Exp SitemapE
|
|
||||||
parseEverything str = undefined {-removeComments <$> lines str
|
|
||||||
where removeComments = takeWhile (/= '#')
|
|
||||||
parseLines _ [] = []
|
|
||||||
parseLines lineno (x:xs) = case opts of
|
|
||||||
[] -> (parseUrlLine x):parseLines rest
|
|
||||||
xs -> undefined
|
|
||||||
where (opts, rest) = span (startsWith ' ') xs -}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
parsePath :: String -> Exp PathElemE
|
|
||||||
parsePath line = foldr1 Slash $ PathElem <$> wordsBy '/' line
|
|
||||||
|
|
||||||
parseOpts :: Int -> [String] -> Either ParseError (Exp OptsE)
|
|
||||||
parseOpts lineno lines = foldr1 JoinOpts $ Opts <$> lines
|
|
||||||
|
|
||||||
parseUrlLine :: Int -> String -> Either ParseError (Exp SitemapE)
|
|
||||||
parseUrlLine lineno line = case span '>' line of
|
|
||||||
([], x) -> Left $ ParseError lineno "Expected method and url before '>'"
|
|
||||||
(xs, ">") -> Left $ ParseError lineno "Expected type after '>'"
|
|
||||||
(xs, '>':ys) | length (words xs) /= 2 -> Left $ ParseError lineno "Expected method and url before '>'"
|
|
||||||
| otherwise -> Line (Method met) (parsePath url)
|
|
||||||
where met:url = words xs
|
|
||||||
|
|
||||||
wordsBy :: Char -> String -> [String]
|
|
||||||
wordsBy c s = case dropWhile (== c) s of
|
|
||||||
"" -> []
|
|
||||||
s' -> w : words s''
|
|
||||||
where (w, s'') = break (== c) s'
|
|
||||||
|
|
||||||
|
|
||||||
data SitemapParser = SitemapParser
|
|
||||||
{ methodParsers :: [String -> Maybe Type]
|
|
||||||
, pathParsers :: [String -> Maybe Type]
|
|
||||||
, optsParsers :: [String -> Maybe Type]
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
pFirstWE :: [a -> Maybe b] -> a -> c -> Validation c b
|
|
||||||
pFirstWE fn a c = maybe (Failure c) Success $ pFirst fn a
|
|
||||||
where pFirst :: [a -> Maybe b] -> a -> Maybe b
|
|
||||||
pFirst fns s = case mapMaybe ($ s) fns of
|
|
||||||
[] -> Nothing
|
|
||||||
x:_ -> Just x
|
|
||||||
|
|
||||||
|
|
||||||
joinWith :: Monoid err => (typ -> typ -> typ)
|
|
||||||
-> Validation err typ
|
|
||||||
-> Validation err typ
|
|
||||||
-> Validation err typ
|
|
||||||
joinWith mult (Success s1) (Success s2) = Success (s1 `mult` s2)
|
|
||||||
joinWith _ (Failure e1) (Failure e2) = Failure (e1 <> e2)
|
|
||||||
joinWith _ (Failure e1) _ = Failure e1
|
|
||||||
joinWith _ _ (Failure e2) = Failure e2
|
|
||||||
|
|
||||||
pathUnion :: Type -> Type -> Type
|
|
||||||
pathUnion a = AppT (AppT (ConT ''(:>)) a)
|
|
||||||
|
|
||||||
optsUnion :: Type -> Type -> Type
|
|
||||||
optsUnion a = AppT (AppT (ConT ''(:<|>)) a)
|
|
||||||
|
|
||||||
data UndefinedError = UndefinedPath String
|
|
||||||
| UndefinedMethod String
|
|
||||||
| UndefinedOpts String
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
evalPath :: SitemapParser -> Exp PathElemE -> Validation [UndefinedError] Type
|
|
||||||
evalPath SitemapParser{..} (PathElem path) = pFirstWE pathParsers path [UndefinedPath path]
|
|
||||||
evalPath sp (p1 `Slash` p2) = joinWith pathUnion (evalPath sp p1) (evalPath sp p2)
|
|
||||||
|
|
||||||
evalMethod :: SitemapParser -> Exp MethodE -> Validation [UndefinedError] Type
|
|
||||||
evalMethod SitemapParser{..} (Method met) = pFirstWE methodParsers met [UndefinedMethod met]
|
|
||||||
|
|
||||||
evalOpts :: SitemapParser -> Exp OptsE -> Validation [UndefinedError] Type
|
|
||||||
evalOpts SitemapParser{..} (Opts opt) = pFirstWE optsParsers opt [UndefinedOpts opt]
|
|
||||||
evalOpts sp (o1 `JoinOpts` o2) = joinWith optsUnion (evalOpts sp o1) (evalOpts sp o2)
|
|
||||||
|
|
||||||
|
|
||||||
addMethodParser, addPathParser, addOptsParser :: (String -> Maybe Type) -> SitemapParser -> SitemapParser
|
|
||||||
addMethodParser a x@SitemapParser{..} = x{ methodParsers = methodParsers ++ [a] }
|
|
||||||
addOptsParser a x@SitemapParser{..} = x{ optsParsers = optsParsers ++ [a] }
|
|
||||||
addPathParser a x@SitemapParser{..} = x{ pathParsers = pathParsers ++ [a] }
|
|
||||||
|
|
||||||
-- | Finally-tagless encoding for our DSL.
|
|
||||||
-- Keeping 'repr'' and 'repr' distinct when writing functions with an
|
|
||||||
-- @ExpSYM@ context ensures certain invariants (for instance, that there is
|
|
||||||
-- only one of 'get', 'post', 'put', and 'delete' in a value), but
|
|
||||||
-- sometimes requires a little more work.
|
|
||||||
class ExpSYM repr' repr | repr -> repr', repr' -> repr where
|
|
||||||
lit :: String -> repr' -> repr
|
|
||||||
capture :: String -> String -> repr -> repr
|
|
||||||
reqBody :: String -> repr -> repr
|
|
||||||
queryParam :: String -> String -> repr -> repr
|
|
||||||
matrixParam :: String -> String -> repr -> repr
|
|
||||||
conj :: repr' -> repr -> repr
|
|
||||||
get :: String -> repr
|
|
||||||
post :: String -> repr
|
|
||||||
put :: String -> repr
|
|
||||||
delete :: String -> repr
|
|
||||||
|
|
||||||
|
|
||||||
infixr 6 >:
|
|
||||||
|
|
||||||
(>:) :: Type -> Type -> Type
|
|
||||||
(>:) = conj
|
|
||||||
|
|
||||||
|
|
||||||
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
|
|
||||||
matrixParam name typ r = AppT (AppT (ConT ''MatrixParam) (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)
|
|
||||||
delete "()" = ConT ''Delete
|
|
||||||
delete _ = error "Delete does not return a request body"
|
|
||||||
|
|
||||||
parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
|
|
||||||
parseMethod = try (string "GET" >> return get)
|
|
||||||
<|> try (string "POST" >> return post)
|
|
||||||
<|> try (string "PUT" >> return put)
|
|
||||||
<|> try (string "DELETE" >> return delete)
|
|
||||||
|
|
||||||
parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
|
|
||||||
parseUrlSegment = try parseCapture
|
|
||||||
<|> try parseQueryParam
|
|
||||||
<|> try parseLit
|
|
||||||
where
|
|
||||||
parseCapture = do
|
|
||||||
cname <- many (noneOf " ?/:;")
|
|
||||||
char ':'
|
|
||||||
ctyp <- many (noneOf " ?/:;")
|
|
||||||
mx <- many parseMatrixParam
|
|
||||||
return $ capture cname ctyp . foldr (.) id mx
|
|
||||||
parseQueryParam = do
|
|
||||||
char '?'
|
|
||||||
cname <- many (noneOf " ?/:;")
|
|
||||||
char ':'
|
|
||||||
ctyp <- many (noneOf " ?/:;")
|
|
||||||
return $ queryParam cname ctyp
|
|
||||||
parseLit = do
|
|
||||||
lt <- many (noneOf " ?/:;")
|
|
||||||
mx <- many parseMatrixParam
|
|
||||||
return $ lit lt . foldr (.) id mx
|
|
||||||
parseMatrixParam = do
|
|
||||||
char ';'
|
|
||||||
cname <- many (noneOf " ?/:;")
|
|
||||||
char ':'
|
|
||||||
ctyp <- many (noneOf " ?/:;")
|
|
||||||
return $ matrixParam cname ctyp
|
|
||||||
|
|
||||||
parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
|
|
||||||
parseUrl = do
|
|
||||||
optional $ char '/'
|
|
||||||
url <- parseUrlSegment `sepBy1` char '/'
|
|
||||||
return $ foldr1 (.) url
|
|
||||||
|
|
||||||
data Typ = Val String
|
|
||||||
| ReqArgVal String String
|
|
||||||
|
|
||||||
parseTyp :: Parser Typ
|
|
||||||
parseTyp = do
|
|
||||||
f <- many (noneOf "-{\n\r")
|
|
||||||
spaces
|
|
||||||
s <- optionMaybe (try parseRet)
|
|
||||||
try $ optional inlineComment
|
|
||||||
try $ optional blockComment
|
|
||||||
case s of
|
|
||||||
Nothing -> return $ Val (stripTr f)
|
|
||||||
Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
|
|
||||||
where
|
|
||||||
parseRet :: Parser String
|
|
||||||
parseRet = do
|
|
||||||
string "->"
|
|
||||||
spaces
|
|
||||||
many (noneOf "-{\n\r")
|
|
||||||
stripTr = reverse . dropWhile (== ' ') . reverse
|
|
||||||
|
|
||||||
|
|
||||||
parseEntry :: ExpSYM repr repr => Parser repr
|
|
||||||
parseEntry = do
|
|
||||||
met <- parseMethod
|
|
||||||
spaces
|
|
||||||
url <- parseUrl
|
|
||||||
spaces
|
|
||||||
typ <- parseTyp
|
|
||||||
case typ of
|
|
||||||
Val s -> return $ url (met s)
|
|
||||||
ReqArgVal i o -> return $ url $ reqBody i (met o)
|
|
||||||
|
|
||||||
blockComment :: Parser ()
|
|
||||||
blockComment = do
|
|
||||||
string "{-"
|
|
||||||
manyTill anyChar (try $ string "-}")
|
|
||||||
return ()
|
|
||||||
|
|
||||||
inlineComment :: Parser ()
|
|
||||||
inlineComment = do
|
|
||||||
string "--"
|
|
||||||
manyTill anyChar (try $ lookAhead eol)
|
|
||||||
return ()
|
|
||||||
|
|
||||||
eol :: Parser String
|
|
||||||
eol = try (string "\n\r")
|
|
||||||
<|> try (string "\r\n")
|
|
||||||
<|> string "\n"
|
|
||||||
<|> string "\r"
|
|
||||||
<?> "end of line"
|
|
||||||
|
|
||||||
eols :: Parser ()
|
|
||||||
eols = skipMany $ void eol <|> blockComment <|> inlineComment
|
|
||||||
|
|
||||||
parseAll :: Parser Type
|
|
||||||
parseAll = do
|
|
||||||
eols
|
|
||||||
entries <- parseEntry `endBy` eols
|
|
||||||
return $ foldr1 union entries
|
|
||||||
where union :: Type -> Type -> Type
|
|
||||||
union a = AppT (AppT (ConT ''(:<|>)) a)
|
|
||||||
|
|
||||||
-- | The sitemap QuasiQuoter.
|
|
||||||
--
|
|
||||||
-- * @.../<var>:<type>/...@ becomes a capture
|
|
||||||
-- * @.../?<var>:<type>@ becomes a query parameter
|
|
||||||
-- * @<method> ... <typ>@ becomes a method returning @<typ>@
|
|
||||||
-- * @<method> ... <typ1> -> <typ2>@ becomes a method with request
|
|
||||||
-- body of @<typ1>@ and returning @<typ2>@
|
|
||||||
--
|
|
||||||
-- Comments are allowed, and have the standard Haskell format
|
|
||||||
--
|
|
||||||
-- * @--@ for inline
|
|
||||||
-- * @{- ... -}@ for block
|
|
||||||
--
|
|
||||||
sitemap :: QuasiQuoter
|
|
||||||
sitemap = QuasiQuoter { quoteExp = undefined
|
|
||||||
, quotePat = undefined
|
|
||||||
, quoteType = \x -> case parse parseAll "" x of
|
|
||||||
Left err -> error $ show err
|
|
||||||
Right st -> return st
|
|
||||||
, quoteDec = undefined
|
|
||||||
}
|
|
||||||
-}
|
|
||||||
|
|
@ -1,213 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverlappingInstances #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
module Servant.QQSpec where
|
|
||||||
|
|
||||||
import Test.Hspec ( Expectation, Spec, shouldBe, it, describe, pendingWith )
|
|
||||||
|
|
||||||
spec = describe "this" $ it "is" $ pendingWith "playing around"
|
|
||||||
{-
|
|
||||||
import Servant.API
|
|
||||||
( (:<|>),
|
|
||||||
ReqBody,
|
|
||||||
QueryParam,
|
|
||||||
MatrixParam,
|
|
||||||
Put,
|
|
||||||
Get,
|
|
||||||
Post,
|
|
||||||
Capture,
|
|
||||||
(:>),
|
|
||||||
JSON,
|
|
||||||
sitemap )
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------
|
|
||||||
-- Types for testing
|
|
||||||
--------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- Methods ---------------------------------------------------------------
|
|
||||||
type SimpleGet = [sitemap|
|
|
||||||
GET hello ()
|
|
||||||
|]
|
|
||||||
type SimpleGet' = "hello" :> Get '[JSON] ()
|
|
||||||
type SimpleGet'' = "hello" :> Get '[JSON] Bool
|
|
||||||
|
|
||||||
type SimpleGet2 = [sitemap|
|
|
||||||
GET hello Bool
|
|
||||||
|]
|
|
||||||
type SimpleGet2' = "hello" :> Get '[JSON] Bool
|
|
||||||
type SimpleGet2'' = "hello" :> Get '[JSON] Int
|
|
||||||
|
|
||||||
type SimplePost = [sitemap|
|
|
||||||
POST hello ()
|
|
||||||
|]
|
|
||||||
type SimplePost' = "hello" :> Post ()
|
|
||||||
type SimplePost'' = "hello" :> Post Bool
|
|
||||||
|
|
||||||
type SimplePost2 = [sitemap|
|
|
||||||
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
|
|
||||||
|
|
||||||
type SimpleMatrixParam = [sitemap|
|
|
||||||
POST hello;p:Int Bool
|
|
||||||
|]
|
|
||||||
type SimpleMatrixParam' = "hello" :> MatrixParam "p" Int :> Post Bool
|
|
||||||
type SimpleMatrixParam'' = "hello" :> MatrixParam "r" Int :> Post Bool
|
|
||||||
type SimpleMatrixParam''' = "hello" :> MatrixParam "p" Bool :> Post Bool
|
|
||||||
|
|
||||||
type ComplexMatrixParam = [sitemap|
|
|
||||||
POST hello;p:Int;q:String/world;r:Int Bool
|
|
||||||
|]
|
|
||||||
type ComplexMatrixParam' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "r" Int :> Post Bool
|
|
||||||
type ComplexMatrixParam'' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "s" Int :> Post Bool
|
|
||||||
type ComplexMatrixParam''' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "r" Bool :> Post Bool
|
|
||||||
|
|
||||||
-- Combinations ----------------------------------------------------------
|
|
||||||
|
|
||||||
type TwoPaths = [sitemap|
|
|
||||||
POST hello Bool
|
|
||||||
GET hello Bool
|
|
||||||
|]
|
|
||||||
type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get '[JSON] Bool)
|
|
||||||
|
|
||||||
type WithInlineComments = [sitemap|
|
|
||||||
GET hello Bool -- This is a comment
|
|
||||||
|]
|
|
||||||
type WithInlineComments' = "hello" :> Get '[JSON] Bool
|
|
||||||
|
|
||||||
type WithInlineComments2 = [sitemap|
|
|
||||||
GET hello Bool
|
|
||||||
-- This is a comment
|
|
||||||
|]
|
|
||||||
type WithInlineComments2' = "hello" :> Get '[JSON] Bool
|
|
||||||
|
|
||||||
|
|
||||||
type WithBlockComments = [sitemap|
|
|
||||||
GET hello Bool {-
|
|
||||||
POST hello Bool
|
|
||||||
-}
|
|
||||||
|]
|
|
||||||
type WithBlockComments' = "hello" :> Get '[JSON] Bool
|
|
||||||
|
|
||||||
type WithBlockComments2 = [sitemap|
|
|
||||||
GET hello Bool {-
|
|
||||||
POST hello Bool
|
|
||||||
-}
|
|
||||||
POST hello Bool
|
|
||||||
|]
|
|
||||||
type WithBlockComments2' = ("hello" :> Get '[JSON] Bool) :<|> ("hello" :> Post Bool)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------
|
|
||||||
-- Spec
|
|
||||||
--------------------------------------------------------------------------
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = do
|
|
||||||
describe "'sitemap' QuasiQuoter" $ do
|
|
||||||
it "Handles simple GET types" $ do
|
|
||||||
(u::SimpleGet) ~= (u::SimpleGet' ) ~> True
|
|
||||||
(u::SimpleGet) ~= (u::SimpleGet'' ) ~> False
|
|
||||||
(u::SimpleGet2) ~= (u::SimpleGet2' ) ~> True
|
|
||||||
(u::SimpleGet2) ~= (u::SimpleGet2'') ~> False
|
|
||||||
it "Handles simple POST types" $ do
|
|
||||||
(u::SimplePost) ~= (u::SimplePost' ) ~> True
|
|
||||||
(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 simple matrix parameters" $ do
|
|
||||||
(u::SimpleMatrixParam) ~= (u::SimpleMatrixParam' ) ~> True
|
|
||||||
(u::SimpleMatrixParam) ~= (u::SimpleMatrixParam'') ~> False
|
|
||||||
(u::SimpleMatrixParam) ~= (u::SimpleMatrixParam''') ~> False
|
|
||||||
it "Handles more complex matrix parameters" $ do
|
|
||||||
(u::ComplexMatrixParam) ~= (u::ComplexMatrixParam' ) ~> True
|
|
||||||
(u::ComplexMatrixParam) ~= (u::ComplexMatrixParam'') ~> False
|
|
||||||
(u::ComplexMatrixParam) ~= (u::ComplexMatrixParam''') ~> False
|
|
||||||
it "Handles multiples paths" $ do
|
|
||||||
(u::TwoPaths) ~= (u::TwoPaths') ~> True
|
|
||||||
it "Ignores inline comments" $ do
|
|
||||||
(u::WithInlineComments) ~= (u::WithInlineComments') ~> True
|
|
||||||
(u::WithInlineComments2) ~= (u::WithInlineComments2') ~> True
|
|
||||||
it "Ignores inline comments" $ do
|
|
||||||
(u::WithBlockComments) ~= (u::WithBlockComments') ~> True
|
|
||||||
(u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True
|
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------
|
|
||||||
-- Utilities
|
|
||||||
--------------------------------------------------------------------------
|
|
||||||
data HTrue
|
|
||||||
data HFalse
|
|
||||||
|
|
||||||
-- Kiselyov's Type Equality predicate
|
|
||||||
class TypeEq x y b | x y -> b where { areEq :: x -> y -> Bool }
|
|
||||||
instance TypeEq x x HTrue where { areEq _ _ = True }
|
|
||||||
instance b ~ HFalse => TypeEq x y b where { areEq _ _ = False}
|
|
||||||
|
|
||||||
infix 4 ~=
|
|
||||||
(~=) :: TypeEq x y b => x -> y -> Bool
|
|
||||||
(~=) = areEq
|
|
||||||
|
|
||||||
u :: a
|
|
||||||
u = undefined
|
|
||||||
|
|
||||||
infix 3 ~>
|
|
||||||
(~>) :: (Show a, Eq a) => a -> a -> Expectation
|
|
||||||
(~>) = shouldBe
|
|
||||||
Loading…
Reference in a new issue