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, 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 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 PprForC m = ppBesides [identToC m, ppPStr cSEP]
127 pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
128 pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
129 pp_mod _ m = ppBesides [ppPStr m, ppChar '.']
131 pp_name sty n | codeStyle sty = identToC n
132 | otherwise = ppPStr n
134 showRdr sty rdr = ppShow 100 (ppr sty rdr)
137 %************************************************************************
139 \subsection[Name-datatype]{The @Name@ datatype}
141 %************************************************************************
150 RdrName -- original name; Unqual => prelude
151 Provenance -- where it came from
152 ExportFlag -- is it exported?
153 [RdrName] -- ordered occurrence names (usually just one);
154 -- first may be *un*qual.
157 = LocalDef SrcLoc -- locally defined; give its source location
159 | Imported ExportFlag -- how it was imported
160 SrcLoc -- *original* source location
161 [SrcLoc] -- any import source location(s)
170 mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
171 mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
173 mkImplicitName :: Unique -> RdrName -> Name
174 mkImplicitName u o = Global u o Implicit NotExported []
176 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
177 mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
179 mkCompoundName :: Unique -> [FAST_STRING] -> Name
181 = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
185 dotify (n:ns) = n : (map (_CONS_ '.') ns)
188 = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
189 mkTupleDataConName arity
190 = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
191 mkTupleTyConName arity
192 = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
194 mkTupNameStr 0 = SLIT("()")
195 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
196 mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
197 mkTupNameStr 3 = SLIT("(,,)") -- ditto
198 mkTupNameStr 4 = SLIT("(,,,)") -- ditto
200 = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
202 -- ToDo: what about module ???
203 -- ToDo: exported when compiling builtin ???
205 isLocalName (Local _ _ _) = True
206 isLocalName _ = False
208 isImplicitName (Global _ _ Implicit _ _) = True
209 isImplicitName _ = False
211 isBuiltinName (Global _ _ Builtin _ _) = True
212 isBuiltinName _ = False
217 %************************************************************************
219 \subsection[Name-instances]{Instance declarations}
221 %************************************************************************
224 cmpName n1 n2 = c n1 n2
226 c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2
227 c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
229 c other_1 other_2 -- the tags *must* be different
230 = let tag1 = tag_Name n1
233 if tag1 _LT_ tag2 then LT_ else GT_
235 tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT)
236 tag_Name (Global _ _ _ _ _) = ILIT(2)
240 instance Eq Name where
241 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
242 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
244 instance Ord Name where
245 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
246 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
247 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
248 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
250 instance Ord3 Name where
253 instance Uniquable Name where
254 uniqueOf = nameUnique
256 instance NamedThing Name where
261 nameUnique (Local u _ _) = u
262 nameUnique (Global u _ _ _ _) = u
264 nameOrigName (Local _ n _) = Unqual n
265 nameOrigName (Global _ orig _ _ _) = orig
267 nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n)
268 nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
269 nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
271 nameOccName (Local _ n _) = Unqual n
272 nameOccName (Global _ orig _ _ [] ) = orig
273 nameOccName (Global _ orig _ _ occs) = head occs
275 nameExportFlag (Local _ _ _) = NotExported
276 nameExportFlag (Global _ _ _ exp _) = exp
278 nameSrcLoc (Local _ _ loc) = loc
279 nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
280 nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
281 nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
282 nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
284 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
287 nameImportFlag (Local _ _ _) = NotExported
288 nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
289 nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
290 nameImportFlag (Global _ _ Implicit _ _) = ExportAll
291 nameImportFlag (Global _ _ Builtin _ _) = ExportAll
293 isLocallyDefinedName (Local _ _ _) = True
294 isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
295 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
296 isLocallyDefinedName (Global _ _ Implicit _ _) = False
297 isLocallyDefinedName (Global _ _ Builtin _ _) = False
299 isPreludeDefinedName (Local _ n _) = False
300 isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
304 instance Outputable Name where
306 ppr PprDebug (Local u n _) = pp_debug u (ppPStr n)
307 ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o)
309 ppr sty (Local u n _) = pp_name sty n
310 ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
311 ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs)
312 ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs
313 ppr sty (Global u o _ _ _) = ppr sty o
316 = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
318 pp_all orig prov exp occs
319 = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
321 pp_exp NotExported = ppNil
322 pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
323 pp_exp ExportAbs = ppPStr SLIT("/EXP")
325 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
326 pp_prov Builtin = ppPStr SLIT("/BUILTIN")
330 %************************************************************************
332 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
334 %************************************************************************
336 The export flag @ExportAll@ means `export all there is', so there are
337 times when it is attached to a class or data type which has no
338 ops/constructors (if the class/type was imported abstractly). In
339 fact, @ExportAll@ is attached to everything except to classes/types
340 which are being {\em exported} abstractly, regardless of how they were
345 = ExportAll -- export with all constructors/methods
346 | ExportAbs -- export abstractly (tycons/classes only)
349 exportFlagOn NotExported = False
350 exportFlagOn _ = True
352 isExported a = exportFlagOn (getExportFlag a)
355 %************************************************************************
357 \subsection{Overloaded functions related to Names}
359 %************************************************************************
362 class NamedThing a where
367 origName :: NamedThing a => a -> RdrName
368 moduleOf :: RdrName -> Module
369 nameOf :: RdrName -> FAST_STRING
370 moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
372 getOccName :: NamedThing a => a -> RdrName
373 getLocalName :: NamedThing a => a -> FAST_STRING
374 getExportFlag :: NamedThing a => a -> ExportFlag
375 getSrcLoc :: NamedThing a => a -> SrcLoc
376 getImpLocs :: NamedThing a => a -> [SrcLoc]
377 isLocallyDefined :: NamedThing a => a -> Bool
378 isPreludeDefined :: NamedThing a => a -> Bool
380 -- ToDo: specialise for RdrNames?
381 origName = nameOrigName . getName
382 moduleNamePair = nameModuleNamePair . getName
384 moduleOf (Unqual n) = pRELUDE
385 moduleOf (Qual m n) = m
387 nameOf (Unqual n) = n
388 nameOf (Qual m n) = n
390 getLocalName = nameOf . origName
392 getOccName = nameOccName . getName
393 getExportFlag = nameExportFlag . getName
394 getSrcLoc = nameSrcLoc . getName
395 getImpLocs = nameImpLocs . getName
396 isLocallyDefined = isLocallyDefinedName . getName
397 isPreludeDefined = isPreludeDefinedName . getName
400 @ltLexical@ is used for sorting things into lexicographical order, so
401 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
405 a `ltLexical` b = origName a < origName b
408 These functions test strings to see if they fit the lexical categories
409 defined in the Haskell report. Normally applied as in e.g. @isCon
413 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
414 isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
416 isLexCon cs = isLexConId cs || isLexConSym cs
417 isLexVar cs = isLexVarId cs || isLexVarSym cs
419 isLexId cs = isLexConId cs || isLexVarId cs
420 isLexSym cs = isLexConSym cs || isLexVarSym cs
426 | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
427 | otherwise = isUpper c || isUpperISO c
433 | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
434 | otherwise = isLower c || isLowerISO c
440 | otherwise = c == ':'
441 -- || c == '(' -- (), (,), (,,), ...
443 -- || cs == SLIT("[]")
449 | otherwise = isSymbolASCII c
451 -- || c == '(' -- (), (,), (,,), ...
452 -- || cs == SLIT("[]")
458 | otherwise = c == '(' -- (), (,), (,,), ...
464 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
465 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
466 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
467 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
470 And one ``higher-level'' interface to those:
473 isSymLexeme :: NamedThing a => a -> Bool
476 = let str = nameOf (origName v) in isLexSym str
478 -- print `vars`, (op) correctly
479 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
483 str = nameOf (origName var)
485 if isLexSym str && not (isLexSpecialSym str)
487 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
491 then ppParens (ppr sty var)