From 42b7d0eb9bc36e02fc4aa2656bcbde9aa540aaee Mon Sep 17 00:00:00 2001
From: Andrea Condoluci <andrea.condoluci@tweag.io>
Date: Fri, 10 Apr 2020 17:07:45 +0200
Subject: [PATCH 1/2] Type-level errors for HasLink for invalid combinators

---
 servant/servant.cabal                 |  1 +
 servant/src/Servant/API/TypeErrors.hs | 40 +++++++++++++++++++++++++++
 servant/src/Servant/Links.hs          | 15 +++++++++-
 3 files changed, 55 insertions(+), 1 deletion(-)
 create mode 100644 servant/src/Servant/API/TypeErrors.hs

diff --git a/servant/servant.cabal b/servant/servant.cabal
index 8dd79c75..b6f8ca9e 100644
--- a/servant/servant.cabal
+++ b/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
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 50a7ee57..d28815d6 100644
--- a/servant/src/Servant/Links.hs
+++ b/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

From 67a37dc3f6f6d6b326b439ba732cfe446090be97 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ga=C3=ABl=20Deest?= <gael.deest@tweag.io>
Date: Wed, 17 Nov 2021 15:29:22 +0100
Subject: [PATCH 2/2] Fix build error on GHC 8.6

---
 servant/src/Servant/Links.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs
index d28815d6..0966fe04 100644
--- a/servant/src/Servant/Links.hs
+++ b/servant/src/Servant/Links.hs
@@ -614,7 +614,7 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
 -- 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)
+    type MkLink (arr :> sub) _ = TypeError (PartialApplication HasLink arr)
     toLink = error "unreachable"
 
 -- Erroring instances for 'HasLink' for unknown API combinators