%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
\begin{code}
-#include "HsVersions.h"
-
module RnHsSyn where
-import Ubiq
+#include "HsVersions.h"
import HsSyn
-
-import Id ( isDataCon, GenId, Id(..) )
-import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
- mkLocalName{-ToDo:rm-}
- )
-import Outputable ( Outputable(..){-instance * []-} )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType, GenTyVar, TyCon )
-import Pretty
-import TyCon ( TyCon )
-import TyVar ( GenTyVar )
-import Unique ( mkAlphaTyVarUnique, Unique )
-import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
+import HsCore
+import Class ( FunDep, DefMeth(..) )
+import TyCon ( visibleDataCons )
+import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
+import Name ( Name, getName, isTyVarName )
+import NameSet
+import BasicTypes ( Boxity )
+import Outputable
\end{code}
+
\begin{code}
-data RnName
- = WiredInId Id
- | WiredInTyCon TyCon
- | RnName Name -- functions/binders/tyvars
- | RnSyn Name -- type synonym
- | RnData Name [Name] [Name] -- data type (with constrs and fields)
- | RnConstr Name Name -- constructor (with data type)
- | RnField Name Name -- field (with data type)
- | RnClass Name [Name] -- class (with class ops)
- | RnClassOp Name Name -- class op (with class)
- | RnImplicit Name -- implicitly imported
- | RnImplicitTyCon Name -- implicitly imported
- | RnImplicitClass Name -- implicitly imported
- | RnUnbound RdrName -- place holder
-
-mkRnName = RnName
-mkRnImplicit = RnImplicit
-mkRnImplicitTyCon = RnImplicitTyCon
-mkRnImplicitClass = RnImplicitClass
-mkRnUnbound = RnUnbound
-
-isRnWired (WiredInId _) = True
-isRnWired (WiredInTyCon _) = True
-isRnWired _ = False
-
-isRnLocal (RnName n) = isLocalName n
-isRnLocal _ = False
-
-isRnTyCon (WiredInTyCon _) = True
-isRnTyCon (RnSyn _) = True
-isRnTyCon (RnData _ _ _) = True
-isRnTyCon (RnImplicitTyCon _) = True
-isRnTyCon _ = False
-
-isRnClass (RnClass _ _) = True
-isRnClass (RnImplicitClass _) = True
-isRnClass _ = False
-
--- a common need: isRnTyCon || isRnClass:
-isRnTyConOrClass (WiredInTyCon _) = True
-isRnTyConOrClass (RnSyn _) = True
-isRnTyConOrClass (RnData _ _ _) = True
-isRnTyConOrClass (RnImplicitTyCon _) = True
-isRnTyConOrClass (RnClass _ _) = True
-isRnTyConOrClass (RnImplicitClass _) = True
-isRnTyConOrClass _ = False
-
-isRnConstr (RnConstr _ _) = True
-isRnConstr (WiredInId id) = isDataCon id
-isRnConstr _ = False
-
-isRnField (RnField _ _) = True
-isRnField _ = False
-
-isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls _ = False
-
-isRnImplicit (RnImplicit _) = True
-isRnImplicit (RnImplicitTyCon _) = True
-isRnImplicit (RnImplicitClass _) = True
-isRnImplicit _ = False
-
-isRnUnbound (RnUnbound _) = True
-isRnUnbound _ = False
-
-isRnDecl (RnName _) = True
-isRnDecl (RnSyn _) = True
-isRnDecl (RnData _ _ _) = True
-isRnDecl (RnClass _ _) = True
-isRnDecl _ = False
-
--- Very general NamedThing comparison, used when comparing
--- Uniquable things with different types
-
-eqUniqsNamed n1 n2 = uniqueOf n1 == uniqueOf n2
-cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
-
-instance Eq RnName where
- a == b = eqUniqsNamed a b
-
-instance Ord3 RnName where
- a `cmp` b = cmpUniqsNamed a b
-
-instance Uniquable RnName where
- uniqueOf = nameUnique . getName
-
-instance NamedThing RnName where
- getName (WiredInId id) = getName id
- getName (WiredInTyCon tc) = getName tc
- getName (RnName n) = n
- getName (RnSyn n) = n
- getName (RnData n _ _) = n
- getName (RnConstr n _) = n
- getName (RnField n _) = n
- getName (RnClass n _) = n
- getName (RnClassOp n _) = n
- getName (RnImplicit n) = n
- getName (RnImplicitTyCon n) = n
- getName (RnImplicitClass n) = n
- getName (RnUnbound occ) = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
- (case occ of
- Unqual n -> mkLocalName bottom n bottom2
- Qual m n -> mkLocalName bottom n bottom2)
- where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
- bottom2 = panic "getRnName: srcloc"
-
-instance Outputable RnName where
-#ifdef DEBUG
- ppr sty@PprShowAll (RnData n cs fs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
- ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
- ppr sty@PprShowAll (RnField n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
- ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
- ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
-#endif
- ppr sty (WiredInId id) = ppr sty id
- ppr sty (WiredInTyCon tycon)= ppr sty tycon
- ppr sty (RnUnbound occ) = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
- ppr sty rn_name = ppr sty (getName rn_name)
+type RenamedHsDecl = HsDecl Name RenamedPat
+type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat
+type RenamedClassOpSig = Sig Name
+type RenamedConDecl = ConDecl Name
+type RenamedContext = HsContext Name
+type RenamedRuleDecl = RuleDecl Name RenamedPat
+type RenamedTyClDecl = TyClDecl Name RenamedPat
+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 RenamedMatchContext = HsMatchContext Name
+type RenamedMatch = Match Name RenamedPat
+type RenamedMonoBinds = MonoBinds Name RenamedPat
+type RenamedPat = InPat Name
+type RenamedHsType = HsType Name
+type RenamedHsPred = HsPred Name
+type RenamedRecordBinds = HsRecordBinds Name RenamedPat
+type RenamedSig = Sig Name
+type RenamedStmt = Stmt Name RenamedPat
+type RenamedFixitySig = FixitySig Name
+type RenamedDeprecation = DeprecDecl Name
\end{code}
+%************************************************************************
+%* *
+\subsection{Free variables}
+%* *
+%************************************************************************
+
+These free-variable finders returns tycons and classes too.
+
\begin{code}
-type RenamedArithSeqInfo = ArithSeqInfo Fake Fake RnName RenamedPat
-type RenamedBind = Bind Fake Fake RnName RenamedPat
-type RenamedClassDecl = ClassDecl Fake Fake RnName RenamedPat
-type RenamedClassOpSig = Sig RnName
-type RenamedConDecl = ConDecl RnName
-type RenamedContext = Context RnName
-type RenamedSpecDataSig = SpecDataSig RnName
-type RenamedDefaultDecl = DefaultDecl RnName
-type RenamedFixityDecl = FixityDecl RnName
-type RenamedGRHS = GRHS Fake Fake RnName RenamedPat
-type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake RnName RenamedPat
-type RenamedHsBinds = HsBinds Fake Fake RnName RenamedPat
-type RenamedHsExpr = HsExpr Fake Fake RnName RenamedPat
-type RenamedHsModule = HsModule Fake Fake RnName RenamedPat
-type RenamedInstDecl = InstDecl Fake Fake RnName RenamedPat
-type RenamedMatch = Match Fake Fake RnName RenamedPat
-type RenamedMonoBinds = MonoBinds Fake Fake RnName RenamedPat
-type RenamedMonoType = MonoType RnName
-type RenamedPat = InPat RnName
-type RenamedPolyType = PolyType RnName
-type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat
-type RenamedQual = Qual Fake Fake RnName RenamedPat
-type RenamedSig = Sig RnName
-type RenamedSpecInstSig = SpecInstSig RnName
-type RenamedStmt = Stmt Fake Fake RnName RenamedPat
-type RenamedTyDecl = TyDecl RnName
-
-type RenamedClassOpPragmas = ClassOpPragmas RnName
-type RenamedClassPragmas = ClassPragmas RnName
-type RenamedDataPragmas = DataPragmas RnName
-type RenamedGenPragmas = GenPragmas RnName
-type RenamedInstancePragmas = InstancePragmas RnName
+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)
+
+extractHsTyVars :: RenamedHsType -> NameSet
+extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
+
+extractFunDepNames :: FunDep Name -> NameSet
+extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
+
+extractHsTyNames :: RenamedHsType -> NameSet
+extractHsTyNames ty
+ = get 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
+ get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets`
+ 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
+ get (HsForAllTy (Just tvs)
+ ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
+ `minusNameSet`
+ mkNameSet (hsTyVarNames tvs)
+ get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
+
+extractHsTyNames_s :: [RenamedHsType] -> NameSet
+extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
+
+extractHsCtxtTyNames :: RenamedContext -> NameSet
+extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNameSet ctxt
+
+-- You don't import or export implicit parameters,
+-- so don't mention the IP names
+extractHsPredTyNames (HsClassP cls tys)
+ = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
+extractHsPredTyNames (HsIParam n ty)
+ = extractHsTyNames ty
\end{code}
-\begin{code}
-collectQualBinders :: [RenamedQual] -> [RnName]
-collectQualBinders quals
- = concat (map collect quals)
+%************************************************************************
+%* *
+\subsection{Free variables of declarations}
+%* *
+%************************************************************************
+
+Return the Names that must be in scope if we are to use this declaration.
+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})
+ = delFVs (map hsTyVarName tyvars) $
+ extractHsCtxtTyNames context `plusFV`
+ plusFVs (map conDeclFVs (visibleDataCons condecls))
+
+tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty})
+ = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty)
+
+tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = maybe_meths})
+ = delFVs (map hsTyVarName tyvars) $
+ extractHsCtxtTyNames context `plusFV`
+ plusFVs (map extractFunDepNames fds) `plusFV`
+ hsSigsFVs sigs `plusFV`
+ dm_fvs
where
- collect (GeneratorQual pat _) = collectPatBinders pat
- collect (FilterQual expr) = []
- collect (LetQual binds) = collectTopLevelBinders binds
-
-fixDeclName :: FixityDecl name -> name
-fixDeclName (InfixL name i) = name
-fixDeclName (InfixR name i) = name
-fixDeclName (InfixN name i) = name
+ dm_fvs = case maybe_meths of
+ Nothing -> mkFVs [v | ClassOpSig _ (DefMeth v) _ _ <- sigs]
+ -- No method bindings, so this class decl comes from an interface file,
+ -- So we want to treat the default-method names as free (they should
+ -- be defined somewhere else). [In source code this is not so; the class
+ -- decl will bind whatever default-methods are necessary.]
+ Just _ -> emptyFVs -- Source code, so the default methods
+ -- are *bound* not *free*
+
+tyClDeclFVs (CoreDecl {tcdType = ty, tcdRhs = rhs})
+ = extractHsTyNames ty `plusFV` ufExprFVs rhs
+
+----------------
+hsSigsFVs sigs = plusFVs (map hsSigFVs sigs)
+
+hsSigFVs (Sig v ty _) = extractHsTyNames ty
+hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty
+hsSigFVs (SpecSig v ty _) = extractHsTyNames ty
+hsSigFVs (ClassOpSig _ _ ty _) = extractHsTyNames ty
+hsSigFVs other = emptyFVs
+
+----------------
+instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _)
+ = extractHsTyNames inst_ty `plusFV`
+ (case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs })
+
+----------------
+ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs
+ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs
+ruleDeclFVs (IfaceRule _ _ vars _ args rhs _)
+ = delFVs (map ufBinderName vars) $
+ ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args)
+
+----------------
+conDeclFVs (ConDecl _ _ tyvars context details _)
+ = delFVs (map hsTyVarName tyvars) $
+ extractHsCtxtTyNames context `plusFV`
+ conDetailsFVs details
+
+conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys)
+conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
+conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds]
+
+bangTyFVs bty = extractHsTyNames (getBangType bty)
+
+----------------
+hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf
+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 (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)
+ufExprFVs (UfApp e1 e2) = ufExprFVs e1 `plusFV` ufExprFVs e2
+ufExprFVs (UfCase e n as) = ufExprFVs e `plusFV` delFV n (plusFVs (map ufAltFVs as))
+ufExprFVs (UfNote n e) = ufNoteFVs n `plusFV` ufExprFVs e
+ufExprFVs (UfLet (UfNonRec b r) e) = ufExprFVs r `plusFV` ufBndrFVs b (ufExprFVs e)
+ufExprFVs (UfLet (UfRec prs) e) = foldr ufBndrFVs
+ (foldr (plusFV . ufExprFVs . snd) (ufExprFVs e) prs)
+ (map fst prs)
+
+ufBndrFVs (UfValBinder n ty) fvs = extractHsTyNames ty `plusFV` delFV n fvs
+ufBndrFVs (UfTyBinder n k) fvs = delFV n fvs
+
+ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e)
+
+ufConFVs (UfDataAlt n) = unitFV n
+ufConFVs (UfTupleAlt t) = hsTupConFVs t
+ufConFVs (UfLitLitAlt _ ty) = extractHsTyNames ty
+ufConFVs other = emptyFVs
+
+ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
+ufNoteFVs note = emptyFVs
+
+hsTupConFVs (HsTupCon n _ _) = unitFV n
\end{code}
+%************************************************************************
+%* *
+\subsection{A few functions on generic defintions
+%* *
+%************************************************************************
+
+These functions on generics are defined over RenamedMatches, which is
+why they are here and not in HsMatches.
+
+\begin{code}
+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)
+ = Just (ty, Match pats sig_ty grhss)
+
+maybeGenericMatch other_match = Nothing
+\end{code}
projects / ghc-hetmet.git / blobdiff