2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Name]{@Name@: to transmit name info from renamer to typechecker}
7 #include "HsVersions.h"
10 -- things for the Name NON-abstract type
13 isTyConName, isClassName, isClassOpName,
14 getTagFromClassOpName, isUnboundName,
18 -- to make the interface self-sufficient
19 Id, FullName, ShortName, TyCon, Unique
20 #ifndef __GLASGOW_HASKELL__
25 import AbsUniType ( cmpTyCon, TyCon, Class, ClassOp, Arity(..)
26 IF_ATTACK_PRAGMAS(COMMA cmpClass)
27 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
29 import Id ( cmpId, Id )
30 import NameTypes -- all of them
33 import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
34 import Unique ( eqUnique, cmpUnique, pprUnique, Unique )
38 %************************************************************************
40 \subsection[Name-datatype]{The @Name@ datatype}
42 %************************************************************************
46 = Short Unique -- Local ids and type variables
49 -- Nano-prelude things; truly wired in.
50 -- Includes all type constructors and their associated data constructors
54 -- Prelude things not actually wired into the compiler, but important
55 -- enough to get their own special lookup key (a magic Unique).
56 | PreludeVal Unique{-IdKey-} FullName
57 | PreludeTyCon Unique{-TyConKey-} FullName Arity Bool -- as for OtherTyCon
58 | PreludeClass Unique{-ClassKey-} FullName
60 | OtherTyCon Unique -- TyCons other than Prelude ones; need to
61 FullName -- separate these because we want to pin on
63 Bool -- True <=> `data', False <=> `type'
64 [Name] -- List of user-visible data constructors;
65 -- NB: for `data' types only.
66 -- Used in checking import/export lists.
70 [Name] -- List of class methods; used for checking
71 -- import/export lists.
73 | OtherTopId Unique -- Top level id
77 Name -- Name associated w/ the defined class
78 -- (can get unique and export info, etc., from this)
79 FAST_STRING -- The class operation
80 Int -- Unique tag within the class
83 | Unbound FAST_STRING -- Placeholder for a name which isn't in scope
84 -- Used only so that the renamer can carry on after
85 -- finding an unbound identifier.
86 -- The string is grabbed from the unbound name, for
87 -- debugging information only.
90 These @is..@ functions are used in the renamer to check that (eg) a tycon
91 is seen in a context which demands one.
94 isTyConName, isClassName, isUnboundName :: Name -> Bool
96 isTyConName (WiredInTyCon _) = True
97 isTyConName (PreludeTyCon _ _ _ _) = True
98 isTyConName (OtherTyCon _ _ _ _ _) = True
99 isTyConName other = False
101 isClassName (PreludeClass _ _) = True
102 isClassName (OtherClass _ _ _) = True
103 isClassName other = False
105 isUnboundName (Unbound _) = True
106 isUnboundName other = False
109 @isClassOpName@ is a little cleverer: it checks to see whether the
110 class op comes from the correct class.
113 isClassOpName :: Name -- The name of the class expected for this op
114 -> Name -- The name of the thing which should be a class op
117 isClassOpName (PreludeClass key1 _) (ClassOpName _ (PreludeClass key2 _) _ _)
119 isClassOpName (OtherClass uniq1 _ _) (ClassOpName _ (OtherClass uniq2 _ _) _ _)
120 = eqUnique uniq1 uniq2
121 isClassOpName other_class other_op = False
124 A Name is ``invisible'' if the user has no business seeing it; e.g., a
125 data-constructor for an abstract data type (but whose constructors are
126 known because of a pragma).
128 invisibleName :: Name -> Bool
130 invisibleName (PreludeVal _ n) = invisibleFullName n
131 invisibleName (PreludeTyCon _ n _ _) = invisibleFullName n
132 invisibleName (PreludeClass _ n) = invisibleFullName n
133 invisibleName (OtherTyCon _ n _ _ _) = invisibleFullName n
134 invisibleName (OtherClass _ n _) = invisibleFullName n
135 invisibleName (OtherTopId _ n) = invisibleFullName n
136 invisibleName _ = False
140 getTagFromClassOpName :: Name -> Int
142 getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
146 %************************************************************************
148 \subsection[Name-instances]{Instance declarations}
150 %************************************************************************
153 cmpName n1 n2 = cmp n1 n2
155 cmp (Short u1 _) (Short u2 _) = cmpUnique u1 u2
157 cmp (WiredInTyCon tc1) (WiredInTyCon tc2) = cmpTyCon tc1 tc2
158 cmp (WiredInVal id1) (WiredInVal id2) = cmpId id1 id2
160 cmp (PreludeVal k1 _) (PreludeVal k2 _) = cmpUnique k1 k2
161 cmp (PreludeTyCon k1 _ _ _) (PreludeTyCon k2 _ _ _) = cmpUnique k1 k2
162 cmp (PreludeClass k1 _) (PreludeClass k2 _) = cmpUnique k1 k2
164 cmp (OtherTyCon u1 _ _ _ _) (OtherTyCon u2 _ _ _ _) = cmpUnique u1 u2
165 cmp (OtherClass u1 _ _) (OtherClass u2 _ _) = cmpUnique u1 u2
166 cmp (OtherTopId u1 _) (OtherTopId u2 _) = cmpUnique u1 u2
168 cmp (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmpUnique u1 u2
170 -- panic won't unify w/ CMP_TAG (Int#)
171 cmp (Unbound a) (Unbound b) = panic "Eq.Name.Unbound"
174 cmp other_1 other_2 -- the tags *must* be different
175 = let tag1 = tag_Name n1
178 if tag1 _LT_ tag2 then LT_ else GT_
180 tag_Name (Short _ _) = (ILIT(1) :: FAST_INT)
181 tag_Name (WiredInTyCon _) = ILIT(2)
182 tag_Name (WiredInVal _) = ILIT(3)
183 tag_Name (PreludeVal _ _) = ILIT(4)
184 tag_Name (PreludeTyCon _ _ _ _) = ILIT(5)
185 tag_Name (PreludeClass _ _) = ILIT(6)
186 tag_Name (OtherTyCon _ _ _ _ _) = ILIT(7)
187 tag_Name (OtherClass _ _ _) = ILIT(8)
188 tag_Name (OtherTopId _ _) = ILIT(9)
189 tag_Name (ClassOpName _ _ _ _) = ILIT(10)
190 tag_Name (Unbound _) = ILIT(11)
194 eqName a b = case cmpName a b of { EQ_ -> True; _ -> False }
195 gtName a b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
197 instance Eq Name where
198 a == b = case cmpName a b of { EQ_ -> True; _ -> False }
199 a /= b = case cmpName a b of { EQ_ -> False; _ -> True }
201 instance Ord Name where
202 a <= b = case cmpName a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
203 a < b = case cmpName a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
204 a >= b = case cmpName a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
205 a > b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
206 #ifdef __GLASGOW_HASKELL__
207 _tagCmp a b = case cmpName a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
212 instance NamedThing Name where
213 getExportFlag (Short _ _) = NotExported
214 getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these
215 getExportFlag (WiredInVal _) = NotExported
216 getExportFlag (ClassOpName _ c _ _) = getExportFlag c
217 getExportFlag other = getExportFlag (get_nm "getExportFlag" other)
219 isLocallyDefined (Short _ _) = True
220 isLocallyDefined (WiredInTyCon _) = False
221 isLocallyDefined (WiredInVal _) = False
222 isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
223 isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other)
225 getOrigName (Short _ sn) = getOrigName sn
226 getOrigName (WiredInTyCon tc) = getOrigName tc
227 getOrigName (WiredInVal id) = getOrigName id
228 getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op)
229 getOrigName other = getOrigName (get_nm "getOrigName" other)
231 getOccurrenceName (Short _ sn) = getOccurrenceName sn
232 getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc
233 getOccurrenceName (WiredInVal id) = getOccurrenceName id
234 getOccurrenceName (ClassOpName _ _ op _) = op
235 getOccurrenceName (Unbound s) = s _APPEND_ SLIT("<unbound>")
236 getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other)
238 getInformingModules thing = panic "getInformingModule:Name"
240 getSrcLoc (Short _ sn) = getSrcLoc sn
241 getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc
242 getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc
243 getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c
244 getSrcLoc (Unbound _) = mkUnknownSrcLoc
245 getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other)
247 getTheUnique (Short uniq _) = uniq
248 getTheUnique (OtherTopId uniq _) = uniq
250 = pprPanic "NamedThing.Name.getTheUnique: not a Short or OtherTopId:" (ppr PprShowAll other)
252 fromPreludeCore (WiredInTyCon _) = True
253 fromPreludeCore (WiredInVal _) = True
254 fromPreludeCore (PreludeVal _ n) = fromPreludeCore n
255 fromPreludeCore (PreludeTyCon _ n _ _) = fromPreludeCore n
256 fromPreludeCore (PreludeClass _ n) = fromPreludeCore n
257 fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c
258 fromPreludeCore other = False
261 getType n = panic "NamedThing.Name.getType"
264 A useful utility; most emphatically not for export!:
266 get_nm :: String -> Name -> FullName
268 get_nm msg (PreludeVal _ n) = n
269 get_nm msg (PreludeTyCon _ n _ _) = n
270 get_nm msg (OtherTyCon _ n _ _ _) = n
271 get_nm msg (PreludeClass _ n) = n
272 get_nm msg (OtherClass _ n _) = n
273 get_nm msg (OtherTopId _ n) = n
275 get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
276 -- If match failure, probably on a ClassOpName or Unbound :-(
281 instance Outputable Name where
283 ppr PprDebug (Short u s) = pp_debug u s
284 ppr PprDebug (PreludeVal u i) = pp_debug u i
285 ppr PprDebug (PreludeTyCon u t _ _) = pp_debug u t
286 ppr PprDebug (PreludeClass u c) = pp_debug u c
288 ppr PprDebug (OtherTyCon u n _ _ _) = pp_debug u n
289 ppr PprDebug (OtherClass u n _) = pp_debug u n
290 ppr PprDebug (OtherTopId u n) = pp_debug u n
292 ppr sty (Short u s) = ppr sty s
294 ppr sty (WiredInTyCon tc) = ppr sty tc
295 ppr sty (WiredInVal id) = ppr sty id
296 ppr sty (PreludeVal _ i) = ppr sty i
297 ppr sty (PreludeTyCon _ t _ _) = ppr sty t
298 ppr sty (PreludeClass _ c) = ppr sty c
300 ppr sty (OtherTyCon u n a b c) = ppr sty n
301 ppr sty (OtherClass u n c) = ppr sty n
302 ppr sty (OtherTopId u n) = ppr sty n
304 ppr sty (ClassOpName u c s i)
312 other -> ppBesides [ps, ppChar '{',
315 ppStr "cls", ppr sty c],
318 ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
321 = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]