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,
  16         appendRdr,
  17         showRdr,
  18         cmpRdr,
  19
  20         Name,
  21         Provenance,
  22         mkLocalName, isLocalName,
  23         mkTopLevName, mkImportedName,
  24         mkImplicitName, isImplicitName,
  25         mkBuiltinName, mkCompoundName,
  26
  27         mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
  28         mkTupNameStr,
  29
  30         NamedThing(..), -- class
  31         ExportFlag(..),
  32         isExported{-overloaded-}, exportFlagOn{-not-},
  33
  34         nameUnique,
  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,
  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 appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
  92 appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
  93                            Qual m (n _APPEND_ str)
  94
  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)
  99
 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 }
 103
 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  }
 109
 110 instance Ord3 RdrName where
 111     cmp = cmpRdr
 112
 113 instance NamedThing RdrName where
 114     -- We're sorta faking it here
 115     getName rdr_name
 116       = Global u rdr_name prov ex [rdr_name]
 117       where
 118         u    = panic "NamedThing.RdrName:Unique"
 119         prov = panic "NamedThing.RdrName:Provenance"
 120         ex   = panic "NamedThing.RdrName:ExportFlag"
 121
 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)
 125
 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 '.']
 131
 132 pp_name sty n | codeStyle sty = identToC n
 133               | otherwise     = ppPStr n
 134
 135 showRdr sty rdr = ppShow 100 (ppr sty rdr)
 136 \end{code}
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection[Name-datatype]{The @Name@ datatype}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 data Name
 146   = Local    Unique
 147              FAST_STRING
 148              SrcLoc
 149
 150   | Global   Unique
 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.
 156
 157 data Provenance
 158   = LocalDef SrcLoc       -- locally defined; give its source location
 159
 160   | Imported ExportFlag   -- how it was imported
 161              SrcLoc       -- *original* source location
 162              [SrcLoc]     -- any import source location(s)
 163
 164   | Implicit
 165   | Builtin
 166 \end{code}
 167
 168 \begin{code}
 169 mkLocalName = Local
 170
 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
 173
 174 mkImplicitName :: Unique -> RdrName -> Name
 175 mkImplicitName u o = Global u o Implicit NotExported []
 176
 177 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
 178 mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
 179
 180 mkCompoundName :: Unique -> [FAST_STRING] -> Name
 181 mkCompoundName u ns
 182   = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
 183   where
 184     dotify []  = []
 185     dotify [n] = [n]
 186     dotify (n:ns) = n : (map (_CONS_ '.') ns)
 187
 188 mkFunTyConName
 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)
 194
 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
 200 mkTupNameStr n
 201   = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
 202
 203         -- ToDo: what about module ???
 204         -- ToDo: exported when compiling builtin ???
 205
 206 isLocalName (Local _ _ _) = True
 207 isLocalName _           = False
 208
 209 isImplicitName (Global _ _ Implicit _ _) = True
 210 isImplicitName _                         = False
 211
 212 isBuiltinName  (Global _ _ Builtin  _ _) = True
 213 isBuiltinName  _                         = False
 214 \end{code}
 215
 216
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsection[Name-instances]{Instance declarations}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 \begin{code}
 225 cmpName n1 n2 = c n1 n2
 226   where
 227     c (Local    u1 _ _)     (Local    u2 _ _)     = cmp u1 u2
 228     c (Global   u1 _ _ _ _) (Global   u2 _ _ _ _) = cmp u1 u2
 229
 230     c other_1 other_2           -- the tags *must* be different
 231       = let tag1 = tag_Name n1
 232             tag2 = tag_Name n2
 233         in
 234         if tag1 _LT_ tag2 then LT_ else GT_
 235
 236     tag_Name (Local    _ _ _)     = (ILIT(1) :: FAST_INT)
 237     tag_Name (Global   _ _ _ _ _) = ILIT(2)
 238 \end{code}
 239
 240 \begin{code}
 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 }
 244
 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  }
 250
 251 instance Ord3 Name where
 252     cmp = cmpName
 253
 254 instance Uniquable Name where
 255     uniqueOf = nameUnique
 256
 257 instance NamedThing Name where
 258     getName n = n
 259 \end{code}
 260
 261 \begin{code}
 262 nameUnique (Local    u _ _)     = u
 263 nameUnique (Global   u _ _ _ _) = u
 264
 265 nameOrigName (Local    _ n _)        = Unqual n
 266 nameOrigName (Global   _ orig _ _ _) = orig
 267
 268 nameModuleNamePair (Local    _ n _) = (panic "nameModuleNamePair", n)
 269 nameModuleNamePair (Global   _ (Unqual n) _ _ _) = (pRELUDE, n)
 270 nameModuleNamePair (Global   _ (Qual m n) _ _ _) = (m, n)
 271
 272 nameOccName (Local    _ n _)           = Unqual n
 273 nameOccName (Global   _ orig _ _ []  ) = orig
 274 nameOccName (Global   _ orig _ _ occs) = head occs
 275
 276 nameExportFlag (Local    _ _ _)       = NotExported
 277 nameExportFlag (Global   _ _ _ exp _) = exp
 278
 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
 284
 285 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
 286 nameImpLocs _                                    = []
 287
 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
 293
 294 isLocallyDefinedName (Local  _ _ _)                    = True
 295 isLocallyDefinedName (Global _ _ (LocalDef _)     _ _) = True
 296 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
 297 isLocallyDefinedName (Global _ _ Implicit         _ _) = False
 298 isLocallyDefinedName (Global _ _ Builtin          _ _) = False
 299
 300 isPreludeDefinedName (Local    _ n _)        = False
 301 isPreludeDefinedName (Global   _ orig _ _ _) = isUnqual orig
 302 \end{code}
 303
 304 \begin{code}
 305 instance Outputable Name where
 306 #ifdef DEBUG
 307     ppr PprDebug (Local    u n _)     = pp_debug u (ppPStr n)
 308     ppr PprDebug (Global   u o _ _ _) = pp_debug u (ppr PprDebug o)
 309 #endif
 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
 315
 316 pp_debug uniq thing
 317   = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
 318
 319 pp_all orig prov exp occs
 320   = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
 321
 322 pp_exp NotExported = ppNil
 323 pp_exp ExportAll   = ppPStr SLIT("/EXP(..)")
 324 pp_exp ExportAbs   = ppPStr SLIT("/EXP")
 325
 326 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
 327 pp_prov Builtin  = ppPStr SLIT("/BUILTIN")
 328 pp_prov _        = ppNil
 329 \end{code}
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
 334 %*                                                                      *
 335 %************************************************************************
 336
 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
 342 imported.
 343
 344 \begin{code}
 345 data ExportFlag
 346   = ExportAll           -- export with all constructors/methods
 347   | ExportAbs           -- export abstractly (tycons/classes only)
 348   | NotExported
 349
 350 exportFlagOn NotExported = False
 351 exportFlagOn _           = True
 352
 353 isExported a = exportFlagOn (getExportFlag a)
 354
 355 #ifdef USE_ATTACK_PRAGMAS
 356 {-# SPECIALIZE isExported :: Class -> Bool #-}
 357 {-# SPECIALIZE isExported :: Id -> Bool #-}
 358 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
 359 #endif
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection{Overloaded functions related to Names}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 class NamedThing a where
 370     getName :: a -> Name
 371 \end{code}
 372
 373 \begin{code}
 374 origName            :: NamedThing a => a -> RdrName
 375 moduleOf            :: RdrName -> Module
 376 nameOf              :: RdrName -> FAST_STRING
 377 moduleNamePair      :: NamedThing a => a -> (Module, FAST_STRING)
 378
 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
 386
 387 -- ToDo: specialise for RdrNames?
 388 origName            = nameOrigName         . getName
 389 moduleNamePair      = nameModuleNamePair   . getName
 390
 391 moduleOf (Unqual n) = pRELUDE
 392 moduleOf (Qual m n) = m
 393
 394 nameOf (Unqual n)   = n
 395 nameOf (Qual m n)   = n
 396
 397 getLocalName        = nameOf . origName
 398
 399 getOccName          = nameOccName          . getName
 400 getExportFlag       = nameExportFlag       . getName
 401 getSrcLoc           = nameSrcLoc           . getName
 402 getImpLocs          = nameImpLocs          . getName
 403 isLocallyDefined    = isLocallyDefinedName . getName
 404 isPreludeDefined    = isPreludeDefinedName . getName
 405 \end{code}
 406
 407 @ltLexical@ is used for sorting things into lexicographical order, so
 408 as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
 409 comparison.]
 410
 411 \begin{code}
 412 a `ltLexical` b = origName a < origName b
 413
 414 #ifdef USE_ATTACK_PRAGMAS
 415 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
 416 {-# SPECIALIZE ltLexical :: Id    -> Id    -> Bool #-}
 417 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
 418 #endif
 419 \end{code}
 420
 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
 423 (getLocalName foo)@.
 424
 425 \begin{code}
 426 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
 427
 428 isLexCon cs = isLexConId  cs || isLexConSym cs
 429 isLexVar cs = isLexVarId  cs || isLexVarSym cs
 430
 431 isLexId  cs = isLexConId  cs || isLexVarId  cs
 432 isLexSym cs = isLexConSym cs || isLexVarSym cs
 433
 434 -------------
 435
 436 isLexConId cs
 437   | _NULL_ cs   = False
 438   | c == '_'    = isLexConId (_TAIL_ cs)        -- allow for leading _'s
 439   | otherwise   = isUpper c || isUpperISO c
 440   where
 441     c = _HEAD_ cs
 442
 443 isLexVarId cs
 444   | _NULL_ cs    = False
 445   | c == '_'     = isLexVarId (_TAIL_ cs)       -- allow for leading _'s
 446   | otherwise    = isLower c || isLowerISO c
 447   where
 448     c = _HEAD_ cs
 449
 450 isLexConSym cs
 451   | _NULL_ cs   = False
 452   | otherwise   = c == ':'
 453                || c == '('      -- (), (,), (,,), ...
 454                || cs == SLIT("->")
 455                || cs == SLIT("[]")
 456   where
 457     c = _HEAD_ cs
 458
 459 isLexVarSym cs
 460   | _NULL_ cs = False
 461   | otherwise = isSymbolASCII c
 462              || isSymbolISO c
 463              || c == '('        -- (), (,), (,,), ...
 464              || cs == SLIT("[]")
 465   where
 466     c = _HEAD_ cs
 467
 468 -------------
 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
 473 \end{code}
 474
 475 And one ``higher-level'' interface to those:
 476
 477 \begin{code}
 478 isSymLexeme :: NamedThing a => a -> Bool
 479
 480 isSymLexeme v
 481   = let str = nameOf (origName v) in isLexSym str
 482
 483 -- print `vars`, (op) correctly
 484 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 485
 486 pprSym sty var
 487   = if isSymLexeme var
 488     then ppr sty var
 489     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 490
 491 pprNonSym sty var
 492   = if isSymLexeme var
 493     then ppBesides [ppLparen, ppr sty var, ppRparen]
 494     else ppr sty var
 495
 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 #-}
 501 #endif
 502 \end{code}