diff --git a/servant/servant.cabal b/servant/servant.cabal index 79d08e39..ffb627e0 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs new file mode 100644 index 00000000..9a78639f --- /dev/null +++ b/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 () () = () + diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index c4cfea26..618bb2aa 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/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,10 +89,6 @@ module Servant.Utils.Links ( , HasLink(..) , linkURI , Link - , IsElem' - -- * Illustrative exports - , IsElem - , Or ) where import Data.List @@ -99,7 +96,6 @@ 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 diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 6a6bb8dc..fbc5ce0b 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/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