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         -- things for the Name NON-abstract type
  11         Name(..),
  12
  13         isTyConName, isClassName, isClassOpName,
  14         isUnboundName, invisibleName,
  15
  16         getTagFromClassOpName, getSynNameArity,
  17
  18         getNameShortName, getNameFullName
  19
  20     ) where
  21
  22 import Ubiq{-uitous-}
  23
  24 import NameLoop         -- break Name/Id loop, Name/PprType/Id loop
  25
  26 import NameTypes
  27 import Outputable       ( ExportFlag(..) )
  28 import Pretty
  29 import PprStyle         ( PprStyle(..) )
  30 import SrcLoc           ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
  31 import TyCon            ( TyCon, synTyConArity )
  32 import TyVar            ( GenTyVar )
  33 import Unique           ( pprUnique, Unique )
  34 import Util             ( panic, panic#, pprPanic )
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[Name-datatype]{The @Name@ datatype}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 \begin{code}
  44 data Name
  45   = Short           Unique      -- Local ids and type variables
  46                     ShortName
  47
  48         -- Nano-prelude things; truly wired in.
  49         -- Includes all type constructors and their associated data constructors
  50   | WiredInTyCon    TyCon
  51   | WiredInVal      Id
  52
  53   | TyConName       Unique      -- TyCons other than Prelude ones; need to
  54                     FullName    -- separate these because we want to pin on
  55                     Arity       -- their arity.
  56                     Bool        -- False <=> `type',
  57                                 -- True <=> `data' or `newtype'
  58                     [Name]      -- List of user-visible data constructors;
  59                                 -- NB: for `data' types only.
  60                                 -- Used in checking import/export lists.
  61
  62   | ClassName       Unique
  63                     FullName
  64                     [Name]      -- List of class methods; used for checking
  65                                 -- import/export lists.
  66
  67   | ValName         Unique      -- Top level id
  68                     FullName
  69
  70   | ClassOpName     Unique
  71                     Name        -- Name associated w/ the defined class
  72                                 -- (can get unique and export info, etc., from this)
  73                     FAST_STRING -- The class operation
  74                     Int         -- Unique tag within the class
  75
  76         -- Miscellaneous
  77   | Unbound         FAST_STRING -- Placeholder for a name which isn't in scope
  78                                 -- Used only so that the renamer can carry on after
  79                                 -- finding an unbound identifier.
  80                                 -- The string is grabbed from the unbound name, for
  81                                 -- debugging information only.
  82 \end{code}
  83
  84 These @is..@ functions are used in the renamer to check that (eg) a tycon
  85 is seen in a context which demands one.
  86
  87 \begin{code}
  88 isTyConName, isClassName, isUnboundName :: Name -> Bool
  89
  90 isTyConName (TyConName _ _ _ _ _) = True
  91 isTyConName (WiredInTyCon _)      = True
  92 isTyConName other                 = False
  93
  94 isClassName (ClassName _ _ _) = True
  95 isClassName other             = False
  96
  97 isUnboundName (Unbound _) = True
  98 isUnboundName other       = False
  99 \end{code}
 100
 101 @isClassOpName@ is a little cleverer: it checks to see whether the
 102 class op comes from the correct class.
 103
 104 \begin{code}
 105 isClassOpName :: Name   -- The name of the class expected for this op
 106               -> Name   -- The name of the thing which should be a class op
 107               -> Bool
 108
 109 isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
 110   = uniq1 == uniq2
 111 isClassOpName other_class other_op = False
 112 \end{code}
 113
 114 A Name is ``invisible'' if the user has no business seeing it; e.g., a
 115 data-constructor for an abstract data type (but whose constructors are
 116 known because of a pragma).
 117 \begin{code}
 118 invisibleName :: Name -> Bool
 119
 120 invisibleName (TyConName _ n _ _ _) = invisibleFullName n
 121 invisibleName (ClassName _ n _)     = invisibleFullName n
 122 invisibleName (ValName   _ n)       = invisibleFullName n
 123 invisibleName _                     = False
 124 \end{code}
 125
 126 \begin{code}
 127 getTagFromClassOpName :: Name -> Int
 128 getTagFromClassOpName (ClassOpName _ _ _ tag)  = tag
 129
 130 getSynNameArity :: Name -> Maybe Arity
 131 getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
 132 getSynNameArity (WiredInTyCon tycon)                 = synTyConArity tycon
 133 getSynNameArity other_name                           = Nothing
 134
 135 getNameShortName :: Name -> ShortName
 136 getNameShortName (Short _ sn) = sn
 137
 138 getNameFullName :: Name -> FullName
 139 getNameFullName n = get_nm "getNameFullName" n
 140 \end{code}
 141
 142
 143 %************************************************************************
 144 %*                                                                      *
 145 \subsection[Name-instances]{Instance declarations}
 146 %*                                                                      *
 147 %************************************************************************
 148
 149 \begin{code}
 150 cmpName n1 n2 = c n1 n2
 151   where
 152     c (Short u1 _)           (Short u2 _)               = cmp u1 u2
 153
 154     c (WiredInTyCon tc1)     (WiredInTyCon tc2)         = cmp tc1 tc2
 155     c (WiredInVal   id1)     (WiredInVal   id2)         = cmp id1 id2
 156
 157     c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _)     = cmp u1 u2
 158     c (ClassName u1 _ _)     (ClassName u2 _ _)         = cmp u1 u2
 159     c (ValName   u1 _)       (ValName   u2 _)           = cmp u1 u2
 160
 161     c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _)     = cmp u1 u2
 162     c (Unbound a)            (Unbound b)                = panic# "Eq.Name.Unbound"
 163
 164     c other_1 other_2           -- the tags *must* be different
 165       = let tag1 = tag_Name n1
 166             tag2 = tag_Name n2
 167         in
 168         if tag1 _LT_ tag2 then LT_ else GT_
 169
 170     tag_Name (Short _ _)                = (ILIT(1) :: FAST_INT)
 171     tag_Name (WiredInTyCon _)           = ILIT(2)
 172     tag_Name (WiredInVal _)             = ILIT(3)
 173     tag_Name (TyConName _ _ _ _ _)      = ILIT(7)
 174     tag_Name (ClassName _ _ _)          = ILIT(8)
 175     tag_Name (ValName _ _)              = ILIT(9)
 176     tag_Name (ClassOpName _ _ _ _)      = ILIT(10)
 177     tag_Name (Unbound _)                = ILIT(11)
 178 \end{code}
 179
 180 \begin{code}
 181 instance Eq Name where
 182     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
 183     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
 184
 185 instance Ord Name where
 186     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 187     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 188     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 189     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 190
 191 instance Ord3 Name where
 192     cmp = cmpName
 193 \end{code}
 194
 195 \begin{code}
 196 instance NamedThing Name where
 197     getExportFlag (Short _ _)           = NotExported
 198     getExportFlag (WiredInTyCon _)      = NotExported -- compiler always know about these
 199     getExportFlag (WiredInVal _)        = NotExported
 200     getExportFlag (ClassOpName _ c _ _) = getExportFlag c
 201     getExportFlag other                 = getExportFlag (get_nm "getExportFlag" other)
 202
 203     isLocallyDefined (Short _ _)           = True
 204     isLocallyDefined (WiredInTyCon _)      = False
 205     isLocallyDefined (WiredInVal _)        = False
 206     isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
 207     isLocallyDefined other                 = isLocallyDefined (get_nm "isLocallyDefined" other)
 208
 209     getOrigName (Short _ sn)            = getOrigName sn
 210     getOrigName (WiredInTyCon tc)       = getOrigName tc
 211     getOrigName (WiredInVal id)         = getOrigName id
 212     getOrigName (ClassOpName _ c op _)  = (fst (getOrigName c), op)
 213     getOrigName other                   = getOrigName (get_nm "getOrigName" other)
 214
 215     getOccurrenceName (Short _ sn)         = getOccurrenceName sn
 216     getOccurrenceName (WiredInTyCon tc)    = getOccurrenceName tc
 217     getOccurrenceName (WiredInVal id)      = getOccurrenceName id
 218     getOccurrenceName (ClassOpName _ _ op _) = op
 219     getOccurrenceName (Unbound s)          =  s _APPEND_ SLIT("<unbound>")
 220     getOccurrenceName other                = getOccurrenceName (get_nm "getOccurrenceName" other)
 221
 222     getInformingModules thing = panic "getInformingModule:Name"
 223
 224     getSrcLoc (Short _ sn)         = getSrcLoc sn
 225     getSrcLoc (WiredInTyCon tc)    = mkBuiltinSrcLoc
 226     getSrcLoc (WiredInVal id)      = mkBuiltinSrcLoc
 227     getSrcLoc (ClassOpName _ c _ _)  = getSrcLoc c
 228     getSrcLoc (Unbound _)          = mkUnknownSrcLoc
 229     getSrcLoc other                = getSrcLoc (get_nm "getSrcLoc" other)
 230
 231     getItsUnique (Short         u _)       = u
 232     getItsUnique (WiredInTyCon  t)         = getItsUnique t
 233     getItsUnique (WiredInVal    i)         = getItsUnique i
 234     getItsUnique (TyConName     u _ _ _ _) = u
 235     getItsUnique (ClassName     u _ _)     = u
 236     getItsUnique (ValName       u _)       = u
 237     getItsUnique (ClassOpName   u _ _ _)   = u
 238
 239     fromPreludeCore (WiredInTyCon _)       = True
 240     fromPreludeCore (WiredInVal _)         = True
 241     fromPreludeCore (ClassOpName _ c _ _)  = fromPreludeCore c
 242     fromPreludeCore other                  = False
 243 \end{code}
 244
 245 A useful utility; most emphatically not for export! (but see
 246 @getNameFullName@...):
 247 \begin{code}
 248 get_nm :: String -> Name -> FullName
 249
 250 get_nm msg (TyConName _ n _ _ _) = n
 251 get_nm msg (ClassName _ n _)     = n
 252 get_nm msg (ValName   _ n)       = n
 253 #ifdef DEBUG
 254 get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
 255 -- If match failure, probably on a ClassOpName or Unbound :-(
 256 #endif
 257 \end{code}
 258
 259 \begin{code}
 260 instance Outputable Name where
 261 #ifdef DEBUG
 262     ppr PprDebug (Short u s)        = pp_debug u s
 263
 264     ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
 265     ppr PprDebug (ClassName u n _)     = pp_debug u n
 266     ppr PprDebug (ValName u n)         = pp_debug u n
 267 #endif
 268     ppr sty (Short u s)           = ppr sty s
 269
 270     ppr sty (WiredInTyCon tc)     = ppr sty tc
 271     ppr sty (WiredInVal   id)     = ppr sty id
 272
 273     ppr sty (TyConName u n a b c) = ppr sty n
 274     ppr sty (ClassName u n c)     = ppr sty n
 275     ppr sty (ValName   u n)       = ppr sty n
 276
 277     ppr sty (ClassOpName u c s i)
 278       = let
 279             ps = ppPStr s
 280         in
 281         case sty of
 282           PprForUser   -> ps
 283           PprInterface -> ps
 284           PprDebug     -> ps
 285           other        -> ppBesides [ps, ppChar '{',
 286                                        ppSep [pprUnique u,
 287                                               ppStr "op", ppInt i,
 288                                               ppStr "cls", ppr sty c],
 289                                        ppChar '}']
 290
 291     ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
 292
 293 pp_debug uniq thing
 294   = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
 295 \end{code}