Loads of documetation and doctests.
This commit is contained in:
parent
02e4281d51
commit
931e67f347
1 changed files with 128 additions and 68 deletions
|
@ -1,29 +1,51 @@
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE KindSignatures #-}
|
{-# LANGUAGE KindSignatures #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
{-|
|
||||||
|
This module collects utilities for manipulating @servant@ API types. The
|
||||||
|
functionality in this module is for advanced usage.
|
||||||
|
|
||||||
|
The code samples in this module use the following type synonym:
|
||||||
|
|
||||||
|
> type SampleAPI = "hello" :> Get '[JSON] Int
|
||||||
|
> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
|
||||||
|
|
||||||
|
-}
|
||||||
module Servant.API.TypeLevel where
|
module Servant.API.TypeLevel where
|
||||||
|
|
||||||
|
|
||||||
import GHC.Exts (Constraint)
|
import GHC.Exts (Constraint)
|
||||||
import Servant.API.Capture ( Capture, CaptureAll )
|
|
||||||
import Servant.API.ReqBody ( ReqBody )
|
|
||||||
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
|
|
||||||
import Servant.API.Header ( Header )
|
|
||||||
import Servant.API.Verbs ( Verb )
|
|
||||||
import Servant.API.Sub ( type (:>) )
|
|
||||||
import Servant.API.Alternative (type (:<|>))
|
import Servant.API.Alternative (type (:<|>))
|
||||||
|
import Servant.API.Capture (Capture, CaptureAll)
|
||||||
|
import Servant.API.Header (Header)
|
||||||
|
import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)
|
||||||
|
import Servant.API.ReqBody (ReqBody)
|
||||||
|
import Servant.API.Sub (type (:>))
|
||||||
|
import Servant.API.Verbs (Verb)
|
||||||
#if MIN_VERSION_base(4,9,0)
|
#if MIN_VERSION_base(4,9,0)
|
||||||
import GHC.TypeLits (TypeError, ErrorMessage(..))
|
import GHC.TypeLits (TypeError, ErrorMessage(..))
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- * API predicates
|
-- * API predicates
|
||||||
|
|
||||||
-- | Flatten API into a list of endpoints.
|
-- | Flatten API into a list of endpoints.
|
||||||
|
--
|
||||||
|
-- >>> :t showType @(Endpoints SampleAPI)
|
||||||
|
-- ...
|
||||||
|
-- ... :: Proxy
|
||||||
|
-- ... '["hello" :> Verb 'GET 200 '[JSON] Int,
|
||||||
|
-- ... "bye"
|
||||||
|
-- ... :> (Capture "name" String
|
||||||
|
-- ... :> Verb 'POST 200 '[JSON, PlainText] Bool)]
|
||||||
type family Endpoints api where
|
type family Endpoints api where
|
||||||
Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b)
|
Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b)
|
||||||
Endpoints (e :> a) = MapSub e (Endpoints a)
|
Endpoints (e :> a) = MapSub e (Endpoints a)
|
||||||
|
@ -47,6 +69,28 @@ type family IsElem' a s :: Constraint
|
||||||
|
|
||||||
-- | Closed type family, check if @endpoint@ is within @api@.
|
-- | Closed type family, check if @endpoint@ is within @api@.
|
||||||
-- Uses @'IsElem''@ if it exhausts all other options.
|
-- Uses @'IsElem''@ if it exhausts all other options.
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsElem ("hello" :> Get '[JSON] Int) SampleAPI)
|
||||||
|
-- OK
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsElem ("bye" :> Get '[JSON] Int) SampleAPI)
|
||||||
|
-- ...
|
||||||
|
-- ... Could not deduce: ...
|
||||||
|
-- ...
|
||||||
|
--
|
||||||
|
-- An endpoint is considered within an api even if it is missing combinators
|
||||||
|
-- that don't affect the URL:
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))
|
||||||
|
-- OK
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int))
|
||||||
|
-- OK
|
||||||
|
--
|
||||||
|
-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL
|
||||||
|
-- represented by @a@ would match the URL represented by @b@, *not* whether a
|
||||||
|
-- request represented by @a@ matches the endpoints serving @b@ (for the
|
||||||
|
-- latter, use 'IsIn').
|
||||||
type family IsElem endpoint api :: Constraint where
|
type family IsElem endpoint api :: Constraint where
|
||||||
IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
|
IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
|
||||||
IsElem (e :> sa) (e :> sb) = IsElem sa sb
|
IsElem (e :> sa) (e :> sb) = IsElem sa sb
|
||||||
|
@ -64,7 +108,17 @@ type family IsElem endpoint api :: Constraint where
|
||||||
IsElem e e = ()
|
IsElem e e = ()
|
||||||
IsElem e a = IsElem' e a
|
IsElem e a = IsElem' e a
|
||||||
|
|
||||||
-- | Check whether @sub@ is a sub API of @api@.
|
-- | Check whether @sub@ is a sub-API of @api@.
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int))
|
||||||
|
-- OK
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI)
|
||||||
|
-- ...
|
||||||
|
-- ... Could not deduce: ...
|
||||||
|
-- ...
|
||||||
|
--
|
||||||
|
-- This uses @IsElem@ for checking; thus the note there applies here.
|
||||||
type family IsSubAPI sub api :: Constraint where
|
type family IsSubAPI sub api :: Constraint where
|
||||||
IsSubAPI sub api = AllIsElem (Endpoints sub) api
|
IsSubAPI sub api = AllIsElem (Endpoints sub) api
|
||||||
|
|
||||||
|
@ -76,18 +130,31 @@ type family AllIsElem xs api :: Constraint where
|
||||||
-- ** Strict inclusion
|
-- ** Strict inclusion
|
||||||
|
|
||||||
-- | Closed type family, check if @endpoint@ is exactly within @api@.
|
-- | Closed type family, check if @endpoint@ is exactly within @api@.
|
||||||
-- We aren't sure what affects how an endpoint is built up, so we require an
|
--
|
||||||
-- exact match.
|
-- >>> ok @(IsIn ("hello" :> Get '[JSON] Int) SampleAPI)
|
||||||
|
-- OK
|
||||||
|
--
|
||||||
|
-- Unlike 'IsElem', this requires an *exact* match.
|
||||||
|
--
|
||||||
|
-- >>> ok @(IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))
|
||||||
|
-- ...
|
||||||
|
-- ... Could not deduce: ...
|
||||||
|
-- ...
|
||||||
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
||||||
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
||||||
IsIn (e :> sa) (e :> sb) = IsIn sa sb
|
IsIn (e :> sa) (e :> sb) = IsIn sa sb
|
||||||
IsIn e e = ()
|
IsIn e e = ()
|
||||||
|
|
||||||
-- | Check whether @sub@ is a sub API of @api@.
|
-- | Check whether @sub@ is a sub API of @api@.
|
||||||
|
--
|
||||||
|
-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'.
|
||||||
type family IsStrictSubAPI sub api :: Constraint where
|
type family IsStrictSubAPI sub api :: Constraint where
|
||||||
IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api
|
IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api
|
||||||
|
|
||||||
-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).
|
-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).
|
||||||
|
--
|
||||||
|
-- OK @(AllIsIn (Endpoints SampleAPI) SampleAPI)
|
||||||
|
-- OK
|
||||||
type family AllIsIn xs api :: Constraint where
|
type family AllIsIn xs api :: Constraint where
|
||||||
AllIsIn '[] api = ()
|
AllIsIn '[] api = ()
|
||||||
AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api)
|
AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api)
|
||||||
|
@ -110,30 +177,16 @@ type family IsSubList a b :: Constraint where
|
||||||
IsSubList '[] b = ()
|
IsSubList '[] b = ()
|
||||||
IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
|
IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,9,0)
|
|
||||||
-- | Check that a value is an element of a list:
|
-- | Check that a value is an element of a list:
|
||||||
--
|
--
|
||||||
-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
|
-- >>> ok @(Elem Bool '[Int, Bool])
|
||||||
-- OK
|
-- OK
|
||||||
--
|
--
|
||||||
-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))
|
-- >>> ok @(Elem String '[Int, Bool])
|
||||||
-- ...
|
|
||||||
-- No instance for (ElemNotFoundIn [Char] '[Int, Bool])
|
|
||||||
-- arising from a use of ‘ok’
|
|
||||||
-- ...
|
|
||||||
type Elem e es = ElemGo e es es
|
|
||||||
#else
|
|
||||||
-- | Check that a value is an element of a list:
|
|
||||||
--
|
|
||||||
-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
|
|
||||||
-- OK
|
|
||||||
--
|
|
||||||
-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))
|
|
||||||
-- ...
|
-- ...
|
||||||
-- ... [Char] expected in list '[Int, Bool]
|
-- ... [Char] expected in list '[Int, Bool]
|
||||||
-- ...
|
-- ...
|
||||||
type Elem e es = ElemGo e es es
|
type Elem e es = ElemGo e es es
|
||||||
#endif
|
|
||||||
|
|
||||||
-- 'orig' is used to store original list for better error messages
|
-- 'orig' is used to store original list for better error messages
|
||||||
type family ElemGo e es orig :: Constraint where
|
type family ElemGo e es orig :: Constraint where
|
||||||
|
@ -173,7 +226,14 @@ We might try to factor these our more cleanly, but the type synonyms and type
|
||||||
families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
|
families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
|
-- >>> :set -XTypeApplications
|
||||||
|
-- >>> :set -XPolyKinds
|
||||||
-- >>> import Data.Proxy
|
-- >>> import Data.Proxy
|
||||||
-- >>> data OK = OK deriving (Show)
|
-- >>> import Servant.API
|
||||||
-- >>> let ok :: ctx => Proxy ctx -> OK; ok _ = OK
|
-- >>> data OK ctx = OK deriving (Show)
|
||||||
|
-- >>> let ok :: ctx => OK ctx; ok = OK
|
||||||
|
-- >>> let showType :: Proxy a ; showType = Proxy
|
||||||
|
-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
|
||||||
|
-- >>> let sampleAPI = Proxy :: Proxy SampleAPI
|
||||||
|
|
Loading…
Reference in a new issue