module RnHsSyn where
-import Ubiq
+IMP_Ubiq()
import HsSyn
-import Id ( isDataCon, GenId, Id(..) )
-import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
- mkLocalName{-ToDo:rm-}
- )
+import Id ( GenId, SYN_IE(Id) )
+import Name ( Name )
import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar, TyCon )
import Pretty
+import Name ( SYN_IE(NameSet), unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet )
import TyCon ( TyCon )
import TyVar ( GenTyVar )
-import Unique ( mkAlphaTyVarUnique, Unique )
-import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
+import Unique ( Unique )
+import Util ( panic, pprPanic{-, pprTrace ToDo:rm-} )
\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)
-\end{code}
\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
+type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat
+type RenamedBind = Bind Fake Fake Name RenamedPat
+type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat
+type RenamedClassOpSig = Sig Name
+type RenamedConDecl = ConDecl Name
+type RenamedContext = Context Name
+type RenamedHsDecl = HsDecl Fake Fake Name RenamedPat
+type RenamedSpecDataSig = SpecDataSig Name
+type RenamedDefaultDecl = DefaultDecl Name
+type RenamedFixityDecl = FixityDecl Name
+type RenamedGRHS = GRHS Fake Fake Name RenamedPat
+type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat
+type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat
+type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat
+type RenamedHsModule = HsModule Fake Fake Name RenamedPat
+type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat
+type RenamedMatch = Match Fake Fake Name RenamedPat
+type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat
+type RenamedPat = InPat Name
+type RenamedHsType = HsType Name
+type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat
+type RenamedSig = Sig Name
+type RenamedSpecInstSig = SpecInstSig Name
+type RenamedStmt = Stmt Fake Fake Name RenamedPat
+type RenamedTyDecl = TyDecl Name
+
+type RenamedClassOpPragmas = ClassOpPragmas Name
+type RenamedClassPragmas = ClassPragmas Name
+type RenamedDataPragmas = DataPragmas Name
+type RenamedGenPragmas = GenPragmas Name
+type RenamedInstancePragmas = InstancePragmas Name
\end{code}
+%************************************************************************
+%* *
+\subsection{Free variables}
+%* *
+%************************************************************************
+
\begin{code}
-collectQualBinders :: [RenamedQual] -> [RnName]
+extractCtxtTyNames :: RenamedContext -> NameSet
+extractCtxtTyNames ctxt = foldr (unionNameSets . extractHsTyNames . snd) emptyNameSet ctxt
-collectQualBinders quals
- = concat (map collect quals)
+extractHsTyNames :: RenamedHsType -> NameSet
+extractHsTyNames ty
+ = get ty
where
- collect (GeneratorQual pat _) = collectPatBinders pat
- collect (FilterQual expr) = []
- collect (LetQual binds) = collectTopLevelBinders binds
+ get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2
+ get (MonoListTy tc ty) = unitNameSet tc `unionNameSets` get ty
+ get (MonoTupleTy tc tys) = foldr (unionNameSets . get) (unitNameSet tc) tys
+ get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
+ get (MonoDictTy cls ty) = unitNameSet cls `unionNameSets` get ty
+ get (MonoTyVar tv) = unitNameSet tv
+ get (HsForAllTy tvs ctxt ty) = foldr (unionNameSets . get . snd) (get ty) ctxt
+ `minusNameSet`
+ mkNameSet (map getTyVarName tvs)
-fixDeclName :: FixityDecl name -> name
-fixDeclName (InfixL name i) = name
-fixDeclName (InfixR name i) = name
-fixDeclName (InfixN name i) = name
\end{code}
projects / ghc-hetmet.git / blobdiff