diff --git a/servant/servant.cabal b/servant/servant.cabal index f2e7359f..4c23da32 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -55,6 +55,7 @@ library Servant.API.Status Servant.API.Stream Servant.API.Sub + Servant.API.TypeErrors Servant.API.TypeLevel Servant.API.UVerb Servant.API.UVerb.Union diff --git a/servant/src/Servant/API/TypeErrors.hs b/servant/src/Servant/API/TypeErrors.hs new file mode 100644 index 00000000..81a0e7eb --- /dev/null +++ b/servant/src/Servant/API/TypeErrors.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module defines the error messages used in type-level errors. +-- Type-level errors can signal non-existing instances, for instance when +-- a combinator is not applied to the correct number of arguments. + +module Servant.API.TypeErrors ( + PartialApplication, + NoInstanceFor, + NoInstanceForSub, +) where + +import Data.Kind +import GHC.TypeLits + +-- | No instance exists for @tycls (expr :> ...)@ because +-- @expr@ is not recognised. +type NoInstanceForSub (tycls :: k) (expr :: k') = + Text "There is no instance for " :<>: ShowType tycls + :<>: Text " (" :<>: ShowType expr :<>: Text " :> ...)" + +-- | No instance exists for @expr@. +type NoInstanceFor (expr :: k) = + Text "There is no instance for " :<>: ShowType expr + +-- | No instance exists for @tycls (expr :> ...)@ because @expr@ is not fully saturated. +type PartialApplication (tycls :: k) (expr :: k') = + NoInstanceForSub tycls expr + :$$: ShowType expr :<>: Text " expects " :<>: ShowType (Arity expr) :<>: Text " more arguments" + +-- The arity of a combinator, i.e. the number of required arguments. +type Arity (ty :: k) = Arity' k + +type family Arity' (ty :: k) :: Nat where + Arity' (_ -> ty) = 1 + Arity' ty + Arity' _ = 0 diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index adc04efc..8f9c553d 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -140,7 +140,7 @@ import qualified Data.Text.Encoding as TE import Data.Type.Bool (If) import GHC.TypeLits - (KnownSymbol, symbolVal) + (KnownSymbol, TypeError, symbolVal) import Network.URI (URI (..), escapeURIString, isUnreserved) import Prelude () @@ -183,6 +183,7 @@ import Servant.API.Stream (Stream, StreamBody') import Servant.API.Sub (type (:>)) +import Servant.API.TypeErrors import Servant.API.TypeLevel import Servant.API.UVerb import Servant.API.Vault @@ -644,3 +645,14 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub) -- $setup -- >>> import Servant.API -- >>> import Data.Text (Text) + +-- Erroring instance for 'HasLink' when a combinator is not fully applied +instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub) + where + type MkLink (arr :> sub) _ = TypeError (PartialApplication HasLink arr) + toLink = error "unreachable" + +-- Erroring instances for 'HasLink' for unknown API combinators +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub) + +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api