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