ghc/compiler/types/Type.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module Type (
   5         GenType(..), SYN_IE(Type), SYN_IE(TauType),
   6         mkTyVarTy, mkTyVarTys,
   7         getTyVar, getTyVar_maybe, isTyVarTy,
   8         mkAppTy, mkAppTys, splitAppTy, splitAppTys,
   9         mkFunTy, mkFunTys,
  10         splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking,
  11         getFunTy_maybe, getFunTyExpandingDicts_maybe,
  12         mkTyConTy, getTyCon_maybe, applyTyCon,
  13         mkSynTy,
  14         mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy,
  15         mkForAllUsageTy, getForAllUsageTy,
  16         applyTy,
  17 #ifdef DEBUG
  18         expandTy, -- only let out for debugging (ToDo: rm?)
  19 #endif
  20         isPrimType, isUnboxedType, typePrimRep,
  21
  22         SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
  23         mkDictTy,
  24         mkRhoTy, splitRhoTy, mkTheta, isDictTy,
  25         mkSigmaTy, splitSigmaTy,
  26
  27         maybeAppTyCon, getAppTyCon,
  28         maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon,
  29         maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
  30         getAppDataTyConExpandingDicts,  getAppSpecDataTyConExpandingDicts,
  31         maybeBoxedPrimType,
  32
  33         matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
  34
  35         instantiateTy, instantiateTauTy, instantiateUsage,
  36         applyTypeEnvToTy,
  37
  38         isTauTy,
  39
  40         tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
  41         showTypeCategory
  42     ) where
  43
  44 IMP_Ubiq()
  45 --IMPORT_DELOOPER(IdLoop)        -- for paranoia checking
  46 IMPORT_DELOOPER(TyLoop)
  47 --IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
  48
  49 -- friends:
  50 import Class    ( classSig, classOpLocalType, GenClass{-instances-} )
  51 import Kind     ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
  52 import TyCon    ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
  53                   isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
  54                   tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
  55 import TyVar    ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
  56                   emptyTyVarSet, unionTyVarSets, minusTyVarSet,
  57                   unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
  58                   addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
  59 import Usage    ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
  60                   nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
  61                   eqUsage )
  62
  63 import Name     ( NamedThing(..),
  64                   NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
  65                 )
  66
  67 -- others
  68 import Maybes   ( maybeToBool, assocMaybe )
  69 import PrimRep  ( PrimRep(..) )
  70 import Unique   -- quite a few *Keys
  71 import Util     ( thenCmp, zipEqual, assoc,
  72                   panic, panic#, assertPanic, pprPanic,
  73                   Ord3(..){-instances-}
  74                 )
  75 -- ToDo:rm all these
  76 --import        {-mumble-}
  77 --      Pretty
  78 --import  {-mumble-}
  79 --      PprStyle
  80 --import        {-mumble-}
  81 --      PprType --(pprType )
  82 --import  {-mumble-}
  83 --      UniqFM (ufmToList )
  84 --import {-mumble-}
  85 --      Outputable
  86 --import PprEnv
  87 \end{code}
  88
  89 Data types
  90 ~~~~~~~~~~
  91
  92 \begin{code}
  93 type Type  = GenType TyVar UVar -- Used after typechecker
  94
  95 data GenType tyvar uvar -- Parameterised over type and usage variables
  96   = TyVarTy tyvar
  97
  98   | AppTy
  99         (GenType tyvar uvar)
 100         (GenType tyvar uvar)
 101
 102   | TyConTy     -- Constants of a specified kind
 103         TyCon   -- Must *not* be a SynTyCon
 104         (GenUsage uvar) -- Usage gives uvar of the full application,
 105                         -- iff the full application is of kind Type
 106                         -- c.f. the Usage field in TyVars
 107
 108   | SynTy       -- Synonyms must be saturated, and contain their expansion
 109         TyCon   -- Must be a SynTyCon
 110         [GenType tyvar uvar]
 111         (GenType tyvar uvar)    -- Expansion!
 112
 113   | ForAllTy
 114         tyvar
 115         (GenType tyvar uvar)    -- TypeKind
 116
 117   | ForAllUsageTy
 118         uvar                    -- Quantify over this
 119         [uvar]                  -- Bounds; the quantified var must be
 120                                 -- less than or equal to all these
 121         (GenType tyvar uvar)
 122
 123         -- Two special cases that save a *lot* of administrative
 124         -- overhead:
 125
 126   | FunTy                       -- BoxedTypeKind
 127         (GenType tyvar uvar)    -- Both args are of TypeKind
 128         (GenType tyvar uvar)
 129         (GenUsage uvar)
 130
 131   | DictTy                      -- TypeKind
 132         Class                   -- Class
 133         (GenType tyvar uvar)    -- Arg has kind TypeKind
 134         (GenUsage uvar)
 135 \end{code}
 136
 137 \begin{code}
 138 type RhoType   = Type
 139 type TauType   = Type
 140 type ThetaType = [(Class, Type)]
 141 type SigmaType = Type
 142 \end{code}
 143
 144
 145 Expand abbreviations
 146 ~~~~~~~~~~~~~~~~~~~~
 147 Removes just the top level of any abbreviations.
 148
 149 \begin{code}
 150 expandTy :: Type -> Type        -- Restricted to Type due to Dict expansion
 151
 152 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
 153 expandTy (SynTy _  _  t) = expandTy t
 154 expandTy (DictTy clas ty u)
 155   = case all_arg_tys of
 156
 157         []       -> voidTy              -- Empty dictionary represented by Void
 158
 159         [arg_ty] -> expandTy arg_ty     -- just the <whatever> itself
 160
 161                 -- The extra expandTy is to make sure that
 162                 -- the result isn't still a dict, which it might be
 163                 -- if the original guy was a dict with one superdict and
 164                 -- no methods!
 165
 166         other -> ASSERT(not (null all_arg_tys))
 167                 foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys
 168
 169                 -- A tuple of 'em
 170                 -- Note: length of all_arg_tys can be 0 if the class is
 171                 --       CCallable, CReturnable (and anything else
 172                 --       *really weird* that the user writes).
 173   where
 174     (tyvar, super_classes, ops) = classSig clas
 175     super_dict_tys = map mk_super_ty super_classes
 176     class_op_tys   = map mk_op_ty ops
 177     all_arg_tys    = super_dict_tys ++ class_op_tys
 178     mk_super_ty sc = DictTy sc ty usageOmega
 179     mk_op_ty    op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
 180
 181 expandTy ty = ty
 182 \end{code}
 183
 184 Simple construction and analysis functions
 185 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 186 \begin{code}
 187 mkTyVarTy  :: t   -> GenType t u
 188 mkTyVarTys :: [t] -> [GenType t y]
 189 mkTyVarTy  = TyVarTy
 190 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 191
 192 getTyVar :: String -> GenType t u -> t
 193 getTyVar msg (TyVarTy tv)   = tv
 194 getTyVar msg (SynTy _ _ t)  = getTyVar msg t
 195 getTyVar msg other          = panic ("getTyVar: " ++ msg)
 196
 197 getTyVar_maybe :: GenType t u -> Maybe t
 198 getTyVar_maybe (TyVarTy tv)  = Just tv
 199 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
 200 getTyVar_maybe other         = Nothing
 201
 202 isTyVarTy :: GenType t u -> Bool
 203 isTyVarTy (TyVarTy tv)  = True
 204 isTyVarTy (SynTy _ _ t) = isTyVarTy t
 205 isTyVarTy other = False
 206 \end{code}
 207
 208 \begin{code}
 209 mkAppTy = AppTy
 210
 211 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
 212 mkAppTys t ts = foldl AppTy t ts
 213
 214 splitAppTy :: GenType t u -> (GenType t u, GenType t u)
 215 splitAppTy (AppTy t arg) = (t,arg)
 216 splitAppTy (SynTy _ _ t) = splitAppTy t
 217 splitAppTy other         = panic "splitAppTy"
 218
 219 splitAppTys :: GenType t u -> (GenType t u, [GenType t u])
 220 splitAppTys t = go t []
 221   where
 222     go (AppTy t arg)     ts = go t (arg:ts)
 223     go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
 224     go (SynTy _ _ t)     ts = go t ts
 225     go t                 ts = (t,ts)
 226 \end{code}
 227
 228 \begin{code}
 229 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
 230 mkFunTy arg res = FunTy arg res usageOmega
 231
 232 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
 233 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
 234
 235   -- getFunTy_maybe and splitFunTy *must* have the general type given, which
 236   -- means they *can't* do the DictTy jiggery-pokery that
 237   -- *is* sometimes required.  Hence we also have the ExpandingDicts variants
 238   -- The relationship between these
 239   -- two functions is like that between eqTy and eqSimpleTy.
 240   -- ToDo: NUKE when we do dicts via newtype
 241
 242 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
 243 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
 244 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
 245                  | isFunTyCon tycon = Just (arg, res)
 246 getFunTy_maybe (SynTy _ _ t)        = getFunTy_maybe t
 247 getFunTy_maybe other                = Nothing
 248
 249 getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
 250                              -> Type
 251                              -> Maybe (Type, Type)
 252
 253 getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result)
 254 getFunTyExpandingDicts_maybe peek
 255         (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
 256 getFunTyExpandingDicts_maybe peek (SynTy _ _ t)     = getFunTyExpandingDicts_maybe peek t
 257 getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty)
 258
 259 getFunTyExpandingDicts_maybe True (ForAllTy _ ty)   = getFunTyExpandingDicts_maybe True ty
 260         -- Ignore for-alls when peeking.  See note with defn of getFunTyExpandingDictsAndPeeking
 261
 262 getFunTyExpandingDicts_maybe peek other
 263   | not peek = Nothing -- that was easy
 264   | otherwise
 265   = case (maybeAppTyCon other) of
 266       Nothing -> Nothing
 267       Just (tc, arg_tys)
 268         | not (isNewTyCon tc) -> Nothing
 269         | otherwise ->
 270           let
 271              [newtype_con] = tyConDataCons tc -- there must be exactly one...
 272              [inside_ty]   = dataConArgTys newtype_con arg_tys
 273           in
 274           getFunTyExpandingDicts_maybe peek inside_ty
 275
 276 splitFunTy                         :: GenType t u -> ([GenType t u], GenType t u)
 277 splitFunTyExpandingDicts           :: Type        -> ([Type], Type)
 278 splitFunTyExpandingDictsAndPeeking :: Type        -> ([Type], Type)
 279
 280 splitFunTy                         t = split_fun_ty getFunTy_maybe                       t
 281 splitFunTyExpandingDicts           t = split_fun_ty (getFunTyExpandingDicts_maybe False) t
 282 splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True)  t
 283         -- This "peeking" stuff is used only by the code generator.
 284         -- It's interested in the representation type of things, ignoring:
 285         --      newtype
 286         --      foralls
 287         --      expanding dictionary reps
 288         --      synonyms, of course
 289
 290 split_fun_ty get t = go t []
 291   where
 292     go t ts = case (get t) of
 293                 Just (arg,res) -> go res (arg:ts)
 294                 Nothing        -> (reverse ts, t)
 295 \end{code}
 296
 297 \begin{code}
 298 -- NB applyTyCon puts in usageOmega, for now at least
 299 mkTyConTy tycon
 300   = ASSERT(not (isSynTyCon tycon))
 301     TyConTy tycon usageOmega
 302
 303 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
 304 applyTyCon tycon tys
 305   = ASSERT (not (isSynTyCon tycon))
 306     --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
 307     foldl AppTy (TyConTy tycon usageOmega) tys
 308
 309 getTyCon_maybe               :: GenType t u -> Maybe TyCon
 310 --getTyConExpandingDicts_maybe :: Type        -> Maybe TyCon
 311
 312 getTyCon_maybe (TyConTy tycon _) = Just tycon
 313 getTyCon_maybe (SynTy _ _ t)     = getTyCon_maybe t
 314 getTyCon_maybe other_ty          = Nothing
 315
 316 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
 317 --getTyConExpandingDicts_maybe (SynTy _ _ t)     = getTyConExpandingDicts_maybe t
 318 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
 319 --getTyConExpandingDicts_maybe other_ty        = Nothing
 320 \end{code}
 321
 322 \begin{code}
 323 mkSynTy syn_tycon tys
 324   = ASSERT(isSynTyCon syn_tycon)
 325     SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
 326   where
 327     (tyvars, body) = getSynTyConDefn syn_tycon
 328 \end{code}
 329
 330 Tau stuff
 331 ~~~~~~~~~
 332 \begin{code}
 333 isTauTy :: GenType t u -> Bool
 334 isTauTy (TyVarTy v)        = True
 335 isTauTy (TyConTy _ _)      = True
 336 isTauTy (AppTy a b)        = isTauTy a && isTauTy b
 337 isTauTy (FunTy a b _)      = isTauTy a && isTauTy b
 338 isTauTy (SynTy _ _ ty)     = isTauTy ty
 339 isTauTy other              = False
 340 \end{code}
 341
 342 Rho stuff
 343 ~~~~~~~~~
 344 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
 345
 346 \begin{code}
 347 mkDictTy :: Class -> GenType t u -> GenType t u
 348 mkDictTy clas ty = DictTy clas ty usageOmega
 349
 350 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
 351 mkRhoTy theta ty =
 352   foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
 353
 354 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
 355 splitRhoTy t =
 356   go t []
 357  where
 358   go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
 359   go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
 360         | isFunTyCon tycon
 361         = go r ((c,t):ts)
 362   go (SynTy _ _ t) ts = go t ts
 363   go t ts = (reverse ts, t)
 364
 365
 366 mkTheta :: [Type] -> ThetaType
 367     -- recover a ThetaType from the types of some dictionaries
 368 mkTheta dict_tys
 369   = map cvt dict_tys
 370   where
 371     cvt (DictTy clas ty _) = (clas, ty)
 372     cvt other              = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
 373
 374 isDictTy (DictTy _ _ _) = True
 375 isDictTy (SynTy  _ _ t) = isDictTy t
 376 isDictTy _              = False
 377 \end{code}
 378
 379
 380 Forall stuff
 381 ~~~~~~~~~~~~
 382 \begin{code}
 383 mkForAllTy = ForAllTy
 384
 385 mkForAllTys :: [t] -> GenType t u -> GenType t u
 386 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 387
 388 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
 389 getForAllTy_maybe (SynTy _ _ t)      = getForAllTy_maybe t
 390 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 391 getForAllTy_maybe _                  = Nothing
 392
 393 getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
 394 getForAllTyExpandingDicts_maybe (SynTy _ _ t)      = getForAllTyExpandingDicts_maybe t
 395 getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 396 getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _)  = getForAllTyExpandingDicts_maybe (expandTy ty)
 397 getForAllTyExpandingDicts_maybe _                  = Nothing
 398
 399 splitForAllTy :: GenType t u-> ([t], GenType t u)
 400 splitForAllTy t = go t []
 401                where
 402                     go (ForAllTy tv t) tvs = go t (tv:tvs)
 403                     go (SynTy _ _ t)   tvs = go t tvs
 404                     go t               tvs = (reverse tvs, t)
 405 \end{code}
 406
 407 \begin{code}
 408 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
 409 mkForAllUsageTy = ForAllUsageTy
 410
 411 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
 412 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
 413 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
 414 getForAllUsageTy _ = Nothing
 415 \end{code}
 416
 417 Applied tycons (includes FunTyCons)
 418 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 419 \begin{code}
 420 maybeAppTyCon
 421         :: GenType tyvar uvar
 422         -> Maybe (TyCon,                -- the type constructor
 423                   [GenType tyvar uvar]) -- types to which it is applied
 424
 425 maybeAppTyCon ty
 426   = case (getTyCon_maybe app_ty) of
 427         Nothing    -> Nothing
 428         Just tycon -> Just (tycon, arg_tys)
 429   where
 430     (app_ty, arg_tys) = splitAppTys ty
 431
 432
 433 getAppTyCon
 434         :: GenType tyvar uvar
 435         -> (TyCon,                      -- the type constructor
 436             [GenType tyvar uvar])       -- types to which it is applied
 437
 438 getAppTyCon ty
 439   = case maybeAppTyCon ty of
 440       Just stuff -> stuff
 441 #ifdef DEBUG
 442       Nothing    -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
 443 #endif
 444 \end{code}
 445
 446 Applied data tycons (give back constrs)
 447 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 448 \begin{code}
 449 maybeAppDataTyCon
 450         :: GenType (GenTyVar any) uvar
 451         -> Maybe (TyCon,                -- the type constructor
 452                   [GenType (GenTyVar any) uvar],        -- types to which it is applied
 453                   [Id])                 -- its family of data-constructors
 454 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
 455         :: Type -> Maybe (TyCon, [Type], [Id])
 456
 457 maybeAppDataTyCon                   ty = maybe_app_data_tycon (\x->x) ty
 458 maybeAppDataTyConExpandingDicts     ty = maybe_app_data_tycon expandTy ty
 459 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
 460
 461
 462 maybe_app_data_tycon expand ty
 463   = let
 464         expanded_ty       = expand ty
 465         (app_ty, arg_tys) = splitAppTys expanded_ty
 466     in
 467     case (getTyCon_maybe app_ty) of
 468         Just tycon |  --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
 469                       isDataTyCon tycon &&
 470                       notArrowKind (typeKind expanded_ty)
 471                         -- Must be saturated for ty to be a data type
 472                    -> Just (tycon, arg_tys, tyConDataCons tycon)
 473
 474         other      -> Nothing
 475
 476 getAppDataTyCon, getAppSpecDataTyCon
 477         :: GenType (GenTyVar any) uvar
 478         -> (TyCon,                      -- the type constructor
 479             [GenType (GenTyVar any) uvar],      -- types to which it is applied
 480             [Id])                       -- its family of data-constructors
 481 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
 482         :: Type -> (TyCon, [Type], [Id])
 483
 484 getAppDataTyCon               ty = get_app_data_tycon maybeAppDataTyCon ty
 485 getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
 486                                    get_app_data_tycon maybeAppDataTyConExpandingDicts ty
 487
 488 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
 489 getAppSpecDataTyCon               = getAppDataTyCon
 490 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
 491
 492 get_app_data_tycon maybe ty
 493   = case maybe ty of
 494       Just stuff -> stuff
 495 #ifdef DEBUG
 496       Nothing    -> panic "Type.getAppDataTyCon"--  (pprGenType PprShowAll ty)
 497 #endif
 498
 499
 500 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
 501
 502 maybeBoxedPrimType ty
 503   = case (maybeAppDataTyCon ty) of              -- Data type,
 504       Just (tycon, tys_applied, [data_con])     -- with exactly one constructor
 505         -> case (dataConArgTys data_con tys_applied) of
 506              [data_con_arg_ty]                  -- Applied to exactly one type,
 507                 | isPrimType data_con_arg_ty    -- which is primitive
 508                 -> Just (data_con, data_con_arg_ty)
 509              other_cases -> Nothing
 510       other_cases -> Nothing
 511 \end{code}
 512
 513 \begin{code}
 514 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
 515 splitSigmaTy ty =
 516   (tyvars, theta, tau)
 517  where
 518   (tyvars,rho) = splitForAllTy ty
 519   (theta,tau)  = splitRhoTy rho
 520
 521 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 522 \end{code}
 523
 524
 525 Finding the kind of a type
 526 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 527 \begin{code}
 528 typeKind :: GenType (GenTyVar any) u -> Kind
 529
 530 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 531 typeKind (TyConTy tycon usage)  = tyConKind tycon
 532 typeKind (SynTy _ _ ty)         = typeKind ty
 533 typeKind (FunTy fun arg _)      = mkBoxedTypeKind
 534 typeKind (DictTy clas arg _)    = mkBoxedTypeKind
 535 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 536 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 537 typeKind (ForAllUsageTy _ _ _)  = mkBoxedTypeKind
 538 \end{code}
 539
 540
 541 Free variables of a type
 542 ~~~~~~~~~~~~~~~~~~~~~~~~
 543 \begin{code}
 544 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
 545
 546 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 547 tyVarsOfType (TyConTy tycon usage)      = emptyTyVarSet
 548 tyVarsOfType (SynTy _ tys ty)           = tyVarsOfTypes tys
 549 tyVarsOfType (FunTy arg res _)          = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 550 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 551 tyVarsOfType (DictTy clas ty _)         = tyVarsOfType ty
 552 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 553 tyVarsOfType (ForAllUsageTy _ _ ty)     = tyVarsOfType ty
 554
 555 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
 556 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 557
 558 -- Find the free names of a type, including the type constructors and classes it mentions
 559 namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet
 560 namesOfType (TyVarTy tv)                = unitNameSet (getName tv)
 561 namesOfType (TyConTy tycon usage)       = unitNameSet (getName tycon)
 562 namesOfType (SynTy tycon tys ty)        = unitNameSet (getName tycon) `unionNameSets`
 563                                           namesOfType ty
 564 namesOfType (FunTy arg res _)           = namesOfType arg `unionNameSets` namesOfType res
 565 namesOfType (AppTy fun arg)             = namesOfType fun `unionNameSets` namesOfType arg
 566 namesOfType (DictTy clas ty _)          = unitNameSet (getName clas) `unionNameSets`
 567                                           namesOfType ty
 568 namesOfType (ForAllTy tyvar ty)         = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
 569 namesOfType (ForAllUsageTy _ _ ty)      = panic "forall usage"
 570 \end{code}
 571
 572
 573 Instantiating a type
 574 ~~~~~~~~~~~~~~~~~~~~
 575 \begin{code}
 576 -- applyTy :: GenType (GenTyVar flexi) uvar
 577 --      -> GenType (GenTyVar flexi) uvar
 578 --      -> GenType (GenTyVar flexi) uvar
 579
 580 applyTy :: Type -> Type -> Type
 581
 582 applyTy (SynTy _ _ fun)   arg = applyTy fun arg
 583 applyTy (ForAllTy tv ty)  arg = instantiateTy [(tv,arg)] ty
 584 applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg
 585 applyTy other             arg = panic "applyTy"
 586 \end{code}
 587
 588 \begin{code}
 589 instantiateTy   :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
 590                 -> GenType (GenTyVar flexi) uvar
 591                 -> GenType (GenTyVar flexi) uvar
 592
 593 instantiateTauTy :: Eq tv =>
 594                    [(tv, GenType tv' u)]
 595                 -> GenType tv u
 596                 -> GenType tv' u
 597
 598 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
 599
 600 -- instantiateTauTy works only (a) on types with no ForAlls,
 601 --      and when               (b) all the type variables are being instantiated
 602 -- In return it is more polymorphic than instantiateTy
 603
 604 instant_help ty lookup_tv deflt_tv choose_tycon
 605                 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 606   = go ty
 607   where
 608     go (TyVarTy tv)                = case (lookup_tv tv) of
 609                                        Nothing -> deflt_tv tv
 610                                        Just ty -> ty
 611     go ty@(TyConTy tycon usage)    = choose_tycon ty tycon usage
 612     go (SynTy tycon tys ty)        = SynTy tycon (map go tys) (go ty)
 613     go (FunTy arg res usage)       = FunTy (go arg) (go res) usage
 614     go (AppTy fun arg)             = AppTy (go fun) (go arg)
 615     go (DictTy clas ty usage)      = DictTy clas (go ty) usage
 616     go (ForAllUsageTy uvar bds ty) = if_usage $
 617                                      ForAllUsageTy uvar bds (go ty)
 618     go (ForAllTy tv ty)            = if_forall $
 619                                      (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
 620                                         trace "instantiateTy: unexpected forall hit"
 621                                      else
 622                                         \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
 623
 624 instantiateTy tenv ty
 625   = instant_help ty lookup_tv deflt_tv choose_tycon
 626                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 627   where
 628     lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
 629                      []   -> Nothing
 630                      [ty] -> Just ty
 631                      _    -> panic "instantiateTy:lookup_tv"
 632
 633     deflt_tv tv = TyVarTy tv
 634     choose_tycon ty _ _ = ty
 635     if_usage ty = ty
 636     if_forall ty = ty
 637     bound_forall_tv_BAD = True
 638     deflt_forall_tv tv  = tv
 639
 640 instantiateTauTy tenv ty
 641   = instant_help ty lookup_tv deflt_tv choose_tycon
 642                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 643   where
 644     lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
 645                      []   -> Nothing
 646                      [ty] -> Just ty
 647                      _    -> panic "instantiateTauTy:lookup_tv"
 648
 649     deflt_tv tv = panic "instantiateTauTy"
 650     choose_tycon _ tycon usage = TyConTy tycon usage
 651     if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
 652     if_forall ty = panic "instantiateTauTy:ForAllTy"
 653     bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
 654     deflt_forall_tv tv  = panic "instantiateTauTy:deflt_forall_tv"
 655
 656
 657 -- applyTypeEnv applies a type environment to a type.
 658 -- It can handle shadowing; for example:
 659 --      f = /\ t1 t2 -> \ d ->
 660 --         letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
 661 --         in f' t1
 662 -- Here, when we clone t1 to t1', say, we'll come across shadowing
 663 -- when applying the clone environment to the type of f'.
 664 --
 665 -- As a sanity check, we should also check that name capture
 666 -- doesn't occur, but that means keeping track of the free variables of the
 667 -- range of the TyVarEnv, which I don't do just yet.
 668 --
 669 -- We don't use instant_help because we need to carry in the environment
 670
 671 applyTypeEnvToTy tenv ty
 672   = go tenv ty
 673   where
 674     go tenv ty@(TyVarTy tv)             = case (lookupTyVarEnv tenv tv) of
 675                                              Nothing -> ty
 676                                              Just ty -> ty
 677     go tenv ty@(TyConTy tycon usage)    = ty
 678     go tenv (SynTy tycon tys ty)        = SynTy tycon (map (go tenv) tys) (go tenv ty)
 679     go tenv (FunTy arg res usage)       = FunTy (go tenv arg) (go tenv res) usage
 680     go tenv (AppTy fun arg)             = AppTy (go tenv fun) (go tenv arg)
 681     go tenv (DictTy clas ty usage)      = DictTy clas (go tenv ty) usage
 682     go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
 683     go tenv (ForAllTy tv ty)            = ForAllTy tv (go tenv' ty)
 684                                         where
 685                                           tenv' = case lookupTyVarEnv tenv tv of
 686                                                     Nothing -> tenv
 687                                                     Just _  -> delFromTyVarEnv tenv tv
 688 \end{code}
 689
 690 \begin{code}
 691 instantiateUsage
 692         :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
 693
 694 instantiateUsage = panic "instantiateUsage: not implemented"
 695 \end{code}
 696
 697
 698 At present there are no unboxed non-primitive types, so
 699 isUnboxedType is the same as isPrimType.
 700
 701 We're a bit cavalier about finding out whether something is
 702 primitive/unboxed or not.  Rather than deal with the type
 703 arguemnts we just zoom into the function part of the type.
 704 That is, given (T a) we just recurse into the "T" part,
 705 ignoring "a".
 706
 707 \begin{code}
 708 isPrimType, isUnboxedType :: Type -> Bool
 709
 710 isPrimType (AppTy ty _)      = isPrimType ty
 711 isPrimType (SynTy _ _ ty)    = isPrimType ty
 712 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
 713                                   Just (tyvars, ty) -> isPrimType ty
 714                                   Nothing           -> isPrimTyCon tycon
 715
 716 isPrimType _                 = False
 717
 718 isUnboxedType = isPrimType
 719 \end{code}
 720
 721 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
 722 \begin{code}
 723 typePrimRep :: Type -> PrimRep
 724
 725 typePrimRep (SynTy _ _ ty)  = typePrimRep ty
 726 typePrimRep (AppTy ty _)    = typePrimRep ty
 727 typePrimRep (TyConTy tc _)
 728   | isPrimTyCon tc          = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
 729                                    Just xx -> xx
 730                                    Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
 731
 732   | otherwise               = case maybeNewTyCon tc of
 733                                   Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
 734                                   _ -> PtrRep   -- Default
 735
 736 typePrimRep _               = PtrRep -- the "default"
 737
 738 tc_primrep_list
 739   = [(addrPrimTyConKey,             AddrRep)
 740     ,(arrayPrimTyConKey,            ArrayRep)
 741     ,(byteArrayPrimTyConKey,        ByteArrayRep)
 742     ,(charPrimTyConKey,             CharRep)
 743     ,(doublePrimTyConKey,           DoubleRep)
 744     ,(floatPrimTyConKey,            FloatRep)
 745     ,(foreignObjPrimTyConKey,       ForeignObjRep)
 746     ,(intPrimTyConKey,              IntRep)
 747     ,(mutableArrayPrimTyConKey,     ArrayRep)
 748     ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
 749     ,(stablePtrPrimTyConKey,        StablePtrRep)
 750     ,(statePrimTyConKey,            VoidRep)
 751     ,(synchVarPrimTyConKey,         PtrRep)
 752     ,(voidTyConKey,                 PtrRep)     -- Not VoidRep!  That's just for Void#
 753                                                 -- The type Void is represented by a pointer to
 754                                                 -- a bottom closure.
 755     ,(wordPrimTyConKey,             WordRep)
 756     ]
 757 \end{code}
 758
 759 %************************************************************************
 760 %*                                                                      *
 761 \subsection{Matching on types}
 762 %*                                                                      *
 763 %************************************************************************
 764
 765 Matching is a {\em unidirectional} process, matching a type against a
 766 template (which is just a type with type variables in it).  The
 767 matcher assumes that there are no repeated type variables in the
 768 template, so that it simply returns a mapping of type variables to
 769 types.  It also fails on nested foralls.
 770
 771 @matchTys@ matches corresponding elements of a list of templates and
 772 types.
 773
 774 \begin{code}
 775 matchTy :: GenType t1 u1                -- Template
 776         -> GenType t2 u2                -- Proposed instance of template
 777         -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
 778
 779
 780 matchTys :: [GenType t1 u1]             -- Templates
 781          -> [GenType t2 u2]             -- Proposed instance of template
 782          -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
 783                    [GenType t2 u2])     -- Left over instance types
 784
 785 matchTy  ty1  ty2  = match  ty1 ty2 (\s -> Just s) []
 786 matchTys tys1 tys2 = go [] tys1 tys2
 787                    where
 788                      go s []        tys2        = Just (s,tys2)
 789                      go s (ty1:tys1) []         = trace "matchTys" Nothing
 790                      go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
 791 \end{code}
 792
 793 @match@ is the main function.
 794
 795 \begin{code}
 796 match :: GenType t1 u1 -> GenType t2 u2                 -- Current match pair
 797       -> ([(t1, GenType t2 u2)] -> Maybe result)        -- Continuation
 798       -> [(t1, GenType t2 u2)]                          -- Current substitution
 799       -> Maybe result
 800
 801 match (TyVarTy v)          ty                   k = \s -> k ((v,ty) : s)
 802 match (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  k = match fun1 fun2 (match arg1 arg2 k)
 803 match (AppTy fun1 arg1)    (AppTy fun2 arg2)    k = match fun1 fun2 (match arg1 arg2 k)
 804 match (TyConTy con1 _)     (TyConTy con2 _)     k | con1  == con2  = k
 805 match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
 806 match (SynTy _ _ ty1)      ty2                  k = match ty1 ty2 k
 807 match ty1                      (SynTy _ _ ty2)  k = match ty1 ty2 k
 808
 809         -- With type synonyms, we have to be careful for the exact
 810         -- same reasons as in the unifier.  Please see the
 811         -- considerable commentary there before changing anything
 812         -- here! (WDP 95/05)
 813
 814 -- Catch-all fails
 815 match _ _ _ = \s -> Nothing
 816 \end{code}
 817
 818 %************************************************************************
 819 %*                                                                      *
 820 \subsection{Equality on types}
 821 %*                                                                      *
 822 %************************************************************************
 823
 824 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
 825 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
 826 dictionaries or polymorphic types).  The function eqTy has a more
 827 specific type, but does the `right thing' for all types.
 828
 829 \begin{code}
 830 eqSimpleTheta :: (Eq t,Eq u) =>
 831     [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
 832
 833 eqSimpleTheta [] [] = True
 834 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
 835   c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
 836 eqSimpleTheta other1 other2 = False
 837 \end{code}
 838
 839 \begin{code}
 840 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
 841
 842 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
 843   tv1 == tv2
 844 (AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
 845   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
 846 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
 847   tc1 == tc2 --ToDo: later: && u1 == u2
 848
 849 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
 850   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
 851 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
 852   -- Expand t1 just in case t2 matches that version
 853   (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
 854 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
 855   -- Expand t2 just in case t1 matches that version
 856   t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 857
 858 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
 859   (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
 860   || t1 `eqSimpleTy` t2
 861 (SynTy _ _ t1) `eqSimpleTy` t2 =
 862   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 863 t1 `eqSimpleTy` (SynTy _ _ t2) =
 864   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 865
 866 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
 867 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
 868
 869 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
 870 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
 871
 872 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
 873 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
 874
 875 _ `eqSimpleTy` _ = False
 876 \end{code}
 877
 878 Types are ordered so we can sort on types in the renamer etc.  DNT: Since
 879 this class is also used in CoreLint and other such places, we DO expand out
 880 Fun/Syn/Dict types (if necessary).
 881
 882 \begin{code}
 883 eqTy :: Type -> Type -> Bool
 884
 885 eqTy t1 t2 =
 886   eq nullTyVarEnv nullUVarEnv t1 t2
 887  where
 888   eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
 889     tv1 == tv2 ||
 890     case (lookupTyVarEnv tve tv1) of
 891       Just tv -> tv == tv2
 892       Nothing -> False
 893   eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
 894     eq tve uve f1 f2 && eq tve uve a1 a2
 895   eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
 896     tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
 897
 898   eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
 899     eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
 900   eq tve uve (FunTy f1 a1 u1) t2 =
 901     -- Expand t1 just in case t2 matches that version
 902     eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
 903   eq tve uve t1 (FunTy f2 a2 u2) =
 904     -- Expand t2 just in case t1 matches that version
 905     eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 906
 907   eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
 908     | c1 == c2
 909     = eq tve uve t1 t2 && eqUsage uve u1 u2
 910         -- NB we use a guard for c1==c2 so that if they aren't equal we
 911         -- fall through into expanding the type.  Why?  Because brain-dead
 912         -- people might write
 913         --      class Foo a => Baz a where {}
 914         -- and that means that a Foo dictionary and a Baz dictionary are identical
 915         -- Sigh.  Let's hope we don't spend too much time in here!
 916
 917   eq tve uve t1@(DictTy _ _ _) t2 =
 918     eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
 919   eq tve uve t1 t2@(DictTy _ _ _) =
 920     eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
 921
 922   eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
 923     (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
 924     || eq tve uve t1 t2
 925   eq tve uve (SynTy _ _ t1) t2 =
 926     eq tve uve t1 t2  -- Expand the abbrevation and try again
 927   eq tve uve t1 (SynTy _ _ t2) =
 928     eq tve uve t1 t2  -- Expand the abbrevation and try again
 929
 930   eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
 931     eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
 932   eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
 933     eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
 934
 935   eq _ _ _ _ = False
 936
 937   eqBounds uve [] [] = True
 938   eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
 939   eqBounds uve _ _ = False
 940 \end{code}
 941
 942 \begin{code}
 943 showTypeCategory :: Type -> Char
 944   {-
 945         {C,I,F,D}   char, int, float, double
 946         T           tuple
 947         S           other single-constructor type
 948         {c,i,f,d}   unboxed ditto
 949         t           *unpacked* tuple
 950         s           *unpacked" single-cons...
 951
 952         v           void#
 953         a           primitive array
 954
 955         E           enumeration type
 956         +           dictionary, unless it's a ...
 957         L           List
 958         >           function
 959         M           other (multi-constructor) data-con type
 960         .           other type
 961         -           reserved for others to mark as "uninteresting"
 962     -}
 963 showTypeCategory ty
 964   = if isDictTy ty
 965     then '+'
 966     else
 967       case getTyCon_maybe ty of
 968         Nothing -> if maybeToBool (getFunTy_maybe ty)
 969                    then '>'
 970                    else '.'
 971
 972         Just tycon ->
 973           let utc = uniqueOf tycon in
 974           if      utc == charDataConKey    then 'C'
 975           else if utc == intDataConKey     then 'I'
 976           else if utc == floatDataConKey   then 'F'
 977           else if utc == doubleDataConKey  then 'D'
 978           else if utc == integerDataConKey then 'J'
 979           else if utc == charPrimTyConKey  then 'c'
 980           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 981                 || utc == addrPrimTyConKey)                then 'i'
 982           else if utc  == floatPrimTyConKey                then 'f'
 983           else if utc  == doublePrimTyConKey               then 'd'
 984           else if isPrimTyCon tycon {- array, we hope -}   then 'A'
 985           else if isEnumerationTyCon tycon                 then 'E'
 986           else if isTupleTyCon tycon                       then 'T'
 987           else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
 988           else if utc == listTyConKey                      then 'L'
 989           else 'M' -- oh, well...
 990 \end{code}