Fix infinite loop when specializing instance heads (#723)

* Fix infinite loop when specializing instance heads

The bug can only be triggered from TH, hence why it went un-noticed for
so long.

* Add test for #679 and #710

1 files changed, 10 insertions, 10 deletions

diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 6d2888d3..bb27f10c 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -31,23 +31,23 @@ import qualified Data.Set as Set
 specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
             => Data a
             => [(IdP name, HsType name)] -> a -> a
-specialize specs = go
+specialize specs = go spec_map0
   where
-    go :: forall x. Data x => x -> x
-    go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+    go :: forall x. Data x => Map name (HsType name) -> x -> x
+    go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
 
     strip_kind_sig :: HsType name -> HsType name
     strip_kind_sig (HsKindSig (L _ t) _) = t
     strip_kind_sig typ = typ
 
-    specialize_ty_var :: HsType name -> HsType name
-    specialize_ty_var (HsTyVar _ (L _ name'))
+    specialize_ty_var :: Map name (HsType name) -> HsType name -> HsType name
+    specialize_ty_var spec_map (HsTyVar _ (L _ name'))
       | Just t <- Map.lookup name' spec_map = t
-    specialize_ty_var typ = typ
-    -- This is a tricky recursive definition that is guaranteed to terminate
-    -- because a type binder cannot be instantiated with a type that depends
-    -- on that binder. i.e. @a -> Maybe a@ is invalid
-    spec_map = Map.fromList [ (n, go t) | (n, t) <- specs]
+    specialize_ty_var _ typ = typ
+
+    -- This is a tricky recursive definition. By adding in the specializations
+    -- one by one, we should avoid infinite loops.
+    spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
 
 
 -- | Instantiate given binders with corresponding types.