2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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 isUnboundName, invisibleName,
16 getTagFromClassOpName, getSynNameArity,
18 getNameShortName, getNameFullName
24 import NameLoop -- break Name/Id loop, Name/PprType/Id loop
27 import Outputable ( ExportFlag(..) )
29 import PprStyle ( PprStyle(..) )
30 import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
31 import TyCon ( TyCon, synTyConArity )
32 import TyVar ( GenTyVar )
33 import Unique ( pprUnique, Unique )
34 import Util ( panic, panic#, pprPanic )
37 %************************************************************************
39 \subsection[Name-datatype]{The @Name@ datatype}
41 %************************************************************************
45 = Short Unique -- Local ids and type variables
48 -- Nano-prelude things; truly wired in.
49 -- Includes all type constructors and their associated data constructors
53 | TyConName Unique -- TyCons other than Prelude ones; need to
54 FullName -- separate these because we want to pin on
56 Bool -- False <=> `type',
57 -- True <=> `data' or `newtype'
58 [Name] -- List of user-visible data constructors;
59 -- NB: for `data' types only.
60 -- Used in checking import/export lists.
64 [Name] -- List of class methods; used for checking
65 -- import/export lists.
67 | ValName Unique -- Top level id
71 Name -- Name associated w/ the defined class
72 -- (can get unique and export info, etc., from this)
73 FAST_STRING -- The class operation
74 Int -- Unique tag within the class
77 | Unbound FAST_STRING -- Placeholder for a name which isn't in scope
78 -- Used only so that the renamer can carry on after
79 -- finding an unbound identifier.
80 -- The string is grabbed from the unbound name, for
81 -- debugging information only.
84 These @is..@ functions are used in the renamer to check that (eg) a tycon
85 is seen in a context which demands one.
88 isTyConName, isClassName, isUnboundName :: Name -> Bool
90 isTyConName (TyConName _ _ _ _ _) = True
91 isTyConName (WiredInTyCon _) = True
92 isTyConName other = False
94 isClassName (ClassName _ _ _) = True
95 isClassName other = False
97 isUnboundName (Unbound _) = True
98 isUnboundName other = False
101 @isClassOpName@ is a little cleverer: it checks to see whether the
102 class op comes from the correct class.
105 isClassOpName :: Name -- The name of the class expected for this op
106 -> Name -- The name of the thing which should be a class op
109 isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
111 isClassOpName other_class other_op = False
114 A Name is ``invisible'' if the user has no business seeing it; e.g., a
115 data-constructor for an abstract data type (but whose constructors are
116 known because of a pragma).
118 invisibleName :: Name -> Bool
120 invisibleName (TyConName _ n _ _ _) = invisibleFullName n
121 invisibleName (ClassName _ n _) = invisibleFullName n
122 invisibleName (ValName _ n) = invisibleFullName n
123 invisibleName _ = False
127 getTagFromClassOpName :: Name -> Int
128 getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
130 getSynNameArity :: Name -> Maybe Arity
131 getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
132 getSynNameArity (WiredInTyCon tycon) = synTyConArity tycon
133 getSynNameArity other_name = Nothing
135 getNameShortName :: Name -> ShortName
136 getNameShortName (Short _ sn) = sn
138 getNameFullName :: Name -> FullName
139 getNameFullName n = get_nm "getNameFullName" n
143 %************************************************************************
145 \subsection[Name-instances]{Instance declarations}
147 %************************************************************************
150 cmpName n1 n2 = c n1 n2
152 c (Short u1 _) (Short u2 _) = cmp u1 u2
154 c (WiredInTyCon tc1) (WiredInTyCon tc2) = cmp tc1 tc2
155 c (WiredInVal id1) (WiredInVal id2) = cmp id1 id2
157 c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) = cmp u1 u2
158 c (ClassName u1 _ _) (ClassName u2 _ _) = cmp u1 u2
159 c (ValName u1 _) (ValName u2 _) = cmp u1 u2
161 c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmp u1 u2
162 c (Unbound a) (Unbound b) = panic# "Eq.Name.Unbound"
164 c other_1 other_2 -- the tags *must* be different
165 = let tag1 = tag_Name n1
168 if tag1 _LT_ tag2 then LT_ else GT_
170 tag_Name (Short _ _) = (ILIT(1) :: FAST_INT)
171 tag_Name (WiredInTyCon _) = ILIT(2)
172 tag_Name (WiredInVal _) = ILIT(3)
173 tag_Name (TyConName _ _ _ _ _) = ILIT(7)
174 tag_Name (ClassName _ _ _) = ILIT(8)
175 tag_Name (ValName _ _) = ILIT(9)
176 tag_Name (ClassOpName _ _ _ _) = ILIT(10)
177 tag_Name (Unbound _) = ILIT(11)
181 instance Eq Name where
182 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
183 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
185 instance Ord Name where
186 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
187 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
188 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
189 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
191 instance Ord3 Name where
196 instance NamedThing Name where
197 getExportFlag (Short _ _) = NotExported
198 getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these
199 getExportFlag (WiredInVal _) = NotExported
200 getExportFlag (ClassOpName _ c _ _) = getExportFlag c
201 getExportFlag other = getExportFlag (get_nm "getExportFlag" other)
203 isLocallyDefined (Short _ _) = True
204 isLocallyDefined (WiredInTyCon _) = False
205 isLocallyDefined (WiredInVal _) = False
206 isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
207 isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other)
209 getOrigName (Short _ sn) = getOrigName sn
210 getOrigName (WiredInTyCon tc) = getOrigName tc
211 getOrigName (WiredInVal id) = getOrigName id
212 getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op)
213 getOrigName other = getOrigName (get_nm "getOrigName" other)
215 getOccurrenceName (Short _ sn) = getOccurrenceName sn
216 getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc
217 getOccurrenceName (WiredInVal id) = getOccurrenceName id
218 getOccurrenceName (ClassOpName _ _ op _) = op
219 getOccurrenceName (Unbound s) = s _APPEND_ SLIT("<unbound>")
220 getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other)
222 getInformingModules thing = panic "getInformingModule:Name"
224 getSrcLoc (Short _ sn) = getSrcLoc sn
225 getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc
226 getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc
227 getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c
228 getSrcLoc (Unbound _) = mkUnknownSrcLoc
229 getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other)
231 getItsUnique (Short u _) = u
232 getItsUnique (WiredInTyCon t) = getItsUnique t
233 getItsUnique (WiredInVal i) = getItsUnique i
234 getItsUnique (TyConName u _ _ _ _) = u
235 getItsUnique (ClassName u _ _) = u
236 getItsUnique (ValName u _) = u
237 getItsUnique (ClassOpName u _ _ _) = u
239 fromPreludeCore (WiredInTyCon _) = True
240 fromPreludeCore (WiredInVal _) = True
241 fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c
242 fromPreludeCore other = False
245 A useful utility; most emphatically not for export! (but see
246 @getNameFullName@...):
248 get_nm :: String -> Name -> FullName
250 get_nm msg (TyConName _ n _ _ _) = n
251 get_nm msg (ClassName _ n _) = n
252 get_nm msg (ValName _ n) = n
254 get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
255 -- If match failure, probably on a ClassOpName or Unbound :-(
260 instance Outputable Name where
262 ppr PprDebug (Short u s) = pp_debug u s
264 ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
265 ppr PprDebug (ClassName u n _) = pp_debug u n
266 ppr PprDebug (ValName u n) = pp_debug u n
268 ppr sty (Short u s) = ppr sty s
270 ppr sty (WiredInTyCon tc) = ppr sty tc
271 ppr sty (WiredInVal id) = ppr sty id
273 ppr sty (TyConName u n a b c) = ppr sty n
274 ppr sty (ClassName u n c) = ppr sty n
275 ppr sty (ValName u n) = ppr sty n
277 ppr sty (ClassOpName u c s i)
285 other -> ppBesides [ps, ppChar '{',
288 ppStr "cls", ppr sty c],
291 ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
294 = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]