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 )
68 #ifdef REALLY_HASKELL_1_3
69 ord = fromEnum :: Char -> Int
73 %************************************************************************
75 \subsection[RdrName]{The @RdrName@ datatype; names read from files}
77 %************************************************************************
80 type Module = FAST_STRING
84 | Qual Module FAST_STRING
86 isUnqual (Unqual _) = True
87 isUnqual (Qual _ _) = False
89 isQual (Unqual _) = False
90 isQual (Qual _ _) = True
92 isRdrLexCon (Unqual n) = isLexCon n
93 isRdrLexCon (Qual m n) = isLexCon n
95 isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
96 isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
98 appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
99 appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
100 Qual m (n _APPEND_ str)
102 cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
103 cmpRdr (Unqual n1) (Qual m2 n2) = LT_
104 cmpRdr (Qual m1 n1) (Unqual n2) = GT_
105 cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
107 instance Eq RdrName where
108 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
109 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
111 instance Ord RdrName where
112 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
113 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
114 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
115 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
117 instance Ord3 RdrName where
120 instance NamedThing RdrName where
121 -- We're sorta faking it here
123 = Global u rdr_name prov ex [rdr_name]
125 u = panic "NamedThing.RdrName:Unique"
126 prov = panic "NamedThing.RdrName:Provenance"
127 ex = panic "NamedThing.RdrName:ExportFlag"
129 instance Outputable RdrName where
130 ppr sty (Unqual n) = pp_name sty n
131 ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
133 pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
134 pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
135 pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
136 pp_mod _ m = ppBesides [ppPStr m, ppChar '.']
138 pp_name sty n | codeStyle sty = identToC n
139 | otherwise = ppPStr n
141 showRdr sty rdr = ppShow 100 (ppr sty rdr)
144 %************************************************************************
146 \subsection[Name-datatype]{The @Name@ datatype}
148 %************************************************************************
154 Bool -- True <=> emphasize Unique when
155 -- printing; this is just an esthetic thing...
159 RdrName -- original name; Unqual => prelude
160 Provenance -- where it came from
161 ExportFlag -- is it exported?
162 [RdrName] -- ordered occurrence names (usually just one);
163 -- first may be *un*qual.
166 = LocalDef SrcLoc -- locally defined; give its source location
168 | Imported ExportFlag -- how it was imported
169 SrcLoc -- *original* source location
170 [SrcLoc] -- any import source location(s)
179 mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
180 mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
182 mkImplicitName :: Unique -> RdrName -> Name
183 mkImplicitName u o = Global u o Implicit NotExported []
185 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
187 = Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported []
189 mkCompoundName :: Unique
190 -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
191 -> [RdrName] -- "dot" these names together
192 -> Name -- from which we get provenance, etc....
195 mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
196 mkCompoundName u str ns (Global _ _ prov exp _)
197 = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
199 glue [] acc = reverse acc
200 glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
201 glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
203 -- this ugly one is used for instance-y things
204 mkCompoundName2 :: Unique
205 -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
206 -> [RdrName] -- "dot" these names together
207 -> [FAST_STRING] -- type-name strings
208 -> Bool -- True <=> defined in this module
212 mkCompoundName2 u str ns ty_strs from_here locn
213 = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs))))
214 (if from_here then LocalDef locn else Imported ExportAll locn [])
215 ExportAll{-instances-}
219 = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
220 mkTupleDataConName arity
221 = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
222 mkTupleTyConName arity
223 = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
225 mkTupNameStr 0 = SLIT("()")
226 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
227 mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
228 mkTupNameStr 3 = SLIT("(,,)") -- ditto
229 mkTupNameStr 4 = SLIT("(,,,)") -- ditto
231 = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
233 -- ToDo: what about module ???
234 -- ToDo: exported when compiling builtin ???
236 isLocalName (Local _ _ _ _) = True
237 isLocalName _ = False
239 isImplicitName (Global _ _ Implicit _ _) = True
240 isImplicitName _ = False
242 isBuiltinName (Global _ _ Builtin _ _) = True
243 isBuiltinName _ = False
248 %************************************************************************
250 \subsection[Name-instances]{Instance declarations}
252 %************************************************************************
255 cmpName n1 n2 = c n1 n2
257 c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2
258 c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
260 c other_1 other_2 -- the tags *must* be different
261 = let tag1 = tag_Name n1
264 if tag1 _LT_ tag2 then LT_ else GT_
266 tag_Name (Local _ _ _ _) = (ILIT(1) :: FAST_INT)
267 tag_Name (Global _ _ _ _ _) = ILIT(2)
271 instance Eq Name where
272 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
273 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
275 instance Ord Name where
276 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
277 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
278 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
279 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
281 instance Ord3 Name where
284 instance Uniquable Name where
285 uniqueOf = nameUnique
287 instance NamedThing Name where
292 nameUnique (Local u _ _ _) = u
293 nameUnique (Global u _ _ _ _) = u
295 -- when we renumber/rename things, we need to be
296 -- able to change a Name's Unique to match the cached
297 -- one in the thing it's the name of. If you know what I mean.
298 changeUnique (Local _ n b l) u = Local u n b l
299 changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n))
302 nameOrigName (Local _ n _ _) = Unqual n
303 nameOrigName (Global _ orig _ _ _) = orig
305 nameModuleNamePair (Local _ n _ _) = (panic "nameModuleNamePair", n)
306 nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
307 nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
309 nameOccName (Local _ n _ _) = Unqual n
310 nameOccName (Global _ orig _ _ [] ) = orig
311 nameOccName (Global _ orig _ _ occs) = head occs
313 nameExportFlag (Local _ _ _ _) = NotExported
314 nameExportFlag (Global _ _ _ exp _) = exp
316 nameSrcLoc (Local _ _ _ loc) = loc
317 nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
318 nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
319 nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
320 nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
322 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
325 nameImportFlag (Local _ _ _ _) = NotExported
326 nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
327 nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
328 nameImportFlag (Global _ _ Implicit _ _) = ExportAll
329 nameImportFlag (Global _ _ Builtin _ _) = ExportAll
331 isLocallyDefinedName (Local _ _ _ _) = True
332 isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
333 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
334 isLocallyDefinedName (Global _ _ Implicit _ _) = False
335 isLocallyDefinedName (Global _ _ Builtin _ _) = False
337 isPreludeDefinedName (Local _ n _ _) = False
338 isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
342 instance Outputable Name where
343 ppr sty (Local u n emph_uniq _)
344 | codeStyle sty = pprUnique u
345 | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
346 | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
348 ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
349 ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
350 ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs)
351 ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs
352 ppr sty (Global u o _ _ _) = ppr sty o
354 pp_all orig prov exp occs
355 = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
357 pp_exp NotExported = ppNil
358 pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
359 pp_exp ExportAbs = ppPStr SLIT("/EXP")
361 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
362 pp_prov Builtin = ppPStr SLIT("/BUILTIN")
366 %************************************************************************
368 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
370 %************************************************************************
372 The export flag @ExportAll@ means `export all there is', so there are
373 times when it is attached to a class or data type which has no
374 ops/constructors (if the class/type was imported abstractly). In
375 fact, @ExportAll@ is attached to everything except to classes/types
376 which are being {\em exported} abstractly, regardless of how they were
381 = ExportAll -- export with all constructors/methods
382 | ExportAbs -- export abstractly (tycons/classes only)
385 exportFlagOn NotExported = False
386 exportFlagOn _ = True
388 isExported a = exportFlagOn (getExportFlag a)
391 %************************************************************************
393 \subsection{Overloaded functions related to Names}
395 %************************************************************************
398 class NamedThing a where
403 origName :: NamedThing a => a -> RdrName
404 moduleOf :: RdrName -> Module
405 nameOf :: RdrName -> FAST_STRING
406 moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
408 getOccName :: NamedThing a => a -> RdrName
409 getLocalName :: NamedThing a => a -> FAST_STRING
410 getExportFlag :: NamedThing a => a -> ExportFlag
411 getSrcLoc :: NamedThing a => a -> SrcLoc
412 getImpLocs :: NamedThing a => a -> [SrcLoc]
413 isLocallyDefined :: NamedThing a => a -> Bool
414 isPreludeDefined :: NamedThing a => a -> Bool
416 -- ToDo: specialise for RdrNames?
417 origName = nameOrigName . getName
418 moduleNamePair = nameModuleNamePair . getName
420 moduleOf (Unqual n) = pRELUDE
421 moduleOf (Qual m n) = m
423 nameOf (Unqual n) = n
424 nameOf (Qual m n) = n
426 getLocalName = nameOf . origName
428 getOccName = nameOccName . getName
429 getExportFlag = nameExportFlag . getName
430 getSrcLoc = nameSrcLoc . getName
431 getImpLocs = nameImpLocs . getName
432 isLocallyDefined = isLocallyDefinedName . getName
433 isPreludeDefined = isPreludeDefinedName . getName
436 @ltLexical@ is used for sorting things into lexicographical order, so
437 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
441 a `ltLexical` b = origName a < origName b
444 These functions test strings to see if they fit the lexical categories
445 defined in the Haskell report. Normally applied as in e.g. @isCon
449 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
450 isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
452 isLexCon cs = isLexConId cs || isLexConSym cs
453 isLexVar cs = isLexVarId cs || isLexVarSym cs
455 isLexId cs = isLexConId cs || isLexVarId cs
456 isLexSym cs = isLexConSym cs || isLexVarSym cs
462 | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
463 | otherwise = isUpper c || isUpperISO c
469 | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
470 | otherwise = isLower c || isLowerISO c
476 | otherwise = c == ':'
477 -- || c == '(' -- (), (,), (,,), ...
479 -- || cs == SLIT("[]")
485 | otherwise = isSymbolASCII c
487 -- || c == '(' -- (), (,), (,,), ...
488 -- || cs == SLIT("[]")
494 | otherwise = c == '(' -- (), (,), (,,), ...
500 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
501 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
502 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
503 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
506 And one ``higher-level'' interface to those:
509 isSymLexeme :: NamedThing a => a -> Bool
512 = let str = nameOf (origName v) in isLexSym str
514 -- print `vars`, (op) correctly
515 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
519 str = nameOf (origName var)
521 if isLexSym str && not (isLexSpecialSym str)
523 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
527 then ppParens (ppr sty var)