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(..), NewOrData(..),
  13
  14         isFunTyCon, isPrimTyCon, isBoxedTyCon,
  15         isDataTyCon, isSynTyCon, isNewTyCon,
  16
  17         mkDataTyCon,
  18         mkFunTyCon,
  19         mkPrimTyCon,
  20         mkSpecTyCon,
  21         mkTupleTyCon,
  22
  23         mkSynTyCon,
  24
  25         tyConKind,
  26         tyConUnique,
  27         tyConTyVars,
  28         tyConDataCons,
  29         tyConFamilySize,
  30         tyConDerivings,
  31         tyConArity, synTyConArity,
  32         getSynTyConDefn,
  33
  34         maybeTyConSingleCon,
  35         isEnumerationTyCon,
  36         derivedFor
  37 ) where
  38
  39 CHK_Ubiq()      -- debugging consistency check
  40
  41 import TyLoop           ( Type(..), GenType,
  42                           Class(..), GenClass,
  43                           Id(..), GenId,
  44                           mkTupleCon, dataConSig,
  45                           specMaybeTysSuffix
  46                         )
  47
  48 import TyVar            ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
  49 import Usage            ( GenUsage, Usage(..) )
  50 import Kind             ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
  51
  52 import Maybes
  53 import Name             ( Name, RdrName(..), appendRdr, nameUnique,
  54                           mkTupleTyConName, mkFunTyConName
  55                         )
  56 import Unique           ( Unique, funTyConKey, mkTupleTyConUnique )
  57 import Pretty           ( Pretty(..), PrettyRep )
  58 import SrcLoc           ( SrcLoc, mkBuiltinSrcLoc )
  59 import Util             ( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) )
  60 import {-hide me-}
  61         PprType (pprTyCon)
  62 import {-hide me-}
  63         PprStyle--ToDo:rm
  64 \end{code}
  65
  66 \begin{code}
  67 type Arity = Int
  68
  69 data TyCon
  70   = FunTyCon            -- Kind = Type -> Type -> Type
  71
  72   | DataTyCon   Unique{-TyConKey-}
  73                 Name
  74                 Kind
  75                 [TyVar]
  76                 [(Class,Type)]  -- Its context
  77                 [Id]            -- Its data constructors, with fully polymorphic types
  78                 [Class]         -- Classes which have derived instances
  79                 NewOrData
  80
  81   | TupleTyCon  Unique          -- cached
  82                 Name            -- again, we could do without this, but
  83                                 -- it makes life somewhat easier
  84                 Arity   -- just a special case of DataTyCon
  85                         -- Kind = BoxedTypeKind
  86                         --      -> ... (n times) ...
  87                         --      -> BoxedTypeKind
  88                         --      -> BoxedTypeKind
  89
  90   | PrimTyCon           -- Primitive types; cannot be defined in Haskell
  91         Unique          -- Always unboxed; hence never represented by a closure
  92         Name            -- Often represented by a bit-pattern for the thing
  93         Kind            -- itself (eg Int#), but sometimes by a pointer to
  94
  95   | SpecTyCon           -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
  96         TyCon
  97         [Maybe Type]    -- Specialising types
  98
  99         --      OLD STUFF ABOUT Array types.  Use SpecTyCon instead
 100         -- ([PrimRep] -> PrimRep) -- a heap-allocated object (eg ArrInt#).
 101         -- The primitive types Arr# and StablePtr# have
 102         -- parameters (hence arity /= 0); but the rest don't.
 103         -- Only arrays use the list in a non-trivial way.
 104         -- Length of that list must == arity.
 105
 106   | SynTyCon
 107         Unique
 108         Name
 109         Kind
 110         Arity
 111         [TyVar]         -- Argument type variables
 112         Type            -- Right-hand side, mentioning these type vars.
 113                         -- Acts as a template for the expansion when
 114                         -- the tycon is applied to some types.
 115
 116 data NewOrData
 117   = NewType         -- "newtype Blah ..."
 118   | DataType        -- "data Blah ..."
 119 \end{code}
 120
 121 \begin{code}
 122 mkFunTyCon   = FunTyCon
 123 mkSpecTyCon  = SpecTyCon
 124
 125 mkTupleTyCon arity
 126   = TupleTyCon u n arity
 127   where
 128     n = mkTupleTyConName arity
 129     u = uniqueOf n
 130
 131 mkDataTyCon name
 132   = DataTyCon (nameUnique name) name
 133 mkPrimTyCon name
 134   = PrimTyCon (nameUnique name) name
 135 mkSynTyCon name
 136   = SynTyCon (nameUnique name) name
 137
 138 isFunTyCon FunTyCon = True
 139 isFunTyCon _ = False
 140
 141 isPrimTyCon (PrimTyCon _ _ _) = True
 142 isPrimTyCon _ = False
 143
 144 -- At present there are no unboxed non-primitive types, so
 145 -- isBoxedTyCon is just the negation of isPrimTyCon.
 146 isBoxedTyCon = not . isPrimTyCon
 147
 148 -- isDataTyCon returns False for @newtype@.
 149 -- Not sure about this decision yet.
 150 isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True
 151 isDataTyCon (TupleTyCon _ _ _)                 = True
 152 isDataTyCon other                              = False
 153
 154 isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True
 155 isNewTyCon other                             = False
 156
 157 isSynTyCon (SynTyCon _ _ _ _ _ _) = True
 158 isSynTyCon _                      = False
 159 \end{code}
 160
 161 \begin{code}
 162 -- Special cases to avoid reconstructing lots of kinds
 163 kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
 164 kind2 = mkBoxedTypeKind `mkArrowKind` kind1
 165
 166 tyConKind :: TyCon -> Kind
 167 tyConKind FunTyCon                       = kind2
 168 tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind
 169 tyConKind (PrimTyCon _ _ kind)           = kind
 170 tyConKind (SynTyCon _ _ k _ _ _)         = k
 171
 172 tyConKind (TupleTyCon _ _ n)
 173   = mkArrow n
 174    where
 175     mkArrow 0 = mkBoxedTypeKind
 176     mkArrow 1 = kind1
 177     mkArrow 2 = kind2
 178     mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1)
 179
 180 tyConKind (SpecTyCon tc tys)
 181   = spec (tyConKind tc) tys
 182    where
 183     spec kind []              = kind
 184     spec kind (Just _  : tys) = spec (resultKind kind) tys
 185     spec kind (Nothing : tys) =
 186       argKind kind `mkArrowKind` spec (resultKind kind) tys
 187 \end{code}
 188
 189 \begin{code}
 190 tyConUnique :: TyCon -> Unique
 191 tyConUnique FunTyCon                       = funTyConKey
 192 tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
 193 tyConUnique (TupleTyCon uniq _ _)          = uniq
 194 tyConUnique (PrimTyCon uniq _ _)           = uniq
 195 tyConUnique (SynTyCon uniq _ _ _ _ _)      = uniq
 196 tyConUnique (SpecTyCon _ _ )               = panic "tyConUnique:SpecTyCon"
 197
 198 tyConArity :: TyCon -> Arity
 199 tyConArity FunTyCon                      = 2
 200 tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs
 201 tyConArity (TupleTyCon _ _ arity)        = arity
 202 tyConArity (PrimTyCon _ _ _)             = 0    -- ??
 203 tyConArity (SpecTyCon _ _)               = 0
 204 tyConArity (SynTyCon _ _ _ arity _ _)    = arity
 205
 206 synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon
 207 synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
 208 synTyConArity _                          = Nothing
 209 \end{code}
 210
 211 \begin{code}
 212 tyConTyVars :: TyCon -> [TyVar]
 213 tyConTyVars FunTyCon                      = [alphaTyVar,betaTyVar]
 214 tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
 215 tyConTyVars (TupleTyCon _ _ arity)        = take arity alphaTyVars
 216 tyConTyVars (SynTyCon _ _ _ _ tvs _)      = tvs
 217 tyConTyVars (PrimTyCon _ _ _)             = panic "tyConTyVars:PrimTyCon"
 218 tyConTyVars (SpecTyCon _ _ )              = panic "tyConTyVars:SpecTyCon"
 219 \end{code}
 220
 221 \begin{code}
 222 tyConDataCons :: TyCon -> [Id]
 223 tyConFamilySize  :: TyCon -> Int
 224
 225 tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
 226 tyConDataCons (TupleTyCon _ _ a)                  = [mkTupleCon a]
 227 tyConDataCons other                               = []
 228         -- You may think this last equation should fail,
 229         -- but it's quite convenient to return no constructors for
 230         -- a synonym; see for example the call in TcTyClsDecls.
 231
 232 tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
 233 tyConFamilySize (TupleTyCon _ _ _)                  = 1
 234 #ifdef DEBUG
 235 tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
 236 #endif
 237 \end{code}
 238
 239 \begin{code}
 240 tyConDerivings :: TyCon -> [Class]
 241 tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs
 242 tyConDerivings other                            = []
 243 \end{code}
 244
 245 \begin{code}
 246 getSynTyConDefn :: TyCon -> ([TyVar], Type)
 247 getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
 248 \end{code}
 249
 250 \begin{code}
 251 maybeTyConSingleCon :: TyCon -> Maybe Id
 252
 253 maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (mkTupleCon arity)
 254 maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
 255 maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _) = Nothing
 256 maybeTyConSingleCon (PrimTyCon _ _ _)             = Nothing
 257 maybeTyConSingleCon (SpecTyCon tc tys)            = panic "maybeTyConSingleCon:SpecTyCon"
 258                                                   -- requires DataCons of TyCon
 259
 260 isEnumerationTyCon (TupleTyCon _ _ arity)
 261   = arity == 0
 262 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _)
 263   = not (null data_cons) && all is_nullary data_cons
 264   where
 265     is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) ->
 266                      null arg_tys }
 267 \end{code}
 268
 269 @derivedFor@ reports if we have an {\em obviously}-derived instance
 270 for the given class/tycon.  Of course, you might be deriving something
 271 because it a superclass of some other obviously-derived class --- this
 272 function doesn't deal with that.
 273
 274 ToDo: what about derivings for specialised tycons !!!
 275
 276 \begin{code}
 277 derivedFor :: Class -> TyCon -> Bool
 278 derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _) = isIn "derivedFor" clas derivs
 279 derivedFor clas something_weird                  = False
 280 \end{code}
 281
 282 %************************************************************************
 283 %*                                                                      *
 284 \subsection[TyCon-instances]{Instance declarations for @TyCon@}
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 @TyCon@s are compared by comparing their @Unique@s.
 289
 290 The strictness analyser needs @Ord@. It is a lexicographic order with
 291 the property @(a<=b) || (b<=a)@.
 292
 293 \begin{code}
 294 instance Ord3 TyCon where
 295   cmp FunTyCon                    FunTyCon                    = EQ_
 296   cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b
 297   cmp (SynTyCon a _ _ _ _ _)      (SynTyCon b _ _ _ _ _)      = a `cmp` b
 298   cmp (TupleTyCon _ _ a)          (TupleTyCon _ _ b)          = a `cmp` b
 299   cmp (PrimTyCon a _ _)           (PrimTyCon b _ _)           = a `cmp` b
 300   cmp (SpecTyCon tc1 mtys1)       (SpecTyCon tc2 mtys2)
 301     = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
 302
 303     -- now we *know* the tags are different, so...
 304   cmp other_1 other_2
 305     | tag1 _LT_ tag2 = LT_
 306     | otherwise      = GT_
 307     where
 308       tag1 = tag_TyCon other_1
 309       tag2 = tag_TyCon other_2
 310
 311       tag_TyCon FunTyCon                    = ILIT(1)
 312       tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2)
 313       tag_TyCon (TupleTyCon _ _ _)          = ILIT(3)
 314       tag_TyCon (PrimTyCon  _ _ _)          = ILIT(4)
 315       tag_TyCon (SpecTyCon  _ _)            = ILIT(5)
 316       tag_TyCon (SynTyCon _ _ _ _ _ _)      = ILIT(6)
 317
 318 instance Eq TyCon where
 319     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 320     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 321
 322 instance Ord TyCon where
 323     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 324     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 325     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 326     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 327     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 328
 329 instance Uniquable TyCon where
 330     uniqueOf (DataTyCon  u _ _ _ _ _ _ _) = u
 331     uniqueOf (TupleTyCon u _ _)           = u
 332     uniqueOf (PrimTyCon  u _ _)           = u
 333     uniqueOf (SynTyCon   u _ _ _ _ _)     = u
 334     uniqueOf tc@(SpecTyCon _ _)           = panic "uniqueOf:SpecTyCon"
 335     uniqueOf tc                           = uniqueOf (getName tc)
 336 \end{code}
 337
 338 \begin{code}
 339 instance NamedThing TyCon where
 340     getName (DataTyCon _ n _ _ _ _ _ _) = n
 341     getName (PrimTyCon _ n _)           = n
 342     getName (SpecTyCon tc _)            = getName tc
 343     getName (SynTyCon _ n _ _ _ _)      = n
 344     getName FunTyCon                    = mkFunTyConName
 345     getName (TupleTyCon _ n _)          = n
 346     getName tc                          = panic "TyCon.getName"
 347
 348 {- LATER:
 349     getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in
 350                              (m, n _APPEND_ specMaybeTysSuffix tys)
 351     getName     other_tc           = moduleNamePair (expectJust "tycon1" (getName other_tc))
 352     getName other                            = Nothing
 353 -}
 354 \end{code}