Look through type synonyms when computing orphans

I renamed functions tyClsNamesOfTypes to oprhNamesOfType,
because it's only used in that capacity, and we therefore
want to look through type synonyms.  Similarly exprOrphNames.

This fixes Trac #4912.

compiler/coreSyn/CoreFVs.lhs

@@ -23,14 +23,13 @@ module CoreFVs (
         -- * Selective free variables of expressions
         InterestingVarFun,
 	exprSomeFreeVars, exprsSomeFreeVars,
-	exprFreeNames, exprsFreeNames,
 
         -- * Free variables of Rules, Vars and Ids
         varTypeTyVars, varTypeTcTyVars, 
 	idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
         idRuleVars, idRuleRhsVars, stableUnfoldingVars,
 	ruleRhsFreeVars, rulesFreeVars,
-	ruleLhsFreeNames, ruleLhsFreeIds, 
+	ruleLhsOrphNames, ruleLhsFreeIds, 
 
         -- * Core syntax tree annotation with free variables
 	CoreExprWithFVs,	-- = AnnExpr Id VarSet
@@ -219,7 +218,7 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
 %************************************************************************
 
 \begin{code}
--- | Similar to 'exprFreeNames'. However, this is used when deciding whether 
+-- | ruleLhsOrphNames is used when deciding whether 
 -- a rule is an orphan.  In particular, suppose that T is defined in this 
 -- module; we want to avoid declaring that a rule like:
 -- 
@@ -227,18 +226,20 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
 --
 -- is an orphan. Of course it isn't, and declaring it an orphan would
 -- make the whole module an orphan module, which is bad.
-ruleLhsFreeNames :: CoreRule -> NameSet
-ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
-ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args })
-  = addOneToNameSet (exprsFreeNames tpl_args) fn
+ruleLhsOrphNames :: CoreRule -> NameSet
+ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
+ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args })
+  = addOneToNameSet (exprsOrphNames tpl_args) fn
+		-- No need to delete bndrs, because
+		-- exprsOrphNames finds only External names
 
 -- | Finds the free /external/ names of an expression, notably
 -- including the names of type constructors (which of course do not show
 -- up in 'exprFreeVars').
-exprFreeNames :: CoreExpr -> NameSet
+exprOrphNames :: CoreExpr -> NameSet
 -- There's no need to delete local binders, because they will all
 -- be /internal/ names.
-exprFreeNames e
+exprOrphNames e
   = go e
   where
     go (Var v) 
@@ -246,21 +247,21 @@ exprFreeNames e
       | otherwise	    = emptyNameSet
       where n = idName v
     go (Lit _) 	   	    = emptyNameSet
-    go (Type ty)   	    = tyClsNamesOfType ty	-- Don't need free tyvars
+    go (Type ty)   	    = orphNamesOfType ty	-- Don't need free tyvars
     go (App e1 e2) 	    = go e1 `unionNameSets` go e2
     go (Lam v e)   	    = go e `delFromNameSet` idName v
     go (Note _ e)           = go e
-    go (Cast e co)          = go e `unionNameSets` tyClsNamesOfType co
+    go (Cast e co)          = go e `unionNameSets` orphNamesOfType co
     go (Let (NonRec _ r) e) = go e `unionNameSets` go r
