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