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