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