@@ -0,0 +1,54 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+module Servant.API.TypeLevel.Prune
3+ ( Prune
4+ , Wild
5+ )
6+ where
7+
8+import Servant.API
9+import Servant.API.TypeLevel
10+
11+
12+-- | On the left hand side of 'IsElem' and 'Prune',
13+-- @UVerb ... ... '[Wild]@ will match any return result type.
14+data Wild
15+type instance IsElem' (UVerb m ct '[Wild]) (Verb m s ct' _) = IsSubList ct ct'
16+type instance IsElem' (UVerb m ct '[Wild]) (UVerb m ct' _) = IsSubList ct ct'
17+
18+type instance IsElem' sa (Description _ :> sb) = IsElem sa sb
19+type instance IsElem' sa (AuthProtect _ :> sb) = IsElem sa sb
20+type instance IsElem' sa (QueryParam' _ _ _ :> sb) = IsElem sa sb
21+
22+-- | Restrict the API in @api@ to the endpoints in @mask@. This works similarly
23+-- to 'IsElem' in that the @mask@ doesn't have to specify non-path parameters.
24+-- Additionally, 'Wild' can be used as a wildcard for the return type of a
25+-- request.
26+type family Prune (mask :: *) (api :: *) :: * where
27+ -- The instances mimic 'IsElem' and the 'IsElem'' instances above
28+ Prune sa (sb :<|> sc) = Prune sa sb ?<|> Prune sa sc
29+ Prune (e :> sa) (e :> sb) = e ?> Prune sa sb
30+ Prune sa (Header sym x :> sb) = Header sym x ?> Prune sa sb
31+ Prune sa (ReqBody y x :> sb) = ReqBody y x ?> Prune sa sb
32+ Prune (CaptureAll z y :> sa) (CaptureAll x y :> sb) = CaptureAll x y ?> Prune sa sb
33+ Prune (Capture z y :> sa) (Capture x y :> sb) = Capture x y ?> Prune sa sb
34+ Prune sa (QueryParam' x y z :> sb) = QueryParam' x y z ?> Prune sa sb
35+ Prune sa (QueryParams x y :> sb) = QueryParams x y ?> Prune sa sb
36+ Prune sa (QueryFlag x :> sb) = QueryFlag x ?> Prune sa sb
37+ Prune sa (Fragment x :> sb) = Fragment x ?> Prune sa sb
38+ Prune sa (Description x :> sb) = Description x ?> Prune sa sb
39+ Prune sa (AuthProtect x :> sb) = AuthProtect x ?> Prune sa sb
40+ Prune (Verb m s ct typ) (Verb m s ct typ) = Verb m s ct typ
41+ Prune (UVerb m ct typs) (UVerb m ct typs) = UVerb m ct typs
42+ Prune (UVerb m ct '[Wild]) (Verb m s ct typ) = Verb m s ct typ
43+ Prune (UVerb m ct '[Wild]) (UVerb m ct typs) = UVerb m ct typs
44+ Prune (sa :<|> sb) sc = Prune sa sc ?<|> Prune sb sc
45+ Prune sa sb = EmptyAPI
46+
47+type family (?>) (path :: k) (api :: *) :: * where
48+ path ?> EmptyAPI = EmptyAPI
49+ path ?> api = path :> api
50+
51+type family (?<|>) (api :: *) (api' :: *) :: * where
52+ EmptyAPI ?<|> sa = sa
53+ sa ?<|> EmptyAPI = sa
54+ sa ?<|> sb = sa :<|> sb