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, 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 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 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 '.']
 130
 131 pp_name sty n | codeStyle sty = identToC n
 132               | otherwise     = ppPStr n
 133
 134 showRdr sty rdr = ppShow 100 (ppr sty rdr)
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection[Name-datatype]{The @Name@ datatype}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 data Name
 145   = Local    Unique
 146              FAST_STRING
 147              SrcLoc
 148
 149   | Global   Unique
 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.
 155
 156 data Provenance
 157   = LocalDef SrcLoc       -- locally defined; give its source location
 158
 159   | Imported ExportFlag   -- how it was imported
 160              SrcLoc       -- *original* source location
 161              [SrcLoc]     -- any import source location(s)
 162
 163   | Implicit
 164   | Builtin
 165 \end{code}
 166
 167 \begin{code}
 168 mkLocalName = Local
 169
 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
 172
 173 mkImplicitName :: Unique -> RdrName -> Name
 174 mkImplicitName u o = Global u o Implicit NotExported []
 175
 176 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
 177 mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
 178
 179 mkCompoundName :: Unique -> [FAST_STRING] -> Name
 180 mkCompoundName u ns
 181   = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
 182   where
 183     dotify []  = []
 184     dotify [n] = [n]
 185     dotify (n:ns) = n : (map (_CONS_ '.') ns)
 186
 187 mkFunTyConName
 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)
 193
 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
 199 mkTupNameStr n
 200   = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
 201
 202         -- ToDo: what about module ???
 203         -- ToDo: exported when compiling builtin ???
 204
 205 isLocalName (Local _ _ _) = True
 206 isLocalName _           = False
 207
 208 isImplicitName (Global _ _ Implicit _ _) = True
 209 isImplicitName _                         = False
 210
 211 isBuiltinName  (Global _ _ Builtin  _ _) = True
 212 isBuiltinName  _                         = False
 213 \end{code}
 214
 215
 216
 217 %************************************************************************
 218 %*                                                                      *
 219 \subsection[Name-instances]{Instance declarations}
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 \begin{code}
 224 cmpName n1 n2 = c n1 n2
 225   where
 226     c (Local    u1 _ _)     (Local    u2 _ _)     = cmp u1 u2
 227     c (Global   u1 _ _ _ _) (Global   u2 _ _ _ _) = cmp u1 u2
 228
 229     c other_1 other_2           -- the tags *must* be different
 230       = let tag1 = tag_Name n1
 231             tag2 = tag_Name n2
 232         in
 233         if tag1 _LT_ tag2 then LT_ else GT_
 234
 235     tag_Name (Local    _ _ _)     = (ILIT(1) :: FAST_INT)
 236     tag_Name (Global   _ _ _ _ _) = ILIT(2)
 237 \end{code}
 238
 239 \begin{code}
 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 }
 243
 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  }
 249
 250 instance Ord3 Name where
 251     cmp = cmpName
 252
 253 instance Uniquable Name where
 254     uniqueOf = nameUnique
 255
 256 instance NamedThing Name where
 257     getName n = n
 258 \end{code}
 259
 260 \begin{code}
 261 nameUnique (Local    u _ _)     = u
 262 nameUnique (Global   u _ _ _ _) = u
 263
 264 nameOrigName (Local    _ n _)        = Unqual n
 265 nameOrigName (Global   _ orig _ _ _) = orig
 266
 267 nameModuleNamePair (Local    _ n _) = (panic "nameModuleNamePair", n)
 268 nameModuleNamePair (Global   _ (Unqual n) _ _ _) = (pRELUDE, n)
 269 nameModuleNamePair (Global   _ (Qual m n) _ _ _) = (m, n)
 270
 271 nameOccName (Local    _ n _)           = Unqual n
 272 nameOccName (Global   _ orig _ _ []  ) = orig
 273 nameOccName (Global   _ orig _ _ occs) = head occs
 274
 275 nameExportFlag (Local    _ _ _)       = NotExported
 276 nameExportFlag (Global   _ _ _ exp _) = exp
 277
 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
 283
 284 nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
 285 nameImpLocs _                                    = []
 286
 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
 292
 293 isLocallyDefinedName (Local  _ _ _)                    = True
 294 isLocallyDefinedName (Global _ _ (LocalDef _)     _ _) = True
 295 isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
 296 isLocallyDefinedName (Global _ _ Implicit         _ _) = False
 297 isLocallyDefinedName (Global _ _ Builtin          _ _) = False
 298
 299 isPreludeDefinedName (Local    _ n _)        = False
 300 isPreludeDefinedName (Global   _ orig _ _ _) = isUnqual orig
 301 \end{code}
 302
 303 \begin{code}
 304 instance Outputable Name where
 305 #ifdef DEBUG
 306     ppr PprDebug (Local    u n _)     = pp_debug u (ppPStr n)
 307     ppr PprDebug (Global   u o _ _ _) = pp_debug u (ppr PprDebug o)
 308 #endif
 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
 314
 315 pp_debug uniq thing
 316   = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
 317
 318 pp_all orig prov exp occs
 319   = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
 320
 321 pp_exp NotExported = ppNil
 322 pp_exp ExportAll   = ppPStr SLIT("/EXP(..)")
 323 pp_exp ExportAbs   = ppPStr SLIT("/EXP")
 324
 325 pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
 326 pp_prov Builtin  = ppPStr SLIT("/BUILTIN")
 327 pp_prov _        = ppNil
 328 \end{code}
 329
 330 %************************************************************************
 331 %*                                                                      *
 332 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
 333 %*                                                                      *
 334 %************************************************************************
 335
 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
 341 imported.
 342
 343 \begin{code}
 344 data ExportFlag
 345   = ExportAll           -- export with all constructors/methods
 346   | ExportAbs           -- export abstractly (tycons/classes only)
 347   | NotExported
 348
 349 exportFlagOn NotExported = False
 350 exportFlagOn _           = True
 351
 352 isExported a = exportFlagOn (getExportFlag a)
 353
 354 #ifdef USE_ATTACK_PRAGMAS
 355 {-# SPECIALIZE isExported :: Class -> Bool #-}
 356 {-# SPECIALIZE isExported :: Id -> Bool #-}
 357 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
 358 #endif
 359 \end{code}
 360
 361 %************************************************************************
 362 %*                                                                      *
 363 \subsection{Overloaded functions related to Names}
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 \begin{code}
 368 class NamedThing a where
 369     getName :: a -> Name
 370 \end{code}
 371
 372 \begin{code}
 373 origName            :: NamedThing a => a -> RdrName
 374 moduleOf            :: RdrName -> Module
 375 nameOf              :: RdrName -> FAST_STRING
 376 moduleNamePair      :: NamedThing a => a -> (Module, FAST_STRING)
 377
 378 getOccName          :: NamedThing a => a -> RdrName
 379 getLocalName        :: NamedThing a => a -> FAST_STRING
 380 getExportFlag       :: NamedThing a => a -> ExportFlag
 381 getSrcLoc           :: NamedThing a => a -> SrcLoc
 382 getImpLocs          :: NamedThing a => a -> [SrcLoc]
 383 isLocallyDefined    :: NamedThing a => a -> Bool
 384 isPreludeDefined    :: NamedThing a => a -> Bool
 385
 386 -- ToDo: specialise for RdrNames?
 387 origName            = nameOrigName         . getName
 388 moduleNamePair      = nameModuleNamePair   . getName
 389
 390 moduleOf (Unqual n) = pRELUDE
 391 moduleOf (Qual m n) = m
 392
 393 nameOf (Unqual n)   = n
 394 nameOf (Qual m n)   = n
 395
 396 getLocalName        = nameOf . origName
 397
 398 getOccName          = nameOccName          . getName
 399 getExportFlag       = nameExportFlag       . getName
 400 getSrcLoc           = nameSrcLoc           . getName
 401 getImpLocs          = nameImpLocs          . getName
 402 isLocallyDefined    = isLocallyDefinedName . getName
 403 isPreludeDefined    = isPreludeDefinedName . getName
 404 \end{code}
 405
 406 @ltLexical@ is used for sorting things into lexicographical order, so
 407 as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
 408 comparison.]
 409
 410 \begin{code}
 411 a `ltLexical` b = origName a < origName b
 412
 413 #ifdef USE_ATTACK_PRAGMAS
 414 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
 415 {-# SPECIALIZE ltLexical :: Id    -> Id    -> Bool #-}
 416 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
 417 #endif
 418 \end{code}
 419
 420 These functions test strings to see if they fit the lexical categories
 421 defined in the Haskell report.  Normally applied as in e.g. @isCon
 422 (getLocalName foo)@.
 423
 424 \begin{code}
 425 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
 426  isLexVarId, isLexVarSym, isLexSpecialSym :: 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 isLexSpecialSym cs
 469   | _NULL_ cs = False
 470   | otherwise = c  == '('       -- (), (,), (,,), ...
 471              || cs == SLIT("[]")
 472   where
 473     c = _HEAD_ cs
 474
 475 -------------
 476 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
 477 isSymbolISO   c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
 478 isUpperISO    c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
 479 isLowerISO    c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
 480 \end{code}
 481
 482 And one ``higher-level'' interface to those:
 483
 484 \begin{code}
 485 isSymLexeme :: NamedThing a => a -> Bool
 486
 487 isSymLexeme v
 488   = let str = nameOf (origName v) in isLexSym str
 489
 490 -- print `vars`, (op) correctly
 491 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 492
 493 pprSym sty var
 494   = let
 495         str = nameOf (origName var)
 496     in
 497     if isLexSym str && not (isLexSpecialSym str)
 498     then ppr sty var
 499     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 500
 501 pprNonSym sty var
 502   = if isSymLexeme var
 503     then ppParens (ppr sty var)
 504     else ppr sty var
 505
 506 #ifdef USE_ATTACK_PRAGMAS
 507 {-# SPECIALIZE isSymLexeme :: Id -> Bool #-}
 508 {-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-}
 509 {-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-}
 510 {-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-}
 511 #endif
 512 \end{code}