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