X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnHsSyn.lhs;h=df20eb00a04c7cbd5e7cbe5bb7a6012d2dcb8907;hb=eb2a3ce7eae091dedfcb790845c5cac5ccd32033;hp=3137382c4943748cba55e3d22c18f430262a6b5c;hpb=14e92de47ef199abfc1fd84c97cb2b275b0e3f21;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 3137382..df20eb0 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,21 +11,21 @@ module RnHsSyn where import HsSyn import HsCore import Class ( FunDep, DefMeth(..) ) -import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) +import TyCon ( visibleDataCons ) +import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) -import Maybes ( orElse ) import Outputable \end{code} \begin{code} +type RenamedHsDecl = HsDecl Name RenamedPat type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name type RenamedContext = HsContext Name -type RenamedHsDecl = HsDecl Name RenamedPat type RenamedRuleDecl = RuleDecl Name RenamedPat type RenamedTyClDecl = TyClDecl Name RenamedPat type RenamedDefaultDecl = DefaultDecl Name @@ -34,8 +34,8 @@ type RenamedGRHS = GRHS Name RenamedPat type RenamedGRHSs = GRHSs Name RenamedPat type RenamedHsBinds = HsBinds Name RenamedPat type RenamedHsExpr = HsExpr Name RenamedPat -type RenamedHsModule = HsModule Name RenamedPat type RenamedInstDecl = InstDecl Name RenamedPat +type RenamedMatchContext = HsMatchContext Name type RenamedMatch = Match Name RenamedPat type RenamedMonoBinds = MonoBinds Name RenamedPat type RenamedPat = InPat Name @@ -46,7 +46,6 @@ type RenamedSig = Sig Name type RenamedStmt = Stmt Name RenamedPat type RenamedFixitySig = FixitySig Name type RenamedDeprecation = DeprecDecl Name -type RenamedHsOverLit = HsOverLit Name \end{code} %************************************************************************ @@ -58,9 +57,10 @@ type RenamedHsOverLit = HsOverLit Name These free-variable finders returns tycons and classes too. \begin{code} -charTyCon_name, listTyCon_name :: Name +charTyCon_name, listTyCon_name, parrTyCon_name :: Name charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon +parrTyCon_name = getName parrTyCon tupleTyCon_name :: Boxity -> Int -> Name tupleTyCon_name boxity n = getName (tupleTyCon boxity n) @@ -77,6 +77,7 @@ extractHsTyNames ty where get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty + get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` get ty get (HsTupleTy con tys) = hsTupConFVs con `unionNameSets` extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p @@ -84,6 +85,7 @@ extractHsTyNames ty unitNameSet tycon get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv + get (HsKindSig ty k) = get ty get (HsForAllTy (Just tvs) ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` @@ -98,9 +100,9 @@ extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNa -- You don't import or export implicit parameters, -- so don't mention the IP names -extractHsPredTyNames (HsPClass cls tys) +extractHsPredTyNames (HsClassP cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys -extractHsPredTyNames (HsPIParam n ty) +extractHsPredTyNames (HsIParam n ty) = extractHsTyNames ty \end{code} @@ -116,18 +118,23 @@ In all cases this is set up for interface-file declarations: - for class decls we ignore the bindings - for instance decls likewise, plus the pragmas - for rule decls, we ignore HsRules + - for data decls, we ignore derivings + + *** See "THE NAMING STORY" in HsDecls **** \begin{code} tyClDeclFVs :: RenamedTyClDecl -> NameSet +tyClDeclFVs (ForeignType {}) + = emptyFVs + tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) = extractHsTyNames ty `plusFV` plusFVs (map hsIdInfoFVs id_infos) -tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) - = delFVs (map hsTyVarName tyvars) $ +tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls}) + = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` - plusFVs (map conDeclFVs condecls) `plusFV` - mkNameSet (derivings `orElse` []) + plusFVs (map conDeclFVs (visibleDataCons condecls)) tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty}) = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty) @@ -165,7 +172,8 @@ instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _) ---------------- ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs -ruleDeclFVs (IfaceRule _ vars _ args rhs _) +ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs +ruleDeclFVs (IfaceRule _ _ vars _ args rhs _) = delFVs (map ufBinderName vars) $ ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args) @@ -183,14 +191,14 @@ bangTyFVs bty = extractHsTyNames (getBangType bty) ---------------- hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf -hsIdInfoFVs (HsWorker n) = unitFV n +hsIdInfoFVs (HsWorker n a) = unitFV n hsIdInfoFVs other = emptyFVs ---------------- ufExprFVs (UfVar n) = unitFV n ufExprFVs (UfLit l) = emptyFVs ufExprFVs (UfLitLit l ty) = extractHsTyNames ty -ufExprFVs (UfCCall cc ty) = extractHsTyNames ty +ufExprFVs (UfFCall cc ty) = extractHsTyNames ty ufExprFVs (UfType ty) = extractHsTyNames ty ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es) ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e) @@ -232,8 +240,8 @@ 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 tvs (TypePatIn ty : pats) sig_ty grhss) - = Just (ty, Match tvs pats sig_ty grhss) +maybeGenericMatch (Match (TypePatIn ty : pats) sig_ty grhss) + = Just (ty, Match pats sig_ty grhss) maybeGenericMatch other_match = Nothing \end{code}