module RnHsSyn where
-import Ubiq
+IMP_Ubiq()
import HsSyn
-import Id ( GenId, Id(..) )
-import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
- mkLocalName{-ToDo:rm-}
+import Id ( isDataCon, GenId, SYN_IE(Id) )
+import Name ( isLocalName, nameUnique, Name, RdrName(..),
+ mkLocalName
)
import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
import TyCon ( TyCon )
import TyVar ( GenTyVar )
import Unique ( mkAlphaTyVarUnique, Unique )
-import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
+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] -- data type (with constrs)
- | RnConstr Name Name -- constructor (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
+ | 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
isRnLocal (RnName n) = isLocalName n
isRnLocal _ = False
-
isRnTyCon (WiredInTyCon _) = True
isRnTyCon (RnSyn _) = True
-isRnTyCon (RnData _ _) = True
+isRnTyCon (RnData _ _ _) = True
isRnTyCon (RnImplicitTyCon _) = True
isRnTyCon _ = False
-- a common need: isRnTyCon || isRnClass:
isRnTyConOrClass (WiredInTyCon _) = True
isRnTyConOrClass (RnSyn _) = True
-isRnTyConOrClass (RnData _ _) = 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 (RnImplicit _) = True -- ho hummm ...
-isRnClassOp cls _ = False
+isRnClassOp cls n = True -- pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
isRnImplicit (RnImplicit _) = True
isRnImplicit (RnImplicitTyCon _) = True
isRnUnbound (RnUnbound _) = True
isRnUnbound _ = False
+isRnEntity (WiredInId _) = True
+isRnEntity (WiredInTyCon _) = True
+isRnEntity (RnName n) = not (isLocalName n)
+isRnEntity (RnSyn _) = True
+isRnEntity (RnData _ _ _) = True
+isRnEntity (RnClass _ _) = True
+isRnEntity _ = False
+
-- Very general NamedThing comparison, used when comparing
-- Uniquable things with different types
getName (WiredInTyCon tc) = getName tc
getName (RnName n) = n
getName (RnSyn n) = n
- getName (RnData 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)
+ 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)
+ Unqual n -> mkLocalName bottom n False bottom2
+ Qual m n -> mkLocalName bottom n False 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) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppStr "-}"]
- ppr sty@PprShowAll (RnConstr 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 "-}"]
+ 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
type RenamedPat = InPat RnName
type RenamedPolyType = PolyType RnName
type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat
-type RenamedQual = Qual Fake Fake RnName RenamedPat
+type RenamedQual = Qualifier Fake Fake RnName RenamedPat
type RenamedSig = Sig RnName
type RenamedSpecInstSig = SpecInstSig RnName
type RenamedStmt = Stmt Fake Fake RnName RenamedPat
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
\end{code}