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

Fix infinite loop when specializing instance heads (#723)
6ed6c110 · Alec Theriault · Alex Biehl · 9fd7f8bf · 6ed6c110 · 6ed6c110
Commit 6ed6c110 authored 7 years ago by Alec Theriault Committed by Alex Biehl 7 years ago
--- 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 :: forall x. Data x => Map name (HsType name) -> x -> x
-    go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+    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 :: Map name (HsType name) -> HsType name -> HsType name
-    specialize_ty_var (HsTyVar _ (L _ name'))
+    specialize_ty_var spec_map (HsTyVar _ (L _ name'))
      | Just t <- Map.lookup name' spec_map = t
-    specialize_ty_var typ = typ
+    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
+    -- This is a tricky recursive definition. By adding in the specializations
-    -- on that binder. i.e. @a -> Maybe a@ is invalid
+    -- one by one, we should avoid infinite loops.
-    spec_map = Map.fromList [ (n, go t) | (n, t) <- specs]
+    spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
 -- | Instantiate given binders with corresponding types.

--- a/html-test/ref/Bug679.html
+++ b/html-test/ref/Bug679.html
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >Bug679</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >None</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>Bug679</p
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:Bar" class="def"
+	    >Bar</a
+	    > a <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a id="v:Bar" class="def"
+		  >Bar</a
+		  ></td
+		><td class="doc empty"
+		></td
+		></tr
+	      ></table
+	    ></div
+	  ><div class="subs instances"
+	  ><details id="i:Bar" open="open"
+	    ><summary
+	      >Instances</summary
+	      ><table
+	      ><tr
+		><td class="src clearfix"
+		  ><span class="inst-left"
+		    ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Bar:Foo:1"
+		      ></span
+		      > <a href="#"
+		      >Foo</a
+		      > (<a href="#"
+		      >Bar</a
+		      > a)</span
+		    > <a href="#" class="selflink"
+		    >#</a
+		    ></td
+		  ><td class="doc empty"
+		  ></td
+		  ></tr
+		><tr
+		><td colspan="2"
+		  ><details id="i:id:Bar:Foo:1"
+		    ><summary class="hide-when-js-enabled"
+		      >Instance details</summary
+		      ><div class="subs methods"
+		      ><p class="caption"
+			>Methods</p
+			><p class="src"
+			><a href="#"
+			  >foo</a
+			  > :: <a href="#"
+			  >Bar</a
+			  > a -&gt; <a href="#"
+			  >Bar</a
+			  > a <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			></div
+		      ></details
+		    ></td
+		  ></tr
+		></table
+	      ></details
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >class</span
+	    > <a id="t:Foo" class="def"
+	    >Foo</a
+	    > a <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="subs minimal"
+	  ><p class="caption"
+	    >Minimal complete definition</p
+	    ><p class="src"
+	    ><a href="#"
+	      >foo</a
+	      ></p
+	    ></div
+	  ><div class="subs methods"
+	  ><p class="caption"
+	    >Methods</p
+	    ><p class="src"
+	    ><a id="v:foo" class="def"
+	      >foo</a
+	      > :: a -&gt; a <a href="#" class="selflink"
+	      >#</a
+	      ></p
+	    ></div
+	  ><div class="subs instances"
+	  ><details id="i:Foo" open="open"
+	    ><summary
+	      >Instances</summary
+	      ><table
+	      ><tr
+		><td class="src clearfix"
+		  ><span class="inst-left"
+		    ><span class="instance details-toggle-control details-toggle" data-details-id="i:ic:Foo:Foo:1"
+		      ></span
+		      > <a href="#"
+		      >Foo</a
+		      > (<a href="#"
+		      >Bar</a
+		      > a)</span
+		    > <a href="#" class="selflink"
+		    >#</a
+		    ></td
+		  ><td class="doc empty"
+		  ></td
+		  ></tr
+		><tr
+		><td colspan="2"
+		  ><details id="i:ic:Foo:Foo:1"
+		    ><summary class="hide-when-js-enabled"
+		      >Instance details</summary
+		      ><div class="subs methods"
+		      ><p class="caption"
+			>Methods</p
+			><p class="src"
+			><a href="#"
+			  >foo</a
+			  > :: <a href="#"
+			  >Bar</a
+			  > a -&gt; <a href="#"
+			  >Bar</a
+			  > a <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			></div
+		      ></details
+		    ></td
+		  ></tr
+		></table
+	      ></details
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
--- a/html-test/src/Bug679.hs
+++ b/html-test/src/Bug679.hs
+{-# LANGUAGE TemplateHaskell #-}
+module Bug679 where
+import Language.Haskell.TH
+data Bar a = Bar
+$(do
+   a <- newName "a"
+   let classN = mkName "Foo"
+   let methodN = mkName "foo"
+   methodTy <- [t| $(varT a) -> $(varT a) |]
+   let cla = ClassD [] classN [PlainTV a] [] [SigD methodN methodTy]
+   -- Note that we are /reusing/ the same type variable 'a' as in the class
+   instanceHead <- [t| $(conT classN) (Bar $(varT a)) |]
+   idCall <- [e| id |]
+   let ins = InstanceD Nothing [] instanceHead [FunD methodN [Clause [] (NormalB idCall) []]]
+   pure [cla,ins])