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