Remove QQ for now
This commit is contained in:
Julian K. Arni
parent
99374c5868
commit
5470297bdc
|
|
@ -41,7 +41,6 @@ library
|
|||
Servant.API.ReqBody
|
||||
Servant.API.Sub
|
||||
Servant.Common.Text
|
||||
Servant.QQ
|
||||
Servant.Utils.Links
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
|
|
|
|||
|
|
@ -38,8 +38,6 @@ module Servant.API (
|
|||
module Servant.API.Raw,
|
||||
|
||||
-- * Utilities
|
||||
-- | QuasiQuotes for endpoints
|
||||
module Servant.QQ,
|
||||
-- | Type-safe internal URIs
|
||||
module Servant.Utils.Links,
|
||||
) where
|
||||
|
|
@ -59,5 +57,4 @@ import Servant.API.MatrixParam ( MatrixFlag, MatrixParams, MatrixParam )
|
|||
import Servant.API.Raw ( Raw )
|
||||
import Servant.API.ReqBody ( ReqBody )
|
||||
import Servant.API.Sub ( (:>)(..) )
|
||||
import Servant.QQ ( sitemap )
|
||||
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 New Issue
Block a user