Type-level errors for HasLink for invalid combinators

Author: Andrea Condoluci

servant/servant.cabal

@@ -54,6 +54,7 @@ library
     Servant.API.Status
     Servant.API.Stream
     Servant.API.Sub
+    Servant.API.TypeErrors
     Servant.API.TypeLevel
     Servant.API.UVerb
     Servant.API.UVerb.Union

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

servant/src/Servant/Links.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes    #-}
 {-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE FlexibleContexts       #-}
@@ -134,7 +135,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 ()
@@ -175,6 +176,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
@@ -608,3 +610,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 :> _) _ = 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