ghc/compiler/abstractSyn/Name.lhs

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