-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 _ = 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
-
--- 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)
+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 :: LHsType Name -> NameSet
+extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
+
+extractFunDepNames :: FunDep Name -> NameSet
+extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
+
+extractHsTyNames :: LHsType Name -> NameSet
+extractHsTyNames ty
+ = getl ty
+ where
+ getl (L _ ty) = get ty
+
+ get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
+ get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty
+ get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty
+ get (HsTupleTy con tys) = extractHsTyNames_s tys
+ get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
+ get (HsPredTy p) = extractHsPredTyNames p
+ get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
+ get (HsParTy ty) = getl ty
+ get (HsBangTy _ ty) = getl ty
+ get (HsNumTy n) = emptyNameSet
+ get (HsTyVar tv) = unitNameSet tv
+ get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables
+ get (HsKindSig ty k) = getl ty
+ get (HsForAllTy _ tvs
+ ctxt ty) = (extractHsCtxtTyNames ctxt
+ `unionNameSets` getl ty)
+ `minusNameSet`
+ mkNameSet (hsLTyVarNames tvs)
+
+extractHsTyNames_s :: [LHsType Name] -> NameSet
+extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
+
+extractHsCtxtTyNames :: LHsContext Name -> NameSet
+extractHsCtxtTyNames (L _ ctxt)
+ = foldr (unionNameSets . extractHsPredTyNames . unLoc) 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