@@ -1,29 +1,51 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE ConstraintKinds #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE KindSignatures #-}
85{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+{-|
12+This module collects utilities for manipulating @servant@ API types. The
13+functionality in this module is for advanced usage.
14+
15+The code samples in this module use the following type synonym:
16+
17+> type SampleAPI = "hello" :> Get '[JSON] Int
18+> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
19+
20+-}
1021module Servant.API.TypeLevel where
1122
12−import GHC.Exts(Constraint)
13−import Servant.API.Capture ( Capture, CaptureAll )
14−import Servant.API.ReqBody ( ReqBody )
15−import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
16−import Servant.API.Header ( Header )
17−import Servant.API.Verbs ( Verb )
18−import Servant.API.Sub ( type (:>) )
19−import Servant.API.Alternative ( type (:<|>) )
23+
24+import GHC.Exts (Constraint)
25+import Servant.API.Alternative (type (:<|>))
26+import Servant.API.Capture (Capture, CaptureAll)
27+import Servant.API.Header (Header)
28+import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)
29+import Servant.API.ReqBody (ReqBody)
30+import Servant.API.Sub (type (:>))
31+import Servant.API.Verbs (Verb)
2032#if MIN_VERSION_base(4,9,0)
21−import GHC.TypeLits (TypeError, ErrorMessage(..))
33+import GHC.TypeLits (TypeError, ErrorMessage(..))
2234#endif
2335
36+
37+
2438-- * API predicates
2539
2640-- | Flatten API into a list of endpoints.
41+--
42+-- >>> :t showType @(Endpoints SampleAPI)
43+-- ...
44+-- ... :: Proxy
45+-- ... '["hello" :> Verb 'GET 200 '[JSON] Int,
46+-- ... "bye"
47+-- ... :> (Capture "name" String
48+-- ... :> Verb 'POST 200 '[JSON, PlainText] Bool)]
2749type family Endpoints api where
2850 Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b)
2951 Endpoints (e :> a) = MapSub e (Endpoints a)
@@ -47,24 +69,56 @@ type family IsElem' a s :: Constraint
4769
4870-- | Closed type family, check if @endpoint@ is within @api@.
4971-- Uses @'IsElem''@ if it exhausts all other options.
72+--
73+-- >>> ok @(IsElem ("hello" :> Get '[JSON] Int) SampleAPI)
74+-- OK
75+--
76+-- >>> ok @(IsElem ("bye" :> Get '[JSON] Int) SampleAPI)
77+-- ...
78+-- ... Could not deduce: ...
79+-- ...
80+--
81+-- An endpoint is considered within an api even if it is missing combinators
82+-- that don't affect the URL:
83+--
84+-- >>> ok @(IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))
85+-- OK
86+--
87+-- >>> ok @(IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int))
88+-- OK
89+--
90+-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL
91+-- represented by @a@ would match the URL represented by @b@, *not* whether a
92+-- request represented by @a@ matches the endpoints serving @b@ (for the
93+-- latter, use 'IsIn').
5094type family IsElem endpoint api :: Constraint where
51− IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
52− IsElem (e :> sa) (e :> sb) = IsElem sa sb
53− IsElem sa (Header sym x :> sb) = IsElem sa sb
54− IsElem sa (ReqBody y x :> sb) = IsElem sa sb
55− IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
56− = IsElem sa sb
57− IsElem (Capture z y :> sa) (Capture x y :> sb)
58− = IsElem sa sb
59− IsElem sa (QueryParam x y :> sb) = IsElem sa sb
60− IsElem sa (QueryParams x y :> sb) = IsElem sa sb
61− IsElem sa (QueryFlag x :> sb) = IsElem sa sb
62− IsElem (Verb m s ct typ) (Verb m s ct' typ)
63− = IsSubList ct ct'
64− IsElem e e = ()
65− IsElem e a = IsElem' e a
66−
67−-- | Check whether @sub@ is a sub API of @api@.
95+ IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
96+ IsElem (e :> sa) (e :> sb) = IsElem sa sb
97+ IsElem sa (Header sym x :> sb) = IsElem sa sb
98+ IsElem sa (ReqBody y x :> sb) = IsElem sa sb
99+ IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
100+ = IsElem sa sb
101+ IsElem (Capture z y :> sa) (Capture x y :> sb)
102+ = IsElem sa sb
103+ IsElem sa (QueryParam x y :> sb) = IsElem sa sb
104+ IsElem sa (QueryParams x y :> sb) = IsElem sa sb
105+ IsElem sa (QueryFlag x :> sb) = IsElem sa sb
106+ IsElem (Verb m s ct typ) (Verb m s ct' typ)
107+ = IsSubList ct ct'
108+ IsElem e e = ()
109+ IsElem e a = IsElem' e a
110+
111+-- | Check whether @sub@ is a sub-API of @api@.
112+--
113+-- >>> ok @(IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int))
114+-- OK
115+--
116+-- >>> ok @(IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI)
117+-- ...
118+-- ... Could not deduce: ...
119+-- ...
120+--
121+-- This uses @IsElem@ for checking; thus the note there applies here.
68122type family IsSubAPI sub api :: Constraint where
69123 IsSubAPI sub api = AllIsElem (Endpoints sub) api
70124
@@ -76,18 +130,31 @@ type family AllIsElem xs api :: Constraint where
76130-- ** Strict inclusion
77131
78132-- | Closed type family, check if @endpoint@ is exactly within @api@.
79−-- We aren't sure what affects how an endpoint is built up, so we require an
80−-- exact match.
133+--
134+-- >>> ok @(IsIn ("hello" :> Get '[JSON] Int) SampleAPI)
135+-- OK
136+--
137+-- Unlike 'IsElem', this requires an *exact* match.
138+--
139+-- >>> ok @(IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))
140+-- ...
141+-- ... Could not deduce: ...
142+-- ...
81143type family IsIn (endpoint :: *) (api :: *) :: Constraint where
82− IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
83− IsIn (e :> sa) (e :> sb) = IsIn sa sb
84− IsIn e e = ()
144+ IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
145+ IsIn (e :> sa) (e :> sb) = IsIn sa sb
146+ IsIn e e = ()
85147
86148-- | Check whether @sub@ is a sub API of @api@.
149+--
150+-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'.
87151type family IsStrictSubAPI sub api :: Constraint where
88152 IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api
89153
90154-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).
155+--
156+-- OK @(AllIsIn (Endpoints SampleAPI) SampleAPI)
157+-- OK
91158type family AllIsIn xs api :: Constraint where
92159 AllIsIn '[] api = ()
93160 AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api)
@@ -107,45 +174,31 @@ type family AppendList xs ys where
107174 AppendList (x ': xs) ys = x ': AppendList xs ys
108175
109176type family IsSubList a b :: Constraint where
110− IsSubList '[] b = ()
111− IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
177+ IsSubList '[] b = ()
178+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
112179
113−#if !MIN_VERSION_base(4,9,0)
114−-- | Check that a value is an element of a list:
115−--
116−-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
117−-- OK
118−--
119−-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))
120−-- ...
121−-- No instance for (ElemNotFoundIn [Char] '[Int, Bool])
122−-- arising from a use of ‘ok’
123−-- ...
124−type Elem e es = ElemGo e es es
125−#else
126180-- | Check that a value is an element of a list:
127181--
128−-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
182+-- >>> ok @(Elem Bool '[Int, Bool])
129183-- OK
130184--
131−-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))
185+-- >>> ok @(Elem String '[Int, Bool])
132186-- ...
133187-- ... [Char] expected in list '[Int, Bool]
134188-- ...
135189type Elem e es = ElemGo e es es
136−#endif
137190
138191-- 'orig' is used to store original list for better error messages
139192type family ElemGo e es orig :: Constraint where
140− ElemGo x (x ': xs) orig = ()
141− ElemGo y (x ': xs) orig = ElemGo y xs orig
193+ ElemGo x (x ': xs) orig = ()
194+ ElemGo y (x ': xs) orig = ElemGo y xs orig
142195#if MIN_VERSION_base(4,9,0)
143− -- Note [Custom Errors]
144− ElemGo x '[] orig = TypeError ('ShowType x
145− ':<>: 'Text " expected in list "
146− ':<>: 'ShowType orig)
196+ -- Note [Custom Errors]
197+ ElemGo x '[] orig = TypeError ('ShowType x
198+ ':<>: 'Text " expected in list "
199+ ':<>: 'ShowType orig)
147200#else
148− ElemGo x '[] orig = ElemNotFoundIn x orig
201+ ElemGo x '[] orig = ElemNotFoundIn x orig
149202#endif
150203
151204-- ** Logic
@@ -154,12 +207,12 @@ type family ElemGo e es orig :: Constraint where
154207type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
155208 -- This works because of:
156209 -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap
157− Or () b = ()
158− Or a () = ()
210+ Or () b = ()
211+ Or a () = ()
159212
160213-- | If both a or b produce an empty constraint, produce an empty constraint.
161214type family And (a :: Constraint) (b :: Constraint) :: Constraint where
162− And () () = ()
215+ And () () = ()
163216
164217-- * Custom type errors
165218
@@ -173,7 +226,14 @@ We might try to factor these our more cleanly, but the type synonyms and type
173226families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
174227-}
175228
229+
176230-- $setup
231+-- >>> :set -XTypeApplications
232+-- >>> :set -XPolyKinds
177233-- >>> import Data.Proxy
178−-- >>> data OK = OK deriving (Show)
179−-- >>> let ok :: ctx => Proxy ctx -> OK; ok _ = OK
234+-- >>> import Servant.API
235+-- >>> data OK ctx = OK deriving (Show)
236+-- >>> let ok :: ctx => OK ctx; ok = OK
237+-- >>> let showType :: Proxy a ; showType = Proxy
238+-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
239+-- >>> let sampleAPI = Proxy :: Proxy SampleAPI