From b033871dfcc7878d3a6d01d99674061da317a8fa Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ga=C3=ABl=20Deest?= <gael.deest@tweag.io>
Date: Sat, 2 Oct 2021 20:43:38 +0200
Subject: [PATCH] Implement HasLink instance for NamedRoutes

---
 servant/servant.cabal        |  1 +
 servant/src/Servant/Links.hs | 40 ++++++++++++++++++++++++++++++++++++
 2 files changed, 41 insertions(+)

diff --git a/servant/servant.cabal b/servant/servant.cabal
index 41ea5792..18a818b3 100644
--- a/servant/servant.cabal
+++ b/servant/servant.cabal
@@ -80,6 +80,7 @@ library
   build-depends:
       base                   >= 4.9      && < 4.16
     , bytestring             >= 0.10.8.1 && < 0.12
+    , constraints
     , mtl                    >= 2.2.2    && < 2.3
     , sop-core               >= 0.4.0.0  && < 0.6
     , transformers           >= 0.5.2.0  && < 0.6
diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs
index 50a7ee57..e7ef257d 100644
--- a/servant/src/Servant/Links.hs
+++ b/servant/src/Servant/Links.hs
@@ -1,13 +1,22 @@
+{-# LANGUAGE AllowAmbiguousTypes    #-}
 {-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs           #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
+
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE QuantifiedConstraints  #-}
+#endif
+
 {-# OPTIONS_HADDOCK not-home        #-}
 
 -- | Type safe generation of internal links.
@@ -125,6 +134,7 @@ module Servant.Links (
 ) where
 
 import           Data.List
+import           Data.Constraint
 import           Data.Proxy
                  (Proxy (..))
 import           Data.Singletons.Bool
@@ -579,6 +589,36 @@ instance HasLink (Stream m status fr ct a) where
 instance HasLink (UVerb m ct a) where
     type MkLink (UVerb m ct a) r = r
     toLink toA _ = toA
+-- Instance for NamedRoutes combinator
+
+#if __GLASGOW_HASKELL__ >= 806
+type GLinkConstraints routes a =
+  ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
+  , GenericServant routes (AsLink a)
+  )
+
+class GLink (routes :: * -> *) (a :: *) where
+  proof :: Dict (GLinkConstraints routes a)
+
+instance GLinkConstraints routes a => GLink routes a where
+  proof = Dict
+
+instance
+  ( HasLink (ToServantApi routes)
+  , forall a. GLink routes a
+  ) => HasLink (NamedRoutes routes) where
+
+  type MkLink (NamedRoutes routes) a = routes (AsLink a)
+
+  toLink
+    :: forall a. (Link -> a)
+    -> Proxy (NamedRoutes routes)
+    -> Link
+    -> routes (AsLink a)
+
+  toLink toA _ l = case proof @routes @a of
+    Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
+#endif
 
 -- AuthProtext instances
 instance HasLink sub => HasLink (AuthProtect tag :> sub) where