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"
15 isRdrLexCon, isRdrLexConOrSpecial,
22 mkLocalName, isLocalName,
23 mkTopLevName, mkImportedName,
24 mkImplicitName, isImplicitName,
25 mkBuiltinName, mkCompoundName, mkCompoundName2,
27 mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
30 NamedThing(..), -- class
32 isExported{-overloaded-}, exportFlagOn{-not-},
34 nameUnique, changeUnique,
44 origName, moduleOf, nameOf, moduleNamePair,
45 getOccName, getExportFlag,
46 getSrcLoc, getImpLocs,
47 isLocallyDefined, isPreludeDefined,
48 getLocalName, ltLexical,
50 isSymLexeme, pprSym, pprNonSym,
51 isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
52 isLexConId, isLexConSym, isLexVarId, isLexVarSym
57 import CStrings ( identToC, cSEP )
58 import Outputable ( Outputable(..) )
59 import PprStyle ( PprStyle(..), codeStyle )
60 import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
62 import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
63 import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
66 import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
69 %************************************************************************
71 \subsection[RdrName]{The @RdrName@ datatype; names read from files}
73 %************************************************************************
76 type Module = FAST_STRING
80 | Qual Module FAST_STRING
82 isUnqual (Unqual _) = True
83 isUnqual (Qual _ _) = False
85 isQual (Unqual _) = False
86 isQual (Qual _ _) = True
88 isRdrLexCon (Unqual n) = isLexCon n
89 isRdrLexCon (Qual m n) = isLexCon n
91 isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
92 isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
94 appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
95 appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
96 Qual m (n _APPEND_ str)
98 cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
99 cmpRdr (Unqual n1) (Qual m2 n2) = LT_
100 cmpRdr (Qual m1 n1) (Unqual n2) = GT_
101 cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
103 instance Eq RdrName where
104 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
105 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
107 instance Ord RdrName where
108 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
109 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
110 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
111 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
113 instance Ord3 RdrName where
116 instance NamedThing RdrName where
117 -- We're sorta faking it here
119 = Global u rdr_name prov ex [rdr_name]
121 u = panic "NamedThing.RdrName:Unique"
122 prov = panic "NamedThing.RdrName:Provenance"
123 ex = panic "NamedThing.RdrName:ExportFlag"
125 instance Outputable RdrName where
126 ppr sty (Unqual n) = pp_name sty n
127 ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
129 pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
130 pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
131 pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
132 pp_mod _ m = ppBesides [ppPStr m, ppChar '.']
134 pp_name sty n | codeStyle sty = identToC n
135 | otherwise = ppPStr n
137 showRdr sty rdr = ppShow 100 (ppr sty rdr)
140 %************************************************************************
142 \subsection[Name-datatype]{The @Name@ datatype}
144 %************************************************************************
153 RdrName -- original name; Unqual => prelude
154 Provenance -- where it came from
155 ExportFlag -- is it exported?
156 [RdrName] -- ordered occurrence names (usually just one);
157 -- first may be *un*qual.
160 = LocalDef SrcLoc -- locally defined; give its source location
162 | Imported ExportFlag -- how it was imported
163 SrcLoc -- *original* source location
164 [SrcLoc] -- any import source location(s)
173 mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
174 mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
176 mkImplicitName :: Unique -> RdrName -> Name
177 mkImplicitName u o = Global u o Implicit NotExported []
179 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
180 mkBuiltinName u m{-NB: unused(?)-} n = Global u (Unqual n) Builtin NotExported []
182 mkCompoundName :: Unique
183 -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
184 -> [RdrName] -- "dot" these names together
185 -> Name -- from which we get provenance, etc....
188 mkCompoundName u str ns (Local _ _ _) = panic "mkCompoundName:Local?"
189 mkCompoundName u str ns (Global _ _ prov exp _)
190 = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
192 glue [] acc = reverse acc
193 glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
194 glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
196 -- this ugly one is used for instance-y things
197 mkCompoundName2 :: Unique
198 -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
199 -> [RdrName] -- "dot" these names together
200 -> [FAST_STRING] -- type-name strings
201 -> Bool -- True <=> defined in this module
205 mkCompoundName2 u str ns ty_strs from_here locn
206 = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs))))
207 (if from_here then LocalDef locn else Imported ExportAll locn [])
208 ExportAll{-instances-}
212 = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
213 mkTupleDataConName arity
214 = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
215 mkTupleTyConName arity
216 = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
218 mkTupNameStr 0 = SLIT("()")
219 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
220 mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
221 mkTupNameStr 3 = SLIT("(,,)") -- ditto
222 mkTupNameStr 4 = SLIT("(,,,)") -- ditto
224 = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
226 -- ToDo: what about module ???
227 -- ToDo: exported when compiling builtin ???
229 isLocalName (Local _ _ _) = True
230 isLocalName _ = False
232 isImplicitName (Global _ _ Implicit _ _) = True
233 isImplicitName _ = False
235 isBuiltinName (Global _ _ Builtin _ _) = True
236 isBuiltinName _ = False
241 %************************************************************************
243 \subsection[Name-instances]{Instance declarations}
245 %************************************************************************
248 cmpName n1 n2 = c n1 n2
250 c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2
251 c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
253 c other_1 other_2 -- the tags *must* be different
254 = let tag1 = tag_Name n1
257 if tag1 _LT_ tag2 then LT_ else GT_
259 tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT)
260 tag_Name (Global _ _ _ _ _) = ILIT(2)
264 instance Eq Name where
265 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
266 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
268 instance Ord Name where
269 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
270 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
271 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
272 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
274 instance Ord3 Name where
277 instance Uniquable Name where
278 uniqueOf = nameUnique
280 instance NamedThing Name where
285 nameUnique (Local u _ _) = u
286 nameUnique (Global u _ _ _ _) = u
288 -- when we renumber/rename things, we need to be
289 -- able to change a Name's Unique to match the cached
290 -- one in the thing it's the name of. If you know what I mean.
291 changeUnique (Local _ n l) u = Local u n l
292 changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n))
295 nameOrigName (Local _ n _) = Unqual n
296 nameOrigName (Global _ orig _ _ _) = orig
298 nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n)
299 nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
300 nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
302 nameOccName (Local _ n _) = Unqual n
303 nameOccName (Global _ orig _ _ [] ) = orig
304 nameOccName (Global _ orig _ _ occs) = head occs
306 nameExportFlag (Local _ _ _) = NotExported
307 nameExportFlag (Global _ _ _ exp _) = exp
309 nameSrcLoc (Local _ _ loc) = loc
310 nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
311 nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
312 nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
313 nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
315 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
318 nameImportFlag (Local _ _ _) = NotExported
319 nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
320 nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
321 nameImportFlag (Global _ _ Implicit _ _) = ExportAll
322 nameImportFlag (Global _ _ Builtin _ _) = ExportAll
324 isLocallyDefinedName (Local _ _ _) = True
325 isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
326 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
327 isLocallyDefinedName (Global _ _ Implicit _ _) = False
328 isLocallyDefinedName (Global _ _ Builtin _ _) = False
330 isPreludeDefinedName (Local _ n _) = False
331 isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
335 instance Outputable Name where
336 ppr sty (Local u n _)
337 | codeStyle sty = pprUnique u
338 | otherwise = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
340 ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
341 ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
342 ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs)
343 ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs
344 ppr sty (Global u o _ _ _) = ppr sty o
346 pp_all orig prov exp occs
347 = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
349 pp_exp NotExported = ppNil
350 pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
351 pp_exp ExportAbs = ppPStr SLIT("/EXP")
353 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
354 pp_prov Builtin = ppPStr SLIT("/BUILTIN")
358 %************************************************************************
360 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
362 %************************************************************************
364 The export flag @ExportAll@ means `export all there is', so there are
365 times when it is attached to a class or data type which has no
366 ops/constructors (if the class/type was imported abstractly). In
367 fact, @ExportAll@ is attached to everything except to classes/types
368 which are being {\em exported} abstractly, regardless of how they were
373 = ExportAll -- export with all constructors/methods
374 | ExportAbs -- export abstractly (tycons/classes only)
377 exportFlagOn NotExported = False
378 exportFlagOn _ = True
380 isExported a = exportFlagOn (getExportFlag a)
383 %************************************************************************
385 \subsection{Overloaded functions related to Names}
387 %************************************************************************
390 class NamedThing a where
395 origName :: NamedThing a => a -> RdrName
396 moduleOf :: RdrName -> Module
397 nameOf :: RdrName -> FAST_STRING
398 moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
400 getOccName :: NamedThing a => a -> RdrName
401 getLocalName :: NamedThing a => a -> FAST_STRING
402 getExportFlag :: NamedThing a => a -> ExportFlag
403 getSrcLoc :: NamedThing a => a -> SrcLoc
404 getImpLocs :: NamedThing a => a -> [SrcLoc]
405 isLocallyDefined :: NamedThing a => a -> Bool
406 isPreludeDefined :: NamedThing a => a -> Bool
408 -- ToDo: specialise for RdrNames?
409 origName = nameOrigName . getName
410 moduleNamePair = nameModuleNamePair . getName
412 moduleOf (Unqual n) = pRELUDE
413 moduleOf (Qual m n) = m
415 nameOf (Unqual n) = n
416 nameOf (Qual m n) = n
418 getLocalName = nameOf . origName
420 getOccName = nameOccName . getName
421 getExportFlag = nameExportFlag . getName
422 getSrcLoc = nameSrcLoc . getName
423 getImpLocs = nameImpLocs . getName
424 isLocallyDefined = isLocallyDefinedName . getName
425 isPreludeDefined = isPreludeDefinedName . getName
428 @ltLexical@ is used for sorting things into lexicographical order, so
429 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
433 a `ltLexical` b = origName a < origName b
436 These functions test strings to see if they fit the lexical categories
437 defined in the Haskell report. Normally applied as in e.g. @isCon
441 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
442 isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
444 isLexCon cs = isLexConId cs || isLexConSym cs
445 isLexVar cs = isLexVarId cs || isLexVarSym cs
447 isLexId cs = isLexConId cs || isLexVarId cs
448 isLexSym cs = isLexConSym cs || isLexVarSym cs
454 | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
455 | otherwise = isUpper c || isUpperISO c
461 | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
462 | otherwise = isLower c || isLowerISO c
468 | otherwise = c == ':'
469 -- || c == '(' -- (), (,), (,,), ...
471 -- || cs == SLIT("[]")
477 | otherwise = isSymbolASCII c
479 -- || c == '(' -- (), (,), (,,), ...
480 -- || cs == SLIT("[]")
486 | otherwise = c == '(' -- (), (,), (,,), ...
492 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
493 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
494 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
495 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
498 And one ``higher-level'' interface to those:
501 isSymLexeme :: NamedThing a => a -> Bool
504 = let str = nameOf (origName v) in isLexSym str
506 -- print `vars`, (op) correctly
507 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
511 str = nameOf (origName var)
513 if isLexSym str && not (isLexSpecialSym str)
515 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
519 then ppParens (ppr sty var)