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