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