X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnHsSyn.lhs;h=83a098a64d7d7e4bc45225ba94d764b5ef9b3390;hb=32c62212b35b2b631f3753d432b508de5c79c783;hp=df20eb00a04c7cbd5e7cbe5bb7a6012d2dcb8907;hpb=da0e7b0f5989c163b1cf79d493877d854ab1c279;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index df20eb0..83a098a 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -11,39 +11,40 @@ module RnHsSyn where
 import HsSyn
 import HsCore
 import Class		( FunDep, DefMeth(..) )
-import TyCon		( visibleDataCons )
+import TyCon		( visibleDataCons, tyConName )
 import TysWiredIn	( tupleTyCon, listTyCon, parrTyCon, charTyCon )
 import Name		( Name, getName, isTyVarName )
 import NameSet
-import BasicTypes	( Boxity )
+import BasicTypes	( Boxity, FixitySig )
 import Outputable
 \end{code}
 
 
 \begin{code}
-type RenamedHsDecl		= HsDecl		Name RenamedPat
-type RenamedArithSeqInfo	= ArithSeqInfo		Name RenamedPat
+type RenamedHsDecl		= HsDecl		Name
+type RenamedArithSeqInfo	= ArithSeqInfo		Name
 type RenamedClassOpSig		= Sig			Name
 type RenamedConDecl		= ConDecl		Name
 type RenamedContext		= HsContext 		Name
-type RenamedRuleDecl		= RuleDecl		Name RenamedPat
-type RenamedTyClDecl		= TyClDecl		Name RenamedPat
+type RenamedRuleDecl		= RuleDecl		Name
+type RenamedTyClDecl		= TyClDecl		Name
 type RenamedDefaultDecl		= DefaultDecl		Name
 type RenamedForeignDecl		= ForeignDecl		Name
-type RenamedGRHS		= GRHS			Name RenamedPat
-type RenamedGRHSs		= GRHSs			Name RenamedPat
-type RenamedHsBinds		= HsBinds		Name RenamedPat
-type RenamedHsExpr		= HsExpr		Name RenamedPat
-type RenamedInstDecl		= InstDecl		Name RenamedPat
+type RenamedCoreDecl		= CoreDecl		Name
+type RenamedGRHS		= GRHS			Name
+type RenamedGRHSs		= GRHSs			Name
+type RenamedHsBinds		= HsBinds		Name
+type RenamedHsExpr		= HsExpr		Name
+type RenamedInstDecl		= InstDecl		Name
 type RenamedMatchContext	= HsMatchContext	Name
-type RenamedMatch		= Match			Name RenamedPat
-type RenamedMonoBinds		= MonoBinds		Name RenamedPat
+type RenamedMatch		= Match			Name
+type RenamedMonoBinds		= MonoBinds		Name
 type RenamedPat			= InPat			Name
 type RenamedHsType		= HsType		Name
 type RenamedHsPred		= HsPred		Name
-type RenamedRecordBinds		= HsRecordBinds		Name RenamedPat
+type RenamedRecordBinds		= HsRecordBinds		Name
 type RenamedSig			= Sig			Name
-type RenamedStmt		= Stmt			Name RenamedPat
+type RenamedStmt		= Stmt			Name
 type RenamedFixitySig		= FixitySig		Name
 type RenamedDeprecation		= DeprecDecl		Name
 \end{code}
@@ -82,7 +83,9 @@ extractHsTyNames ty
     get (HsFunTy ty1 ty2)      = get ty1 `unionNameSets` get ty2
     get (HsPredTy p)	       = extractHsPredTyNames p
     get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets`
-				 unitNameSet tycon
+				 case tycon of { HsTyOp n -> unitNameSet n ; 
+						 HsArrow  -> emptyNameSet }
+    get (HsParTy ty)           = get ty
     get (HsNumTy n)            = emptyNameSet
     get (HsTyVar tv)	       = unitNameSet tv
     get (HsKindSig ty k)       = get ty
@@ -123,6 +126,13 @@ In all cases this is set up for interface-file declarations:
 	*** See "THE NAMING STORY" in HsDecls ****
 
 \begin{code}
+----------------
+impDeclFVs :: RenamedHsDecl -> NameSet
+	-- Just the ones that come from imports
+impDeclFVs (InstD d) = instDeclFVs d
+impDeclFVs (TyClD d) = tyClDeclFVs d
+
+----------------
 tyClDeclFVs :: RenamedTyClDecl -> NameSet
 tyClDeclFVs (ForeignType {})
   = emptyFVs
@@ -178,12 +188,12 @@ ruleDeclFVs (IfaceRule _ _ vars _ args rhs _)
     ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args)
 
 ----------------
-conDeclFVs (ConDecl _ _ tyvars context details _)
+conDeclFVs (ConDecl _ tyvars context details _)
   = delFVs (map hsTyVarName tyvars) $
     extractHsCtxtTyNames context	  `plusFV`
     conDetailsFVs details
 
-conDetailsFVs (VanillaCon btys)    = plusFVs (map bangTyFVs btys)
+conDetailsFVs (PrefixCon btys)    = plusFVs (map bangTyFVs btys)
 conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
 conDetailsFVs (RecCon flds)	   = plusFVs [bangTyFVs bty | (_, bty) <- flds]
 
@@ -223,9 +233,11 @@ ufConFVs other		    = emptyFVs
 ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
 ufNoteFVs note		= emptyFVs
 
-hsTupConFVs (HsTupCon n _ _) = unitFV n
+hsTupConFVs (HsTupCon bx n) = unitFV (tyConName (tupleTyCon bx n))
+	-- Always return the TyCon; that'll suck in the data con
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection{A few functions on generic defintions
@@ -240,7 +252,7 @@ maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch)
   -- Tells whether a Match is for a generic definition
   -- and extract the type from a generic match and put it at the front
 
-maybeGenericMatch (Match (TypePatIn ty : pats) sig_ty grhss)
+maybeGenericMatch (Match (TypePat ty : pats) sig_ty grhss)
   = Just (ty, Match pats sig_ty grhss)
 
 maybeGenericMatch other_match = Nothing