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"
12 OrigName(..), -- glorified pair
13 qualToOrigName, -- a Qual to an OrigName
20 isRdrLexCon, isRdrLexConOrSpecial,
27 mkLocalName, isLocalName,
28 mkTopLevName, mkImportedName, oddlyImportedName,
29 mkImplicitName, isImplicitName,
30 mkPrimitiveName, mkWiredInName,
31 mkCompoundName, mkCompoundName2,
33 mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
36 NamedThing(..), -- class
38 isExported{-overloaded-}, exportFlagOn{-not-},
40 nameUnique, changeUnique,
42 -- nameOrigName, : not exported
47 isLocallyDefinedName, isWiredInName,
49 origName, moduleOf, nameOf,
50 getOccName, getExportFlag,
51 getSrcLoc, getImpLocs,
55 isSymLexeme, pprSym, pprNonSym,
56 isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
57 isLexConId, isLexConSym, isLexVarId, isLexVarSym
61 IMPORT_1_3(Char(isUpper,isLower))
63 import CmdLineOpts ( maybe_CompilingGhcInternals )
64 import CStrings ( identToC, modnameToC, cSEP )
65 import Outputable ( Outputable(..) )
66 import PprStyle ( PprStyle(..), codeStyle )
67 import PrelMods ( pRELUDE )
69 import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc )
70 import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
73 import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} )
75 #ifdef REALLY_HASKELL_1_3
76 ord = fromEnum :: Char -> Int
80 %************************************************************************
82 \subsection[RdrName]{The @RdrName@ datatype; names read from files}
84 %************************************************************************
87 type Module = FAST_STRING
89 data OrigName = OrigName Module FAST_STRING
91 qualToOrigName (Qual m n) = OrigName m n
95 | Qual Module FAST_STRING
97 preludeQual n = Qual pRELUDE n
99 moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this
100 -- constitutes an original name or
101 -- an occurrence name, or anything else
103 isUnqual (Unqual _) = True
104 isUnqual (Qual _ _) = False
106 isQual (Unqual _) = False
107 isQual (Qual _ _) = True
109 isRdrLexCon (Unqual n) = isLexCon n
110 isRdrLexCon (Qual m n) = isLexCon n
112 isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
113 isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
115 appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
116 appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
118 cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
119 cmpRdr (Unqual n1) (Qual m2 n2) = LT_
120 cmpRdr (Qual m1 n1) (Unqual n2) = GT_
121 cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2
122 -- always compare module-names *second*
124 cmpOrig (OrigName m1 n1) (OrigName m2 n2)
125 = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second*
127 instance Eq RdrName where
128 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
129 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
131 instance Ord RdrName where
132 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
133 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
134 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
135 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
137 instance Ord3 RdrName where
140 instance NamedThing RdrName where
141 -- We're sorta faking it here
143 = Local u n True locn
145 u = panic "NamedThing.RdrName:Unique1"
146 locn = panic "NamedThing.RdrName:locn"
148 getName rdr_name@(Qual m n)
149 = Global u m (Left n) prov ex [rdr_name]
151 u = panic "NamedThing.RdrName:Unique"
152 prov = panic "NamedThing.RdrName:Provenance"
153 ex = panic "NamedThing.RdrName:ExportFlag"
155 instance Outputable RdrName where
156 ppr sty (Unqual n) = pp_name sty n
157 ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
162 PprForAsm False _ -> pp_code
163 PprForAsm True _ -> ppBeside (ppPStr cSEP) pp_code
164 _ -> ppBeside (ppPStr m) (ppChar '.')
166 pp_code = ppBeside (ppPStr (modnameToC m)) (ppPStr cSEP)
168 pp_name sty n = (if codeStyle sty then identToC else ppPStr) n
171 = ppIntersperse sep (map pp_piece pieces)
173 sep = if codeStyle sty then ppPStr cSEP else ppChar '.'
175 pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n)
176 pp_piece (Right n) = pp_name sty n
178 showRdr sty rdr = ppShow 100 (ppr sty rdr)
180 -------------------------
181 instance Eq OrigName 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 OrigName 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 OrigName where
194 instance NamedThing OrigName where -- faking it
195 getName (OrigName m n) = getName (Qual m n)
197 instance Outputable OrigName where -- ditto
198 ppr sty (OrigName m n) = ppr sty (Qual m n)
201 %************************************************************************
203 \subsection[Name-datatype]{The @Name@ datatype}
205 %************************************************************************
211 Bool -- True <=> emphasize Unique when
212 -- printing; this is just an esthetic thing...
216 Module -- original name
218 FAST_STRING -- just an ordinary M.n name... or...
219 ([Either OrigName FAST_STRING]))
220 -- "dot" these bits of name together...
221 Provenance -- where it came from
222 ExportFlag -- is it exported?
223 [RdrName] -- ordered occurrence names (usually just one);
224 -- first may be *un*qual.
227 = LocalDef SrcLoc -- locally defined; give its source location
229 | Imported ExportFlag -- how it was imported
230 SrcLoc -- *original* source location
231 [SrcLoc] -- any import source location(s)
234 | Primitive -- really and truly primitive thing (not
235 -- definable in Haskell)
236 | WiredIn Bool -- something defined in Haskell; True <=>
237 -- definition is in the module in question;
238 -- this probably comes from the -fcompiling-prelude=...
245 mkTopLevName u (OrigName m n) locn exp occs = Global u m (Left n) (LocalDef locn) exp occs
246 mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m (Left n) (Imported imp locn imp_locs) exp occs
248 mkImplicitName :: Unique -> OrigName -> Name
249 mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported []
251 mkPrimitiveName :: Unique -> OrigName -> Name
252 mkPrimitiveName u (OrigName m n) = Global u m (Left n) Primitive NotExported []
254 mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
255 mkWiredInName u (OrigName m n) exp
256 = Global u m (Left n) (WiredIn from_here) exp []
259 = case maybe_CompilingGhcInternals of
261 Just mod -> mod == _UNPK_ m
263 mkCompoundName :: Unique
265 -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
266 -> [Either OrigName FAST_STRING] -- "dot" these names together
267 -> Name -- from which we get provenance, etc....
270 mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
271 = Local u str True{-emph uniq-} locn
273 mkCompoundName u m str ns (Global _ _ _ prov exp _)
274 = Global u m (Right (Right str : ns)) prov exp []
277 glue1 (Left (OrigName m n):ns) = m : _CONS_ '.' n : glue2 ns
278 glue1 (Right n :ns) = n : glue2 ns
280 glue2 (Left (OrigName m n):ns) = _CONS_ '.' m : _CONS_ '.' n : glue2 ns
281 glue2 (Right n :ns) = _CONS_ '.' n : glue2 ns
283 -- this ugly one is used for instance-y things
284 mkCompoundName2 :: Unique
286 -> FAST_STRING -- indicates what kind of compound thing it is
287 -> [Either OrigName FAST_STRING] -- "dot" these names together
288 -> Bool -- True <=> defined in this module
292 mkCompoundName2 u m str ns from_here locn
293 = Global u m (Right (Right str : ns))
294 (if from_here then LocalDef locn else Imported ExportAll locn [])
295 ExportAll{-instances-}
299 = mkPrimitiveName funTyConKey (OrigName pRELUDE SLIT("->"))
300 mkTupleDataConName arity
301 = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
302 mkTupleTyConName arity
303 = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
305 mkTupNameStr 0 = SLIT("()")
306 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
307 mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
308 mkTupNameStr 3 = _PK_ "(,,)" -- ditto
309 mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
311 = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
313 -- ToDo: what about module ???
314 -- ToDo: exported when compiling builtin ???
316 isLocalName (Local _ _ _ _) = True
317 isLocalName _ = False
319 -- things the compiler "knows about" are in some sense
320 -- "imported". When we are compiling the module where
321 -- the entities are defined, we need to be able to pick
322 -- them out, often in combination with isLocallyDefined.
323 oddlyImportedName (Global _ _ _ Primitive _ _) = True
324 oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True
325 oddlyImportedName _ = False
327 isImplicitName (Global _ _ _ Implicit _ _) = True
328 isImplicitName _ = False
331 %************************************************************************
333 \subsection[Name-instances]{Instance declarations}
335 %************************************************************************
338 cmpName n1 n2 = c n1 n2
340 c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2
341 c (Local _ _ _ _) _ = LT_
342 c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2
343 c (Global _ _ _ _ _ _) _ = GT_
347 instance Eq Name where
348 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
349 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
351 instance Ord Name where
352 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
353 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
354 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
355 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
357 instance Ord3 Name where
360 instance Uniquable Name where
361 uniqueOf = nameUnique
363 instance NamedThing Name where
368 nameUnique (Local u _ _ _) = u
369 nameUnique (Global u _ _ _ _ _) = u
371 -- when we renumber/rename things, we need to be
372 -- able to change a Name's Unique to match the cached
373 -- one in the thing it's the name of. If you know what I mean.
374 changeUnique (Local _ n b l) u = Local u n b l
375 changeUnique (Global _ m n p e os) u = Global u m n p e os
377 nameOrigName msg (Global _ m (Left n) _ _ _) = OrigName m n
378 nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in
379 --pprTrace ("nameOrigName:"++msg) (ppPStr str) $
382 nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n)
385 nameOccName (Local _ n _ _) = Unqual n
386 nameOccName (Global _ m (Left n) _ _ [] ) = Qual m n
387 nameOccName (Global _ m (Right n) _ _ [] ) = let str = _CONCAT_ (glue n) in
388 --pprTrace "nameOccName:" (ppPStr str) $
390 nameOccName (Global _ m (Left _) _ _ (o:_)) = o
391 nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name"
393 nameExportFlag (Local _ _ _ _) = NotExported
394 nameExportFlag (Global _ _ _ _ exp _) = exp
396 nameSrcLoc (Local _ _ _ loc) = loc
397 nameSrcLoc (Global _ _ _ (LocalDef loc) _ _) = loc
398 nameSrcLoc (Global _ _ _ (Imported _ loc _) _ _) = loc
399 nameSrcLoc (Global _ _ _ Implicit _ _) = mkUnknownSrcLoc
400 nameSrcLoc (Global _ _ _ Primitive _ _) = mkBuiltinSrcLoc
401 nameSrcLoc (Global _ _ _ (WiredIn _) _ _) = mkBuiltinSrcLoc
403 nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs
406 nameImportFlag (Local _ _ _ _) = NotExported
407 nameImportFlag (Global _ _ _ (LocalDef _) _ _) = ExportAll
408 nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp
409 nameImportFlag (Global _ _ _ Implicit _ _) = ExportAll
410 nameImportFlag (Global _ _ _ Primitive _ _) = ExportAll
411 nameImportFlag (Global _ _ _ (WiredIn _) _ _) = ExportAll
413 isLocallyDefinedName (Local _ _ _ _) = True
414 isLocallyDefinedName (Global _ _ _ (LocalDef _) _ _) = True
415 isLocallyDefinedName (Global _ _ _ (Imported _ _ _) _ _) = False
416 isLocallyDefinedName (Global _ _ _ Implicit _ _) = False
417 isLocallyDefinedName (Global _ _ _ Primitive _ _) = False
418 isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here
420 isWiredInName (Global _ _ _ (WiredIn _) _ _) = True
421 isWiredInName _ = False
425 instance Outputable Name where
426 ppr sty (Local u n emph_uniq _)
427 | codeStyle sty = pprUnique u
428 | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
429 | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
431 ppr PprDebug (Global u m (Left n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"]
432 ppr PprDebug (Global u m (Right n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name2 PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"]
434 ppr PprForUser (Global u m (Left n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name PprForUser n)
435 ppr PprForUser (Global u m (Right n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name2 PprForUser n)
436 ppr PprForUser (Global u m (Left _) _ _ occs) = ppr PprForUser (head occs)
439 -- ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs
441 ppr sty (Global u m (Left n) _ _ _) = ppBeside (pp_mod sty m) (pp_name sty n)
442 ppr sty (Global u m (Right n) _ _ _) = ppBeside (pp_mod sty m) (pp_name2 sty n)
444 pp_all orig prov exp occs
445 = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
447 pp_exp NotExported = ppNil
448 pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
449 pp_exp ExportAbs = ppPStr SLIT("/EXP")
451 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
452 pp_prov Primitive = ppPStr SLIT("/PRIMITIVE")
453 pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN")
457 %************************************************************************
459 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
461 %************************************************************************
463 The export flag @ExportAll@ means `export all there is', so there are
464 times when it is attached to a class or data type which has no
465 ops/constructors (if the class/type was imported abstractly). In
466 fact, @ExportAll@ is attached to everything except to classes/types
467 which are being {\em exported} abstractly, regardless of how they were
472 = ExportAll -- export with all constructors/methods
473 | ExportAbs -- export abstractly (tycons/classes only)
476 exportFlagOn NotExported = False
477 exportFlagOn _ = True
479 -- Be very wary about using "isExported"; perhaps you
480 -- really mean "externallyVisibleId"?
482 isExported a = exportFlagOn (getExportFlag a)
485 %************************************************************************
487 \subsection{Overloaded functions related to Names}
489 %************************************************************************
492 class NamedThing a where
497 origName :: NamedThing a => String -> a -> OrigName
498 moduleOf :: OrigName -> Module
499 nameOf :: OrigName -> FAST_STRING
501 getOccName :: NamedThing a => a -> RdrName
502 getLocalName :: NamedThing a => a -> FAST_STRING
503 getExportFlag :: NamedThing a => a -> ExportFlag
504 getSrcLoc :: NamedThing a => a -> SrcLoc
505 getImpLocs :: NamedThing a => a -> [SrcLoc]
506 isLocallyDefined :: NamedThing a => a -> Bool
508 origName str n = nameOrigName str (getName n)
510 moduleOf (OrigName m n) = m
511 nameOf (OrigName m n) = n
514 = case (getName n) of
516 Global _ m (Left n) _ _ _ -> n
517 Global _ m (Right n) _ _ _ -> let str = _CONCAT_ (glue n) in
518 -- pprTrace "getLocalName:" (ppPStr str) $
521 getOccName = nameOccName . getName
522 getExportFlag = nameExportFlag . getName
523 getSrcLoc = nameSrcLoc . getName
524 getImpLocs = nameImpLocs . getName
525 isLocallyDefined = isLocallyDefinedName . getName
529 {-# SPECIALIZE getLocalName
530 :: Name -> FAST_STRING
531 , OrigName -> FAST_STRING
532 , RdrName -> FAST_STRING
533 , RnName -> FAST_STRING
535 {-# SPECIALIZE isLocallyDefined
539 {-# SPECIALIZE origName
540 :: String -> Name -> OrigName
541 , String -> RdrName -> OrigName
542 , String -> RnName -> OrigName
546 These functions test strings to see if they fit the lexical categories
547 defined in the Haskell report. Normally applied as in e.g. @isCon
551 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
552 isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
554 isLexCon cs = isLexConId cs || isLexConSym cs
555 isLexVar cs = isLexVarId cs || isLexVarSym cs
557 isLexId cs = isLexConId cs || isLexVarId cs
558 isLexSym cs = isLexConSym cs || isLexVarSym cs
564 | otherwise = isUpper c || isUpperISO c
570 | otherwise = isLower c || isLowerISO c
576 | otherwise = c == ':'
577 -- || c == '(' -- (), (,), (,,), ...
579 -- || cs == SLIT("[]")
585 | otherwise = isSymbolASCII c
587 -- || c == '(' -- (), (,), (,,), ...
588 -- || cs == SLIT("[]")
594 | otherwise = c == '(' -- (), (,), (,,), ...
600 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
601 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
602 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
603 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
606 And one ``higher-level'' interface to those:
609 isSymLexeme :: NamedThing a => a -> Bool
612 = let str = getLocalName v in isLexSym str
614 -- print `vars`, (op) correctly
615 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
619 str = getLocalName var
621 if isLexSym str && not (isLexSpecialSym str)
623 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
627 then ppParens (ppr sty var)