From 6ed6c110c874a746b002aca148192c3cbc819d7f Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 5 Jan 2018 09:59:59 -0800 Subject: 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 --- haddock-api/src/Haddock/Interface/Specialize.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) (limited to 'haddock-api') 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. -- cgit v1.2.3