ghc/compiler/types/TyCon.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TyCon]{The @TyCon@ datatype}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TyCon(
  10         TyCon(..),      -- NB: some pals need to see representation
  11
  12         Arity(..), ConsVisible(..), NewOrData(..),
  13
  14         isFunTyCon, isPrimTyCon, isVisibleDataTyCon,
  15
  16         mkDataTyCon,
  17         mkFunTyCon,
  18         mkPrimTyCon,
  19         mkSpecTyCon,
  20         mkTupleTyCon,
  21
  22         mkSynTyCon,
  23
  24         getTyConKind,
  25         getTyConUnique,
  26         getTyConTyVars,
  27         getTyConDataCons,
  28         getTyConDerivings,
  29         getSynTyConArity,
  30
  31         maybeTyConSingleCon,
  32         isEnumerationTyCon,
  33         derivedFor
  34 ) where
  35
  36 CHK_Ubiq()      -- debugging consistency check
  37 import NameLoop -- for paranoia checking
  38
  39 import TyLoop           ( Type(..), GenType,
  40                           Class(..), GenClass,
  41                           Id(..), GenId,
  42                           mkTupleCon, getDataConSig,
  43                           specMaybeTysSuffix
  44                         )
  45
  46 import TyVar            ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
  47 import Usage            ( GenUsage, Usage(..) )
  48 import Kind             ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
  49 import PrelMods         ( pRELUDE_BUILTIN )
  50
  51 import Maybes
  52 import NameTypes        ( FullName )
  53 import Unique           ( Unique, funTyConKey, mkTupleTyConUnique )
  54 import Outputable
  55 import Pretty           ( Pretty(..), PrettyRep )
  56 import PprStyle         ( PprStyle )
  57 import SrcLoc           ( SrcLoc, mkBuiltinSrcLoc )
  58 import Util             ( panic, panic#, nOfThem, isIn, Ord3(..) )
  59 \end{code}
  60
  61 \begin{code}
  62 type Arity = Int
  63
  64 data TyCon
  65   = FunTyCon            -- Kind = Type -> Type -> Type
  66
  67   | DataTyCon   Unique{-TyConKey-}
  68                 Kind
  69                 FullName
  70                 [TyVar]
  71                 [(Class,Type)]  -- Its context
  72                 [Id]            -- Its data constructors, with fully polymorphic types
  73                 [Class]         -- Classes which have derived instances
  74                 ConsVisible
  75                 NewOrData
  76
  77   | TupleTyCon  Arity   -- just a special case of DataTyCon
  78                         -- Kind = BoxedTypeKind
  79                         --      -> ... (n times) ...
  80                         --      -> BoxedTypeKind
  81                         --      -> BoxedTypeKind
  82
  83   | PrimTyCon           -- Primitive types; cannot be defined in Haskell
  84         Unique          -- Always unboxed; hence never represented by a closure
  85         FullName        -- Often represented by a bit-pattern for the thing
  86         Kind            -- itself (eg Int#), but sometimes by a pointer to
  87
  88   | SpecTyCon           -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
  89         TyCon
  90         [Maybe Type]    -- Specialising types
  91
  92         --      OLD STUFF ABOUT Array types.  Use SpecTyCon instead
  93         -- ([PrimRep] -> PrimRep) -- a heap-allocated object (eg ArrInt#).
  94         -- The primitive types Arr# and StablePtr# have
  95         -- parameters (hence arity /= 0); but the rest don't.
  96         -- Only arrays use the list in a non-trivial way.
  97         -- Length of that list must == arity.
  98
  99   | SynTyCon
 100         Unique
 101         FullName
 102         Kind
 103         Arity
 104         [TyVar]         -- Argument type variables
 105         Type            -- Right-hand side, mentioning these type vars.
 106                         -- Acts as a template for the expansion when
 107                         -- the tycon is applied to some types.
 108
 109 data ConsVisible
 110   = ConsVisible     -- whether or not data constructors are visible
 111   | ConsInvisible   -- outside their TyCon's defining module.
 112
 113 data NewOrData
 114   = NewType         -- "newtype Blah ..."
 115   | DataType        -- "data Blah ..."
 116 \end{code}
 117
 118 \begin{code}
 119 mkFunTyCon      = FunTyCon
 120 mkDataTyCon     = DataTyCon
 121 mkTupleTyCon    = TupleTyCon
 122 mkPrimTyCon     = PrimTyCon
 123 mkSpecTyCon     = SpecTyCon
 124 mkSynTyCon      = SynTyCon
 125
 126 isFunTyCon FunTyCon = True
 127 isFunTyCon _ = False
 128
 129 isPrimTyCon (PrimTyCon _ _ _) = True
 130 isPrimTyCon _ = False
 131
 132 isVisibleDataTyCon (DataTyCon _ _ _ _ _ _ _ ConsVisible _) = True
 133 isVisibleDataTyCon _ = False
 134 \end{code}
 135
 136 \begin{code}
 137 -- Special cases to avoid reconstructing lots of kinds
 138 kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
 139 kind2 = mkBoxedTypeKind `mkArrowKind` kind1
 140
 141 getTyConKind :: TyCon -> Kind
 142 getTyConKind FunTyCon                         = kind2
 143 getTyConKind (DataTyCon _ kind _ _ _ _ _ _ _) = kind
 144 getTyConKind (PrimTyCon _ _ kind)             = kind
 145
 146 getTyConKind (SpecTyCon tc tys)
 147   = spec (getTyConKind tc) tys
 148    where
 149     spec kind []              = kind
 150     spec kind (Just _  : tys) = spec (resultKind kind) tys
 151     spec kind (Nothing : tys) =
 152       argKind kind `mkArrowKind` spec (resultKind kind) tys
 153
 154 getTyConKind (TupleTyCon n)
 155   = mkArrow n
 156    where
 157     mkArrow 0 = mkBoxedTypeKind
 158     mkArrow 1 = kind1
 159     mkArrow 2 = kind2
 160     mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1)
 161 \end{code}
 162
 163 \begin{code}
 164 getTyConUnique :: TyCon -> Unique
 165 getTyConUnique FunTyCon                         = funTyConKey
 166 getTyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _) = uniq
 167 getTyConUnique (TupleTyCon a)                   = mkTupleTyConUnique a
 168 getTyConUnique (PrimTyCon uniq _ _)             = uniq
 169 getTyConUnique (SynTyCon uniq _ _ _ _ _)        = uniq
 170 getTyConUnique (SpecTyCon _ _ )                 = panic "getTyConUnique:SpecTyCon"
 171 \end{code}
 172
 173 \begin{code}
 174 getTyConTyVars :: TyCon -> [TyVar]
 175 getTyConTyVars FunTyCon                        = [alphaTyVar,betaTyVar]
 176 getTyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _) = tvs
 177 getTyConTyVars (TupleTyCon arity)              = take arity alphaTyVars
 178 getTyConTyVars (SynTyCon _ _ _ _ tvs _)        = tvs
 179 getTyConTyVars (PrimTyCon _ _ _)               = panic "getTyConTyVars:PrimTyCon"
 180 getTyConTyVars (SpecTyCon _ _ )                = panic "getTyConTyVars:SpecTyCon"
 181 \end{code}
 182
 183 \begin{code}
 184 getTyConDataCons :: TyCon -> [Id]
 185 getTyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _) = data_cons
 186 getTyConDataCons (TupleTyCon a)                        = [mkTupleCon a]
 187 \end{code}
 188
 189 \begin{code}
 190 getTyConDerivings :: TyCon -> [Class]
 191 getTyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _) = derivs
 192 \end{code}
 193
 194 \begin{code}
 195 getSynTyConArity :: TyCon -> Maybe Arity
 196 getSynTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
 197 getSynTyConArity other                      = Nothing
 198 \end{code}
 199
 200 \begin{code}
 201 maybeTyConSingleCon :: TyCon -> Maybe Id
 202 maybeTyConSingleCon (TupleTyCon arity)               = Just (mkTupleCon arity)
 203 maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _)  = Just c
 204 maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _ _)  = Nothing
 205 maybeTyConSingleCon (PrimTyCon _ _ _)                = Nothing
 206 maybeTyConSingleCon (SpecTyCon tc tys)               = panic "maybeTyConSingleCon:SpecTyCon"
 207                                                      -- requires DataCons of TyCon
 208
 209 isEnumerationTyCon (TupleTyCon arity)
 210   = arity == 0
 211 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _ _)
 212   = not (null data_cons) && all is_nullary data_cons
 213   where
 214     is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) ->
 215                      null arg_tys }
 216 \end{code}
 217
 218 @derivedFor@ reports if we have an {\em obviously}-derived instance
 219 for the given class/tycon.  Of course, you might be deriving something
 220 because it a superclass of some other obviously-derived class --- this
 221 function doesn't deal with that.
 222
 223 ToDo: what about derivings for specialised tycons !!!
 224
 225 \begin{code}
 226 derivedFor :: Class -> TyCon -> Bool
 227 derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _ _) = isIn "derivedFor" clas derivs
 228 derivedFor clas something_weird                    = False
 229 \end{code}
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection[TyCon-instances]{Instance declarations for @TyCon@}
 234 %*                                                                      *
 235 %************************************************************************
 236
 237 @TyCon@s are compared by comparing their @Unique@s.
 238
 239 The strictness analyser needs @Ord@. It is a lexicographic order with
 240 the property @(a<=b) || (b<=a)@.
 241
 242 \begin{code}
 243 instance Ord3 TyCon where
 244   cmp FunTyCon                      FunTyCon                      = EQ_
 245   cmp (DataTyCon a _ _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _ _) = a `cmp` b
 246   cmp (SynTyCon a _ _ _ _ _)        (SynTyCon b _ _ _ _ _)        = a `cmp` b
 247   cmp (TupleTyCon a)                (TupleTyCon b)                = a `cmp` b
 248   cmp (PrimTyCon a _ _)             (PrimTyCon b _ _)             = a `cmp` b
 249   cmp (SpecTyCon tc1 mtys1)         (SpecTyCon tc2 mtys2)
 250     = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
 251
 252     -- now we *know* the tags are different, so...
 253   cmp other_1 other_2
 254     | tag1 _LT_ tag2 = LT_
 255     | otherwise      = GT_
 256     where
 257       tag1 = tag_TyCon other_1
 258       tag2 = tag_TyCon other_2
 259       tag_TyCon FunTyCon                      = ILIT(1)
 260       tag_TyCon (DataTyCon _ _ _ _ _ _ _ _ _) = ILIT(2)
 261       tag_TyCon (TupleTyCon _)                = ILIT(3)
 262       tag_TyCon (PrimTyCon  _ _ _)            = ILIT(4)
 263       tag_TyCon (SpecTyCon  _ _)              = ILIT(5)
 264
 265 instance Eq TyCon where
 266     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 267     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 268
 269 instance Ord TyCon where
 270     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 271     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 272     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 273     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 274     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 275 \end{code}
 276
 277 \begin{code}
 278 instance NamedThing TyCon where
 279     getExportFlag tc = case get_name tc of
 280                          Nothing   -> NotExported
 281                          Just name -> getExportFlag name
 282
 283
 284     isLocallyDefined tc = case get_name tc of
 285                             Nothing   -> False
 286                             Just name -> isLocallyDefined name
 287
 288     getOrigName FunTyCon                = (pRELUDE_BUILTIN, SLIT("(->)"))
 289     getOrigName (TupleTyCon a)          = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
 290     getOrigName (SpecTyCon tc tys)      = let (m,n) = getOrigName tc in
 291                                           (m, n _APPEND_ specMaybeTysSuffix tys)
 292     getOrigName other_tc                = getOrigName (expectJust "tycon1" (get_name other_tc))
 293
 294     getOccurrenceName  FunTyCon         = SLIT("(->)")
 295     getOccurrenceName (TupleTyCon 0)    = SLIT("()")
 296     getOccurrenceName (TupleTyCon a)    = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
 297     getOccurrenceName (SpecTyCon tc tys)= getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys
 298     getOccurrenceName other_tc          = getOccurrenceName (expectJust "tycon2" (get_name other_tc))
 299
 300     getInformingModules tc = case get_name tc of
 301                                 Nothing   -> panic "getInformingModule:TyCon"
 302                                 Just name -> getInformingModules name
 303
 304     getSrcLoc tc = case get_name tc of
 305                      Nothing   -> mkBuiltinSrcLoc
 306                      Just name -> getSrcLoc name
 307
 308     getItsUnique tycon = getTyConUnique tycon
 309
 310     fromPreludeCore tc = case get_name tc of
 311                            Nothing   -> True
 312                            Just name -> fromPreludeCore name
 313 \end{code}
 314
 315 Emphatically un-exported:
 316
 317 \begin{code}
 318 get_name (DataTyCon _ _ n _ _ _ _ _ _) = Just n
 319 get_name (PrimTyCon _ n _)             = Just n
 320 get_name (SpecTyCon tc _)              = get_name tc
 321 get_name (SynTyCon _ n _ _ _ _)        = Just n
 322 get_name other                         = Nothing
 323 \end{code}
 324