servant/test/Servant/QQSpec.hs

{-# 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

import Servant.API

--------------------------------------------------------------------------
-- Types for testing
--------------------------------------------------------------------------

-- Methods ---------------------------------------------------------------
type SimpleGet = [sitemap|
GET  hello  ()
|]
type SimpleGet' = "hello" :> Get ()
type SimpleGet'' = "hello" :> Get Bool

type SimpleGet2 = [sitemap|
GET  hello  Bool
|]
type SimpleGet2' = "hello" :> Get Bool
type SimpleGet2'' = "hello" :> Get 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

-- Combinations ----------------------------------------------------------

type TwoPaths = [sitemap|
POST hello  Bool
GET  hello  Bool
|]
type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool)

type WithInlineComments = [sitemap|
GET  hello  Bool   -- This is a comment
|]
type WithInlineComments' = "hello" :> Get Bool

type WithInlineComments2 = [sitemap|
GET  hello  Bool
-- This is a comment
|]
type WithInlineComments2' = "hello" :> Get Bool


type WithBlockComments = [sitemap|
GET  hello  Bool   {-
POST hello  Bool
-}
|]
type WithBlockComments' = "hello" :> Get Bool

type WithBlockComments2 = [sitemap|
GET  hello  Bool   {-
POST hello  Bool
-}
POST hello Bool
|]
type WithBlockComments2' = ("hello" :> Get 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 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