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"
22 mkLocalName, isLocalName,
23 mkTopLevName, mkImportedName,
24 mkImplicitName, isImplicitName,
25 mkBuiltinName, mkCompoundName,
27 mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
30 NamedThing(..), -- class
32 isExported{-overloaded-}, exportFlagOn{-not-},
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,
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 appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
92 appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
93 Qual m (n _APPEND_ str)
95 cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
96 cmpRdr (Unqual n1) (Qual m2 n2) = LT_
97 cmpRdr (Qual m1 n1) (Unqual n2) = GT_
98 cmpRdr (Qual m1 n1) (Qual m2 n2) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2)
100 instance Eq RdrName where
101 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
102 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
104 instance Ord RdrName where
105 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
106 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
107 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
108 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
110 instance Ord3 RdrName where
113 instance NamedThing RdrName where
114 -- We're sorta faking it here
116 = Global u rdr_name prov ex [rdr_name]
118 u = panic "NamedThing.RdrName:Unique"
119 prov = panic "NamedThing.RdrName:Provenance"
120 ex = panic "NamedThing.RdrName:ExportFlag"
122 instance Outputable RdrName where
123 ppr sty (Unqual n) = pp_name sty n
124 ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
126 pp_mod PprInterface m = ppNil
127 pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
128 pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
129 pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
130 pp_mod _ m = ppBesides [ppPStr m, ppChar '.']
132 pp_name sty n | codeStyle sty = identToC n
133 | otherwise = ppPStr n
135 showRdr sty rdr = ppShow 100 (ppr sty rdr)
138 %************************************************************************
140 \subsection[Name-datatype]{The @Name@ datatype}
142 %************************************************************************
151 RdrName -- original name; Unqual => prelude
152 Provenance -- where it came from
153 ExportFlag -- is it exported?
154 [RdrName] -- ordered occurrence names (usually just one);
155 -- first may be *un*qual.
158 = LocalDef SrcLoc -- locally defined; give its source location
160 | Imported ExportFlag -- how it was imported
161 SrcLoc -- *original* source location
162 [SrcLoc] -- any import source location(s)
171 mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
172 mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
174 mkImplicitName :: Unique -> RdrName -> Name
175 mkImplicitName u o = Global u o Implicit NotExported []
177 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
178 mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
180 mkCompoundName :: Unique -> [FAST_STRING] -> Name
182 = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
186 dotify (n:ns) = n : (map (_CONS_ '.') ns)
189 = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
190 mkTupleDataConName arity
191 = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
192 mkTupleTyConName arity
193 = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
195 mkTupNameStr 0 = SLIT("()")
196 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
197 mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
198 mkTupNameStr 3 = SLIT("(,,)") -- ditto
199 mkTupNameStr 4 = SLIT("(,,,)") -- ditto
201 = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
203 -- ToDo: what about module ???
204 -- ToDo: exported when compiling builtin ???
206 isLocalName (Local _ _ _) = True
207 isLocalName _ = False
209 isImplicitName (Global _ _ Implicit _ _) = True
210 isImplicitName _ = False
212 isBuiltinName (Global _ _ Builtin _ _) = True
213 isBuiltinName _ = False
218 %************************************************************************
220 \subsection[Name-instances]{Instance declarations}
222 %************************************************************************
225 cmpName n1 n2 = c n1 n2
227 c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2
228 c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
230 c other_1 other_2 -- the tags *must* be different
231 = let tag1 = tag_Name n1
234 if tag1 _LT_ tag2 then LT_ else GT_
236 tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT)
237 tag_Name (Global _ _ _ _ _) = ILIT(2)
241 instance Eq Name where
242 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
243 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
245 instance Ord Name where
246 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
247 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
248 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
249 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
251 instance Ord3 Name where
254 instance Uniquable Name where
255 uniqueOf = nameUnique
257 instance NamedThing Name where
262 nameUnique (Local u _ _) = u
263 nameUnique (Global u _ _ _ _) = u
265 nameOrigName (Local _ n _) = Unqual n
266 nameOrigName (Global _ orig _ _ _) = orig
268 nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n)
269 nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
270 nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
272 nameOccName (Local _ n _) = Unqual n
273 nameOccName (Global _ orig _ _ [] ) = orig
274 nameOccName (Global _ orig _ _ occs) = head occs
276 nameExportFlag (Local _ _ _) = NotExported
277 nameExportFlag (Global _ _ _ exp _) = exp
279 nameSrcLoc (Local _ _ loc) = loc
280 nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
281 nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
282 nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
283 nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
285 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
288 nameImportFlag (Local _ _ _) = NotExported
289 nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
290 nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
291 nameImportFlag (Global _ _ Implicit _ _) = ExportAll
292 nameImportFlag (Global _ _ Builtin _ _) = ExportAll
294 isLocallyDefinedName (Local _ _ _) = True
295 isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
296 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
297 isLocallyDefinedName (Global _ _ Implicit _ _) = False
298 isLocallyDefinedName (Global _ _ Builtin _ _) = False
300 isPreludeDefinedName (Local _ n _) = False
301 isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
305 instance Outputable Name where
307 ppr PprDebug (Local u n _) = pp_debug u (ppPStr n)
308 ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o)
310 ppr sty (Local u n _) = pp_name sty n
311 ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
312 ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs)
313 ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs
314 ppr sty (Global u o _ _ _) = ppr sty o
317 = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
319 pp_all orig prov exp occs
320 = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
322 pp_exp NotExported = ppNil
323 pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
324 pp_exp ExportAbs = ppPStr SLIT("/EXP")
326 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
327 pp_prov Builtin = ppPStr SLIT("/BUILTIN")
331 %************************************************************************
333 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
335 %************************************************************************
337 The export flag @ExportAll@ means `export all there is', so there are
338 times when it is attached to a class or data type which has no
339 ops/constructors (if the class/type was imported abstractly). In
340 fact, @ExportAll@ is attached to everything except to classes/types
341 which are being {\em exported} abstractly, regardless of how they were
346 = ExportAll -- export with all constructors/methods
347 | ExportAbs -- export abstractly (tycons/classes only)
350 exportFlagOn NotExported = False
351 exportFlagOn _ = True
353 isExported a = exportFlagOn (getExportFlag a)
355 #ifdef USE_ATTACK_PRAGMAS
356 {-# SPECIALIZE isExported :: Class -> Bool #-}
357 {-# SPECIALIZE isExported :: Id -> Bool #-}
358 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
362 %************************************************************************
364 \subsection{Overloaded functions related to Names}
366 %************************************************************************
369 class NamedThing a where
374 origName :: NamedThing a => a -> RdrName
375 moduleOf :: RdrName -> Module
376 nameOf :: RdrName -> FAST_STRING
377 moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
379 getOccName :: NamedThing a => a -> RdrName
380 getLocalName :: NamedThing a => a -> FAST_STRING
381 getExportFlag :: NamedThing a => a -> ExportFlag
382 getSrcLoc :: NamedThing a => a -> SrcLoc
383 getImpLocs :: NamedThing a => a -> [SrcLoc]
384 isLocallyDefined :: NamedThing a => a -> Bool
385 isPreludeDefined :: NamedThing a => a -> Bool
387 -- ToDo: specialise for RdrNames?
388 origName = nameOrigName . getName
389 moduleNamePair = nameModuleNamePair . getName
391 moduleOf (Unqual n) = pRELUDE
392 moduleOf (Qual m n) = m
394 nameOf (Unqual n) = n
395 nameOf (Qual m n) = n
397 getLocalName = nameOf . origName
399 getOccName = nameOccName . getName
400 getExportFlag = nameExportFlag . getName
401 getSrcLoc = nameSrcLoc . getName
402 getImpLocs = nameImpLocs . getName
403 isLocallyDefined = isLocallyDefinedName . getName
404 isPreludeDefined = isPreludeDefinedName . getName
407 @ltLexical@ is used for sorting things into lexicographical order, so
408 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
412 a `ltLexical` b = origName a < origName b
414 #ifdef USE_ATTACK_PRAGMAS
415 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
416 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
417 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
421 These functions test strings to see if they fit the lexical categories
422 defined in the Haskell report. Normally applied as in e.g. @isCon
426 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
428 isLexCon cs = isLexConId cs || isLexConSym cs
429 isLexVar cs = isLexVarId cs || isLexVarSym cs
431 isLexId cs = isLexConId cs || isLexVarId cs
432 isLexSym cs = isLexConSym cs || isLexVarSym cs
438 | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
439 | otherwise = isUpper c || isUpperISO c
445 | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
446 | otherwise = isLower c || isLowerISO c
452 | otherwise = c == ':'
453 || c == '(' -- (), (,), (,,), ...
461 | otherwise = isSymbolASCII c
463 || c == '(' -- (), (,), (,,), ...
469 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
470 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
471 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
472 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
475 And one ``higher-level'' interface to those:
478 isSymLexeme :: NamedThing a => a -> Bool
481 = let str = nameOf (origName v) in isLexSym str
483 -- print `vars`, (op) correctly
484 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
489 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
493 then ppBesides [ppLparen, ppr sty var, ppRparen]
496 #ifdef USE_ATTACK_PRAGMAS
497 {-# SPECIALIZE isSymLexeme :: Id -> Bool #-}
498 {-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-}
499 {-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-}
500 {-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-}