[commit: ghc] master: Fix an outright bug in expandTypeSynonyms (286dc02)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/286dc021ef515d02453cd5e31774b852d3a1310f/ghc

>---------------------------------------------------------------

commit 286dc021ef515d02453cd5e31774b852d3a1310f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Mar 2 15:12:12 2016 +0000

    Fix an outright bug in expandTypeSynonyms
    
    The bug was in this code:
    
        go subst (TyConApp tc tys)
          | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
          = let subst' = unionTCvSubst subst (mkTvSubstPrs tenv) in
            go subst' (mkAppTys rhs tys')
    
    This is wrong in two ways.
     * It is wrong to apply the expanded substitution to tys',
     * The unionTCvSubst is utterly wrong; after all, rhs is
       completely separate, and the union makes a non-idempotent
       substitution.
    
    It was the non-idempotency that gave the Lint failure in Trac #11665,
    when there was a type synonym whose RHS mentioned another type synonym,
    something like
    
      type T a b = a -> b
      type S x y = T y x
    
    It only affects SpecConstr because that's about the only place where
    expandTypeSyonym is called.  I tried to trigger the failure with a
    simple test case, but failed, so I have not added a regression test.
    
    Fortunately the solution is very simple and solid.
    
    FWIW, the culprit was 674654, "Add kind equalities to GHC".


>---------------------------------------------------------------

286dc021ef515d02453cd5e31774b852d3a1310f
 compiler/types/Type.hs | 22 +++++++++++++++++-----
 1 file changed, 17 insertions(+), 5 deletions(-)

diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 78c20a9..b71bba3 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -327,14 +327,26 @@ expandTypeSynonyms :: Type -> Type
 -- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,
 -- not in the kinds of any TyCon or TyVar mentioned in the type.
 expandTypeSynonyms ty
-  = go (mkEmptyTCvSubst (mkTyCoInScopeSet [ty] [])) ty
+  = go (mkEmptyTCvSubst in_scope) ty
   where
+    in_scope = mkInScopeSet (tyCoVarsOfType ty)
+
     go subst (TyConApp tc tys)
-      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
-      = let subst' = unionTCvSubst subst (mkTvSubstPrs tenv) in
-        go subst' (mkAppTys rhs tys')
+      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys
+      = let subst' = mkTvSubst in_scope (mkVarEnv tenv)
+            -- Make a fresh substitution; rhs has nothing to
+            -- do with anything that has happened so far
+            -- NB: if you make changes here, be sure to build an
+            --     /idempotent/ substitution, even in the nested case
+            --        type T a b = a -> b
+            --        type S x y = T y x
+            -- (Trac #11665)
+        in  mkAppTys (go subst' rhs) tys'
       | otherwise
-      = TyConApp tc (map (go subst) tys)
+      = TyConApp tc expanded_tys
+      where
+        expanded_tys = (map (go subst) tys)
+
     go _     (LitTy l)     = LitTy l
     go subst (TyVarTy tv)  = substTyVar subst tv
     go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)