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