ghc/compiler/basicTypes/Name.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Name]{@Name@: to transmit name info from renamer to typechecker}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Name (
  10         Module(..),
  11
  12         RdrName(..),
  13         isUnqual,
  14         isQual,
  15         isRdrLexCon, isRdrLexConOrSpecial,
  16         appendRdr,
  17         showRdr,
  18         cmpRdr,
  19
  20         Name,
  21         Provenance,
  22         mkLocalName, isLocalName,
  23         mkTopLevName, mkImportedName,
  24         mkImplicitName, isImplicitName,
  25         mkBuiltinName, mkCompoundName, mkCompoundName2,
  26
  27         mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
  28         mkTupNameStr,
  29
  30         NamedThing(..), -- class
  31         ExportFlag(..),
  32         isExported{-overloaded-}, exportFlagOn{-not-},
  33
  34         nameUnique, changeUnique,
  35         nameOccName,
  36         nameOrigName,
  37         nameExportFlag,
  38         nameSrcLoc,
  39         nameImpLocs,
  40         nameImportFlag,
  41         isLocallyDefinedName,
  42         isPreludeDefinedName,
  43
  44         origName, moduleOf, nameOf, moduleNamePair,
  45         getOccName, getExportFlag,
  46         getSrcLoc, getImpLocs,
  47         isLocallyDefined, isPreludeDefined,
  48         getLocalName, ltLexical,
  49
  50         isSymLexeme, pprSym, pprNonSym,
  51         isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
  52         isLexConId, isLexConSym, isLexVarId, isLexVarSym
  53     ) where
  54
  55 import Ubiq
  56
  57 import CStrings         ( identToC, cSEP )
  58 import Outputable       ( Outputable(..) )
  59 import PprStyle         ( PprStyle(..), codeStyle )
  60 import PrelMods         ( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
  61 import Pretty
  62 import SrcLoc           ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
  63 import Unique           ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
  64                           pprUnique, Unique
  65                         )
  66 import Util             ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
  67 \end{code}
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection[RdrName]{The @RdrName@ datatype; names read from files}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 type Module = FAST_STRING
  77
  78 data RdrName
  79   = Unqual FAST_STRING
  80   | Qual   Module FAST_STRING
  81
  82 isUnqual (Unqual _) = True
  83 isUnqual (Qual _ _) = False
  84
  85 isQual (Unqual _) = False
  86 isQual (Qual _ _) = True
  87
  88 isRdrLexCon (Unqual n) = isLexCon n
  89 isRdrLexCon (Qual m n) = isLexCon n
  90
  91 isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
  92 isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
  93
  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)
  97
  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
 102
 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 }
 106
 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  }
 112
 113 instance Ord3 RdrName where
 114     cmp = cmpRdr
 115
 116 instance NamedThing RdrName where
 117     -- We're sorta faking it here
 118     getName rdr_name
 119       = Global u rdr_name prov ex [rdr_name]
 120       where
 121         u    = panic "NamedThing.RdrName:Unique"
 122         prov = panic "NamedThing.RdrName:Provenance"
 123         ex   = panic "NamedThing.RdrName:ExportFlag"
 124
 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)
 128
 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 '.']
 133
 134 pp_name sty n | codeStyle sty = identToC n
 135               | otherwise     = ppPStr n
 136
 137 showRdr sty rdr = ppShow 100 (ppr sty rdr)
 138 \end{code}
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection[Name-datatype]{The @Name@ datatype}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 \begin{code}
 147 data Name
 148   = Local    Unique
 149              FAST_STRING
 150              Bool       -- True <=> emphasize Unique when
 151                         -- printing; this is just an esthetic thing...
 152              SrcLoc
 153
 154   | Global   Unique
 155              RdrName    -- original name; Unqual => prelude
 156              Provenance -- where it came from
 157              ExportFlag -- is it exported?
 158              [RdrName]  -- ordered occurrence names (usually just one);
 159                         -- first may be *un*qual.
 160
 161 data Provenance
 162   = LocalDef SrcLoc     -- locally defined; give its source location
 163
 164   | Imported ExportFlag -- how it was imported
 165              SrcLoc     -- *original* source location
 166              [SrcLoc]   -- any import source location(s)
 167
 168   | Implicit
 169   | Builtin
 170 \end{code}
 171
 172 \begin{code}
 173 mkLocalName = Local
 174
 175 mkTopLevName   u orig locn exp occs = Global u orig (LocalDef locn) exp occs
 176 mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
 177
 178 mkImplicitName :: Unique -> RdrName -> Name
 179 mkImplicitName u o = Global u o Implicit NotExported []
 180
 181 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
 182 mkBuiltinName u m n
 183   = Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported []
 184
 185 mkCompoundName :: Unique
 186                -> FAST_STRING   -- indicates what kind of compound thing it is (e.g., "sdsel")
 187                -> [RdrName]     -- "dot" these names together
 188                -> Name          -- from which we get provenance, etc....
 189                -> Name          -- result!
 190
 191 mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
 192 mkCompoundName u str ns (Global _ _ prov exp _)
 193   = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
 194
 195 glue []            acc = reverse acc
 196 glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
 197 glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
 198
 199 -- this ugly one is used for instance-y things
 200 mkCompoundName2 :: Unique
 201                -> FAST_STRING   -- indicates what kind of compound thing it is (e.g., "sdsel")
 202                -> [RdrName]     -- "dot" these names together
 203                -> [FAST_STRING] -- type-name strings
 204                -> Bool          -- True <=> defined in this module
 205                -> SrcLoc
 206                -> Name          -- result!
 207
 208 mkCompoundName2 u str ns ty_strs from_here locn
 209   = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs))))
 210              (if from_here then LocalDef locn else Imported ExportAll locn [])
 211              ExportAll{-instances-}
 212              []
 213
 214 mkFunTyConName
 215   = mkBuiltinName funTyConKey                  pRELUDE_BUILTIN SLIT("->")
 216 mkTupleDataConName arity
 217   = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
 218 mkTupleTyConName   arity
 219   = mkBuiltinName (mkTupleTyConUnique   arity) pRELUDE_BUILTIN (mkTupNameStr arity)
 220
 221 mkTupNameStr 0 = SLIT("()")
 222 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
 223 mkTupNameStr 2 = SLIT("(,)")   -- not strictly necessary
 224 mkTupNameStr 3 = SLIT("(,,)")  -- ditto
 225 mkTupNameStr 4 = SLIT("(,,,)") -- ditto
 226 mkTupNameStr n
 227   = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
 228
 229         -- ToDo: what about module ???
 230         -- ToDo: exported when compiling builtin ???
 231
 232 isLocalName (Local _ _ _ _) = True
 233 isLocalName _               = False
 234
 235 isImplicitName (Global _ _ Implicit _ _) = True
 236 isImplicitName _                         = False
 237
 238 isBuiltinName  (Global _ _ Builtin  _ _) = True
 239 isBuiltinName  _                         = False
 240 \end{code}
 241
 242
 243
 244 %************************************************************************
 245 %*                                                                      *
 246 \subsection[Name-instances]{Instance declarations}
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 \begin{code}
 251 cmpName n1 n2 = c n1 n2
 252   where
 253     c (Local    u1 _ _ _)   (Local    u2 _ _ _)   = cmp u1 u2
 254     c (Global   u1 _ _ _ _) (Global   u2 _ _ _ _) = cmp u1 u2
 255
 256     c other_1 other_2           -- the tags *must* be different
 257       = let tag1 = tag_Name n1
 258             tag2 = tag_Name n2
 259         in
 260         if tag1 _LT_ tag2 then LT_ else GT_
 261
 262     tag_Name (Local  _ _ _ _)   = (ILIT(1) :: FAST_INT)
 263     tag_Name (Global _ _ _ _ _) = ILIT(2)
 264 \end{code}
 265
 266 \begin{code}
 267 instance Eq Name where
 268     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
 269     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
 270
 271 instance Ord Name where
 272     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 273     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 274     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 275     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 276
 277 instance Ord3 Name where
 278     cmp = cmpName
 279
 280 instance Uniquable Name where
 281     uniqueOf = nameUnique
 282
 283 instance NamedThing Name where
 284     getName n = n
 285 \end{code}
 286
 287 \begin{code}
 288 nameUnique (Local  u _ _ _)   = u
 289 nameUnique (Global u _ _ _ _) = u
 290
 291 -- when we renumber/rename things, we need to be
 292 -- able to change a Name's Unique to match the cached
 293 -- one in the thing it's the name of.  If you know what I mean.
 294 changeUnique (Local      _ n b l)    u = Local u n b l
 295 changeUnique n@(Global   _ o p e os) u = ASSERT(not (isBuiltinName n))
 296                                          Global u o p e os
 297
 298 nameOrigName (Local  _ n _ _)      = Unqual n
 299 nameOrigName (Global _ orig _ _ _) = orig
 300
 301 nameModuleNamePair (Local  _ n _ _) = (panic "nameModuleNamePair", n)
 302 nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
 303 nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
 304
 305 nameOccName (Local  _ n _ _)         = Unqual n
 306 nameOccName (Global _ orig _ _ []  ) = orig
 307 nameOccName (Global _ orig _ _ occs) = head occs
 308
 309 nameExportFlag (Local  _ _ _ _)     = NotExported
 310 nameExportFlag (Global _ _ _ exp _) = exp
 311
 312 nameSrcLoc (Local  _ _ _ loc)                  = loc
 313 nameSrcLoc (Global _ _ (LocalDef loc)     _ _) = loc
 314 nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
 315 nameSrcLoc (Global _ _ Implicit           _ _) = mkUnknownSrcLoc
 316 nameSrcLoc (Global _ _ Builtin            _ _) = mkBuiltinSrcLoc
 317
 318 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
 319 nameImpLocs _                                    = []
 320
 321 nameImportFlag (Local  _ _ _ _)                    = NotExported
 322 nameImportFlag (Global _ _ (LocalDef _)       _ _) = ExportAll
 323 nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
 324 nameImportFlag (Global _ _ Implicit           _ _) = ExportAll
 325 nameImportFlag (Global _ _ Builtin            _ _) = ExportAll
 326
 327 isLocallyDefinedName (Local  _ _ _ _)                  = True
 328 isLocallyDefinedName (Global _ _ (LocalDef _)     _ _) = True
 329 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
 330 isLocallyDefinedName (Global _ _ Implicit         _ _) = False
 331 isLocallyDefinedName (Global _ _ Builtin          _ _) = False
 332
 333 isPreludeDefinedName (Local  _ n _ _)      = False
 334 isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
 335 \end{code}
 336
 337 \begin{code}
 338 instance Outputable Name where
 339     ppr sty (Local u n emph_uniq _)
 340       | codeStyle sty = pprUnique u
 341       | emph_uniq     = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
 342       | otherwise     = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
 343
 344     ppr PprDebug   (Global   u o _ _ _)         = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
 345     ppr PprForUser (Global   u o _ _ []  )      = ppr PprForUser o
 346     ppr PprForUser (Global   u o _ _ occs)      = ppr PprForUser (head occs)
 347     ppr PprShowAll (Global   u o prov exp occs) = pp_all o prov exp occs
 348     ppr sty        (Global   u o _ _ _)         = ppr sty o
 349
 350 pp_all orig prov exp occs
 351   = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
 352
 353 pp_exp NotExported = ppNil
 354 pp_exp ExportAll   = ppPStr SLIT("/EXP(..)")
 355 pp_exp ExportAbs   = ppPStr SLIT("/EXP")
 356
 357 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
 358 pp_prov Builtin  = ppPStr SLIT("/BUILTIN")
 359 pp_prov _        = ppNil
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 The export flag @ExportAll@ means `export all there is', so there are
 369 times when it is attached to a class or data type which has no
 370 ops/constructors (if the class/type was imported abstractly).  In
 371 fact, @ExportAll@ is attached to everything except to classes/types
 372 which are being {\em exported} abstractly, regardless of how they were
 373 imported.
 374
 375 \begin{code}
 376 data ExportFlag
 377   = ExportAll           -- export with all constructors/methods
 378   | ExportAbs           -- export abstractly (tycons/classes only)
 379   | NotExported
 380
 381 exportFlagOn NotExported = False
 382 exportFlagOn _           = True
 383
 384 isExported a = exportFlagOn (getExportFlag a)
 385 \end{code}
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{Overloaded functions related to Names}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 class NamedThing a where
 395     getName :: a -> Name
 396 \end{code}
 397
 398 \begin{code}
 399 origName            :: NamedThing a => a -> RdrName
 400 moduleOf            :: RdrName -> Module
 401 nameOf              :: RdrName -> FAST_STRING
 402 moduleNamePair      :: NamedThing a => a -> (Module, FAST_STRING)
 403
 404 getOccName          :: NamedThing a => a -> RdrName
 405 getLocalName        :: NamedThing a => a -> FAST_STRING
 406 getExportFlag       :: NamedThing a => a -> ExportFlag
 407 getSrcLoc           :: NamedThing a => a -> SrcLoc
 408 getImpLocs          :: NamedThing a => a -> [SrcLoc]
 409 isLocallyDefined    :: NamedThing a => a -> Bool
 410 isPreludeDefined    :: NamedThing a => a -> Bool
 411
 412 -- ToDo: specialise for RdrNames?
 413 origName            = nameOrigName         . getName
 414 moduleNamePair      = nameModuleNamePair   . getName
 415
 416 moduleOf (Unqual n) = pRELUDE
 417 moduleOf (Qual m n) = m
 418
 419 nameOf (Unqual n)   = n
 420 nameOf (Qual m n)   = n
 421
 422 getLocalName        = nameOf . origName
 423
 424 getOccName          = nameOccName          . getName
 425 getExportFlag       = nameExportFlag       . getName
 426 getSrcLoc           = nameSrcLoc           . getName
 427 getImpLocs          = nameImpLocs          . getName
 428 isLocallyDefined    = isLocallyDefinedName . getName
 429 isPreludeDefined    = isPreludeDefinedName . getName
 430 \end{code}
 431
 432 @ltLexical@ is used for sorting things into lexicographical order, so
 433 as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
 434 comparison.]
 435
 436 \begin{code}
 437 a `ltLexical` b = origName a < origName b
 438 \end{code}
 439
 440 These functions test strings to see if they fit the lexical categories
 441 defined in the Haskell report.  Normally applied as in e.g. @isCon
 442 (getLocalName foo)@.
 443
 444 \begin{code}
 445 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
 446  isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
 447
 448 isLexCon cs = isLexConId  cs || isLexConSym cs
 449 isLexVar cs = isLexVarId  cs || isLexVarSym cs
 450
 451 isLexId  cs = isLexConId  cs || isLexVarId  cs
 452 isLexSym cs = isLexConSym cs || isLexVarSym cs
 453
 454 -------------
 455
 456 isLexConId cs
 457   | _NULL_ cs   = False
 458   | c == '_'    = isLexConId (_TAIL_ cs)        -- allow for leading _'s
 459   | otherwise   = isUpper c || isUpperISO c
 460   where
 461     c = _HEAD_ cs
 462
 463 isLexVarId cs
 464   | _NULL_ cs    = False
 465   | c == '_'     = isLexVarId (_TAIL_ cs)       -- allow for leading _'s
 466   | otherwise    = isLower c || isLowerISO c
 467   where
 468     c = _HEAD_ cs
 469
 470 isLexConSym cs
 471   | _NULL_ cs   = False
 472   | otherwise   = c  == ':'
 473 --             || c  == '('     -- (), (,), (,,), ...
 474                || cs == SLIT("->")
 475 --             || cs == SLIT("[]")
 476   where
 477     c = _HEAD_ cs
 478
 479 isLexVarSym cs
 480   | _NULL_ cs = False
 481   | otherwise = isSymbolASCII c
 482              || isSymbolISO c
 483 --           || c  == '('       -- (), (,), (,,), ...
 484 --           || cs == SLIT("[]")
 485   where
 486     c = _HEAD_ cs
 487
 488 isLexSpecialSym cs
 489   | _NULL_ cs = False
 490   | otherwise = c  == '('       -- (), (,), (,,), ...
 491              || cs == SLIT("[]")
 492   where
 493     c = _HEAD_ cs
 494
 495 -------------
 496 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
 497 isSymbolISO   c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
 498 isUpperISO    c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
 499 isLowerISO    c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
 500 \end{code}
 501
 502 And one ``higher-level'' interface to those:
 503
 504 \begin{code}
 505 isSymLexeme :: NamedThing a => a -> Bool
 506
 507 isSymLexeme v
 508   = let str = nameOf (origName v) in isLexSym str
 509
 510 -- print `vars`, (op) correctly
 511 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 512
 513 pprSym sty var
 514   = let
 515         str = nameOf (origName var)
 516     in
 517     if isLexSym str && not (isLexSpecialSym str)
 518     then ppr sty var
 519     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 520
 521 pprNonSym sty var
 522   = if isSymLexeme var
 523     then ppParens (ppr sty var)
 524     else ppr sty var
 525 \end{code}