Move type-level operations from Utils.Links to API.TypeLevel

Author: fizruk

servant/servant.cabal

@@ -47,6 +47,7 @@ library
     Servant.API.ReqBody
     Servant.API.ResponseHeaders
     Servant.API.Sub
+    Servant.API.TypeLevel
     Servant.API.Vault
     Servant.API.Verbs
     Servant.API.WithNamedContext

servant/src/Servant/API/TypeLevel.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Servant.API.TypeLevel where
+
+import GHC.Exts(Constraint)
+import Servant.API.Capture ( Capture )
+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 (:<|>) )
+
+-- * API predicates
+
+-- | You may use this type family to tell the type checker that your custom
+-- type may be skipped as part of a link. This is useful for things like
+-- 'QueryParam' that are optional in a URI and do not affect them if they are
+-- omitted.
+--
+-- >>> data CustomThing
+-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s
+--
+-- Note that 'IsElem' is called, which will mutually recurse back to `IsElem'`
+-- if it exhausts all other options again.
+--
+-- Once you have written a HasLink instance for CustomThing you are ready to
+-- go.
+type family IsElem' a s :: Constraint
+
+-- | Closed type family, check if @endpoint@ is within @api@.
+-- Uses @'IsElem''@.
+type family IsElem endpoint api :: Constraint where
+    IsElem e (sa :<|> sb)                   = Or (IsElem e sa) (IsElem e sb)
+    IsElem (e :> sa) (e :> sb)              = IsElem sa sb
+    IsElem sa (Header sym x :> sb)          = IsElem sa sb
+    IsElem sa (ReqBody y x :> sb)           = IsElem sa sb
+    IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
+                                            = IsElem sa sb
+    IsElem (Capture z y :> sa) (Capture x y :> sb)
+                                            = IsElem sa sb
+    IsElem sa (QueryParam x y :> sb)        = IsElem sa sb
+    IsElem sa (QueryParams x y :> sb)       = IsElem sa sb
+    IsElem sa (QueryFlag x :> sb)           = IsElem sa sb
+    IsElem (Verb m s ct typ) (Verb m s ct' typ)
+                                            = IsSubList ct ct'
+    IsElem e e                              = ()
+    IsElem e a                              = IsElem' e a
+
+-- * Helpers
+
+-- ** Lists
+
+type family IsSubList a b :: Constraint where
+    IsSubList '[] b          = ()
+    IsSubList (x ': xs) y    = Elem x y `And` IsSubList xs y
+
+type family Elem e es :: Constraint where
+    Elem x (x ': xs) = ()
+    Elem y (x ': xs) = Elem y xs
+
+-- ** Logic
+
+-- | If either a or b produce an empty constraint, produce an empty constraint.
+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
+    -- This works because of:
+    -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap
+    Or () b       = ()
+    Or a ()       = ()
+
+-- | If both a or b produce an empty constraint, produce an empty constraint.
+type family And (a :: Constraint) (b :: Constraint) :: Constraint where
+    And () ()     = ()
+

servant/src/Servant/Utils/Links.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
-{-# LANGUAGE UndecidableInstances   #-}
 {-# OPTIONS_HADDOCK not-home        #-}
 
 -- | Type safe generation of internal links.
@@ -79,6 +78,8 @@
 --  bad_link under api after trying the open (but empty) type family
 --  `IsElem'` as a last resort.
 module Servant.Utils.Links (
+  module Servant.API.TypeLevel,
+
   -- * Building and using safe links
   --
   -- | Note that 'URI' is Network.URI.URI from the network-uri package.
@@ -88,18 +89,13 @@ module Servant.Utils.Links (
   , HasLink(..)
   , linkURI
   , Link
-  , IsElem'
-  -- * Illustrative exports
-  , IsElem
-  , Or
 ) where
 
 import           Data.List
 import           Data.Monoid.Compat    ( (<>) )
 import           Data.Proxy            ( Proxy(..) )
 import qualified Data.Text             as Text
 import qualified Data.Text.Encoding    as TE
-import           GHC.Exts              (Constraint)
 import           GHC.TypeLits          ( KnownSymbol, symbolVal )
 import           Network.URI           ( URI(..), escapeURIString, isUnreserved )
 import           Prelude               ()
@@ -115,7 +111,7 @@ import Servant.API.RemoteHost ( RemoteHost )
 import Servant.API.Verbs ( Verb )
 import Servant.API.Sub ( type (:>) )
 import Servant.API.Raw ( Raw )
-import Servant.API.Alternative ( type (:<|>) )
+import Servant.API.TypeLevel
 
 -- | A safe link datatype.
 -- The only way of constructing a 'Link' is using 'safeLink', which means any
@@ -131,58 +127,6 @@ instance ToHttpApiData Link where
         let uri = linkURI l
         in Text.pack $ uriPath uri ++ uriQuery uri
 
--- | If either a or b produce an empty constraint, produce an empty constraint.
-type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
-    -- This works because of:
-    -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap
-    Or () b       = ()
-    Or a ()       = ()
-
--- | If both a or b produce an empty constraint, produce an empty constraint.
-type family And (a :: Constraint) (b :: Constraint) :: Constraint where
-    And () ()     = ()
-
--- | You may use this type family to tell the type checker that your custom
--- type may be skipped as part of a link. This is useful for things like
--- 'QueryParam' that are optional in a URI and do not affect them if they are
--- omitted.
---
--- >>> data CustomThing
--- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s
---
--- Note that 'IsElem' is called, which will mutually recurse back to `IsElem'`
--- if it exhausts all other options again.
---
--- Once you have written a HasLink instance for CustomThing you are ready to
--- go.
-type family IsElem' a s :: Constraint
-
--- | Closed type family, check if endpoint is within api
-type family IsElem endpoint api :: Constraint where
-    IsElem e (sa :<|> sb)                   = Or (IsElem e sa) (IsElem e sb)
-    IsElem (e :> sa) (e :> sb)              = IsElem sa sb
-    IsElem sa (Header sym x :> sb)          = IsElem sa sb
-    IsElem sa (ReqBody y x :> sb)           = IsElem sa sb
-    IsElem (Capture z y :> sa) (Capture x y :> sb)
-                                            = IsElem sa sb
-    IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
-                                            = IsElem sa sb
-    IsElem sa (QueryParam x y :> sb)        = IsElem sa sb
-    IsElem sa (QueryParams x y :> sb)       = IsElem sa sb
-    IsElem sa (QueryFlag x :> sb)           = IsElem sa sb
-    IsElem (Verb m s ct typ) (Verb m s ct' typ)
-                                            = IsSubList ct ct'
-    IsElem e e                              = ()
-    IsElem e a                              = IsElem' e a
-
-type family IsSubList a b :: Constraint where
-    IsSubList '[] b          = ()
-    IsSubList (x ': xs) y    = Elem x y `And` IsSubList xs y
-
-type family Elem e es :: Constraint where
-    Elem x (x ': xs) = ()
-    Elem y (x ': xs) = Elem y xs
-
 -- Phantom types for Param
 data Query
 

servant/test/Servant/Utils/LinksSpec.hs

@@ -10,6 +10,7 @@ import           Test.Hspec              (Expectation, Spec, describe, it,
 import           Data.String             (fromString)
 
 import           Servant.API
+import           Servant.API.TypeLevel
 
 type TestApi =
   -- Capture and query params