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