-    go (Let (Rec prs) e)    = exprsFreeNames (map snd prs) `unionNameSets` go e
-    go (Case e _ ty as)     = go e `unionNameSets` tyClsNamesOfType ty
+    go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSets` go e
+    go (Case e _ ty as)     = go e `unionNameSets` orphNamesOfType ty
                               `unionNameSets` unionManyNameSets (map go_alt as)
 
     go_alt (_,_,r) = go r
 
--- | Finds the free /external/ names of several expressions: see 'exprFreeNames' for details
-exprsFreeNames :: [CoreExpr] -> NameSet
-exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
+-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
+exprsOrphNames :: [CoreExpr] -> NameSet
+exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
 \end{code}
 
 %************************************************************************

compiler/iface/MkIface.lhs

@@ -1431,7 +1431,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
     (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
 		-- Slightly awkward: we need the Class to get the fundeps
     (tvs, fds) = classTvsFds cls
-    arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
+    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
     orph | is_local cls_name = Just (nameOccName cls_name)
 	 | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
 	 | otherwise	     = Nothing
@@ -1549,10 +1549,10 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
   = pprTrace "toHsRule: builtin" (ppr fn) $
     bogusIfaceRule fn
 
-coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, 
-                                ru_act = act, ru_bndrs = bndrs,
-	                        ru_args = args, ru_rhs = rhs, 
-                                ru_auto = auto })
+coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, 
+                                     ru_act = act, ru_bndrs = bndrs,
+	                             ru_args = args, ru_rhs = rhs, 
+                                     ru_auto = auto })
   = IfaceRule { ifRuleName  = name, ifActivation = act, 
 		ifRuleBndrs = map toIfaceBndr bndrs,
 		ifRuleHead  = fn, 
@@ -1571,9 +1571,7 @@ coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
 	-- Compute orphanhood.  See Note [Orphans] in IfaceSyn
 	-- A rule is an orphan only if none of the variables
 	-- mentioned on its left-hand side are locally defined
-    lhs_names = fn : nameSetToList (exprsFreeNames args)
-		-- No need to delete bndrs, because
-		-- exprsFreeNames finds only External names
+    lhs_names = nameSetToList (ruleLhsOrphNames rule)
 
     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
 			(n : _) -> Just (nameOccName n)

compiler/main/InteractiveEval.hs

@@ -860,7 +860,7 @@ getInfo name
            return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
   where
     plausible rdr_env ispec	-- Dfun involving only names that are in ic_rn_glb_env
-	= all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
+	= all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec
 	where	-- A name is ok if it's in the rdr_env, 
 		-- whether qualified or not
 	  ok n | n == name	   = True	-- The one we looked for in the first place!

compiler/typecheck/TcRnDriver.lhs

@@ -72,7 +72,7 @@ import Outputable
 import DataCon
 import Type
 import Class
-import TcType   ( tyClsNamesOfDFunHead )
+import TcType   ( orphNamesOfDFunHead )
 import Inst	( tcGetInstEnvs )
 import Data.List ( sortBy )
 
@@ -1499,7 +1499,7 @@ lookupInsts (ATyCon tc)
 		 , let dfun = instanceDFunId ispec
 		 , relevant dfun ] } 
   where
-    relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+    relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
     tc_name     = tyConName tc		  
 
 lookupInsts _ = return []

compiler/typecheck/TcType.lhs

@@ -61,7 +61,7 @@ module TcType (
   ---------------------------------
   -- Misc type manipulators
   deNoteType,
-  tyClsNamesOfType, tyClsNamesOfDFunHead, 
+  orphNamesOfType, orphNamesOfDFunHead, 
   getDFunTyKey,
 
   ---------------------------------
@@ -1162,13 +1162,13 @@ exactTyVarsOfType ty
   = go ty
   where
     go ty | Just ty' <- tcView ty = go ty'	-- This is the key line
-    go (TyVarTy tv)         	  = unitVarSet tv
-    go (TyConApp _ tys)     	  = exactTyVarsOfTypes tys
-    go (PredTy ty)	    	  = go_pred ty
-    go (FunTy arg res)	    	  = go arg `unionVarSet` go res
-    go (AppTy fun arg)	    	  = go fun `unionVarSet` go arg
-    go (ForAllTy tyvar ty)  	  = delVarSet (go ty) tyvar
-                                    `unionVarSet` go_tv tyvar
+    go (TyVarTy tv)         = unitVarSet tv
+    go (TyConApp _ tys)     = exactTyVarsOfTypes tys
+    go (PredTy ty)	    = go_pred ty
+    go (FunTy arg res)	    = go arg `unionVarSet` go res
+    go (AppTy fun arg)	    = go fun `unionVarSet` go arg
+    go (ForAllTy tyvar ty)  = delVarSet (go ty) tyvar
+                              `unionVarSet` go_tv tyvar
 
     go_pred (IParam _ ty)    = go ty
     go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
@@ -1185,29 +1185,34 @@ Find the free tycons and classes of a type.  This is used in the front
 end of the compiler.
 
 \begin{code}
-tyClsNamesOfType :: Type -> NameSet
-tyClsNamesOfType (TyVarTy _)		    = emptyNameSet
-tyClsNamesOfType (TyConApp tycon tys)	    = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (PredTy (IParam _ ty))     = tyClsNamesOfType ty
-tyClsNamesOfType (PredTy (ClassP cl tys))   = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (PredTy (EqPred ty1 ty2))  = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
-tyClsNamesOfType (FunTy arg res)	    = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
-tyClsNamesOfType (AppTy fun arg)	    = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
-tyClsNamesOfType (ForAllTy _ ty)	    = tyClsNamesOfType ty
-
-tyClsNamesOfTypes :: [Type] -> NameSet
-tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
-
-tyClsNamesOfDFunHead :: Type -> NameSet
+orphNamesOfType :: Type -> NameSet
+orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
+		-- Look through type synonyms (Trac #4912)
+orphNamesOfType (TyVarTy _)		   = emptyNameSet
+orphNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) 
+                                             `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (IParam _ ty))    = orphNamesOfType ty
+orphNamesOfType (PredTy (ClassP cl tys))  = unitNameSet (getName cl) 
+                                            `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1 
+                                            `unionNameSets` orphNamesOfType ty2
+orphNamesOfType (FunTy arg res)	    = orphNamesOfType arg `unionNameSets` orphNamesOfType res
+orphNamesOfType (AppTy fun arg)	    = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
+orphNamesOfType (ForAllTy _ ty)	    = orphNamesOfType ty
+
+orphNamesOfTypes :: [Type] -> NameSet
+orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
+
+orphNamesOfDFunHead :: Type -> NameSet
 -- Find the free type constructors and classes 
 -- of the head of the dfun instance type
 -- The 'dfun_head_type' is because of
 --	instance Foo a => Baz T where ...
 -- The decl is an orphan if Baz and T are both not locally defined,
 --	even if Foo *is* locally defined
-tyClsNamesOfDFunHead dfun_ty 
+orphNamesOfDFunHead dfun_ty 
   = case tcSplitSigmaTy dfun_ty of
-	(_, _, head_ty) -> tyClsNamesOfType head_ty
+	(_, _, head_ty) -> orphNamesOfType head_ty
 \end{code}