2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
7 #include "HsVersions.h"
15 import Id ( isDataCon, GenId, SYN_IE(Id) )
16 import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
17 mkLocalName{-ToDo:rm-}
19 import Outputable ( Outputable(..){-instance * []-} )
20 import PprStyle ( PprStyle(..) )
21 import PprType ( GenType, GenTyVar, TyCon )
23 import TyCon ( TyCon )
24 import TyVar ( GenTyVar )
25 import Unique ( mkAlphaTyVarUnique, Unique )
26 import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
33 | RnName Name -- functions/binders/tyvars
34 | RnSyn Name -- type synonym
35 | RnData Name [Name] [Name] -- data type (with constrs and fields)
36 | RnConstr Name Name -- constructor (with data type)
37 | RnField Name Name -- field (with data type)
38 | RnClass Name [Name] -- class (with class ops)
39 | RnClassOp Name Name -- class op (with class)
40 | RnImplicit Name -- implicitly imported
41 | RnImplicitTyCon Name -- implicitly imported
42 | RnImplicitClass Name -- implicitly imported
43 | RnUnbound RdrName -- place holder
46 mkRnImplicit = RnImplicit
47 mkRnImplicitTyCon = RnImplicitTyCon
48 mkRnImplicitClass = RnImplicitClass
49 mkRnUnbound = RnUnbound
51 isRnWired (WiredInId _) = True
52 isRnWired (WiredInTyCon _) = True
55 isRnLocal (RnName n) = isLocalName n
58 isRnTyCon (WiredInTyCon _) = True
59 isRnTyCon (RnSyn _) = True
60 isRnTyCon (RnData _ _ _) = True
61 isRnTyCon (RnImplicitTyCon _) = True
64 isRnClass (RnClass _ _) = True
65 isRnClass (RnImplicitClass _) = True
68 -- a common need: isRnTyCon || isRnClass:
69 isRnTyConOrClass (WiredInTyCon _) = True
70 isRnTyConOrClass (RnSyn _) = True
71 isRnTyConOrClass (RnData _ _ _) = True
72 isRnTyConOrClass (RnImplicitTyCon _) = True
73 isRnTyConOrClass (RnClass _ _) = True
74 isRnTyConOrClass (RnImplicitClass _) = True
75 isRnTyConOrClass _ = False
77 isRnConstr (RnConstr _ _) = True
78 isRnConstr (WiredInId id) = isDataCon id
81 isRnField (RnField _ _) = True
84 isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
85 isRnClassOp cls n = pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
87 isRnImplicit (RnImplicit _) = True
88 isRnImplicit (RnImplicitTyCon _) = True
89 isRnImplicit (RnImplicitClass _) = True
90 isRnImplicit _ = False
92 isRnUnbound (RnUnbound _) = True
95 isRnEntity (WiredInId _) = True
96 isRnEntity (WiredInTyCon _) = True
97 isRnEntity (RnName n) = not (isLocalName n)
98 isRnEntity (RnSyn _) = True
99 isRnEntity (RnData _ _ _) = True
100 isRnEntity (RnClass _ _) = True
103 -- Very general NamedThing comparison, used when comparing
104 -- Uniquable things with different types
106 eqUniqsNamed n1 n2 = uniqueOf n1 == uniqueOf n2
107 cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
109 instance Eq RnName where
110 a == b = eqUniqsNamed a b
112 instance Ord3 RnName where
113 a `cmp` b = cmpUniqsNamed a b
115 instance Uniquable RnName where
116 uniqueOf = nameUnique . getName
118 instance NamedThing RnName where
119 getName (WiredInId id) = getName id
120 getName (WiredInTyCon tc) = getName tc
121 getName (RnName n) = n
122 getName (RnSyn n) = n
123 getName (RnData n _ _) = n
124 getName (RnConstr n _) = n
125 getName (RnField n _) = n
126 getName (RnClass n _) = n
127 getName (RnClassOp n _) = n
128 getName (RnImplicit n) = n
129 getName (RnImplicitTyCon n) = n
130 getName (RnImplicitClass n) = n
131 getName (RnUnbound occ) = --pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
133 Unqual n -> mkLocalName bottom n False bottom2
134 Qual m n -> mkLocalName bottom n False bottom2)
135 where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
136 bottom2 = panic "getRnName: srcloc"
138 instance Outputable RnName where
140 ppr sty@PprShowAll (RnData n cs fs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
141 ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
142 ppr sty@PprShowAll (RnField n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
143 ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
144 ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
146 ppr sty (WiredInId id) = ppr sty id
147 ppr sty (WiredInTyCon tycon)= ppr sty tycon
148 ppr sty (RnUnbound occ) = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
149 ppr sty rn_name = ppr sty (getName rn_name)
153 type RenamedArithSeqInfo = ArithSeqInfo Fake Fake RnName RenamedPat
154 type RenamedBind = Bind Fake Fake RnName RenamedPat
155 type RenamedClassDecl = ClassDecl Fake Fake RnName RenamedPat
156 type RenamedClassOpSig = Sig RnName
157 type RenamedConDecl = ConDecl RnName
158 type RenamedContext = Context RnName
159 type RenamedSpecDataSig = SpecDataSig RnName
160 type RenamedDefaultDecl = DefaultDecl RnName
161 type RenamedFixityDecl = FixityDecl RnName
162 type RenamedGRHS = GRHS Fake Fake RnName RenamedPat
163 type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake RnName RenamedPat
164 type RenamedHsBinds = HsBinds Fake Fake RnName RenamedPat
165 type RenamedHsExpr = HsExpr Fake Fake RnName RenamedPat
166 type RenamedHsModule = HsModule Fake Fake RnName RenamedPat
167 type RenamedInstDecl = InstDecl Fake Fake RnName RenamedPat
168 type RenamedMatch = Match Fake Fake RnName RenamedPat
169 type RenamedMonoBinds = MonoBinds Fake Fake RnName RenamedPat
170 type RenamedMonoType = MonoType RnName
171 type RenamedPat = InPat RnName
172 type RenamedPolyType = PolyType RnName
173 type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat
174 type RenamedQual = Qualifier Fake Fake RnName RenamedPat
175 type RenamedSig = Sig RnName
176 type RenamedSpecInstSig = SpecInstSig RnName
177 type RenamedStmt = Stmt Fake Fake RnName RenamedPat
178 type RenamedTyDecl = TyDecl RnName
180 type RenamedClassOpPragmas = ClassOpPragmas RnName
181 type RenamedClassPragmas = ClassPragmas RnName
182 type RenamedDataPragmas = DataPragmas RnName
183 type RenamedGenPragmas = GenPragmas RnName
184 type RenamedInstancePragmas = InstancePragmas RnName
188 collectQualBinders :: [RenamedQual] -> [RnName]
190 collectQualBinders quals
191 = concat (map collect quals)
193 collect (GeneratorQual pat _) = collectPatBinders pat
194 collect (FilterQual expr) = []
195 collect (LetQual binds) = collectTopLevelBinders binds
197 fixDeclName :: FixityDecl name -> name
198 fixDeclName (InfixL name i) = name
199 fixDeclName (InfixR name i) = name
200 fixDeclName (InfixN name i) = name