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