ghc/compiler/types/Type.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module Type (
   5         GenType(..), Type(..), TauType(..),
   6         mkTyVarTy, mkTyVarTys,
   7         getTyVar, getTyVar_maybe, isTyVarTy,
   8         mkAppTy, mkAppTys, splitAppTy,
   9         mkFunTy, mkFunTys, splitFunTy, splitFunTyWithDictsAsArgs,
  10         getFunTy_maybe,
  11         mkTyConTy, getTyCon_maybe, applyTyCon,
  12         mkSynTy,
  13         mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
  14         mkForAllUsageTy, getForAllUsageTy,
  15         applyTy,
  16
  17         isPrimType, isUnboxedType, typePrimRep,
  18
  19         RhoType(..), SigmaType(..), ThetaType(..),
  20         mkDictTy,
  21         mkRhoTy, splitRhoTy,
  22         mkSigmaTy, splitSigmaTy,
  23
  24         maybeAppTyCon, getAppTyCon,
  25         maybeAppDataTyCon, getAppDataTyCon,
  26         maybeBoxedPrimType,
  27
  28         matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
  29
  30         instantiateTy, instantiateTauTy, instantiateUsage,
  31         applyTypeEnvToTy,
  32
  33         isTauTy,
  34
  35         tyVarsOfType, tyVarsOfTypes, typeKind
  36     ) where
  37
  38 import Ubiq
  39 import IdLoop    -- for paranoia checking
  40 import TyLoop    -- for paranoia checking
  41 import PrelLoop  -- for paranoia checking
  42
  43 -- ToDo:rm
  44 --import PprType        ( pprGenType ) -- ToDo: rm
  45 --import PprStyle ( PprStyle(..) )
  46 --import Util   ( pprPanic )
  47
  48 -- friends:
  49 import Class    ( classSig, classOpLocalType, GenClass{-instances-} )
  50 import Kind     ( mkBoxedTypeKind, resultKind )
  51 import TyCon    ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
  52                   tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
  53 import TyVar    ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
  54                   emptyTyVarSet, unionTyVarSets, minusTyVarSet,
  55                   unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
  56                   addOneToTyVarEnv, TyVarEnv(..) )
  57 import Usage    ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
  58                   nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
  59                   eqUsage )
  60
  61 -- others
  62 import PrimRep  ( PrimRep(..) )
  63 import Util     ( thenCmp, zipEqual, panic, panic#, assertPanic,
  64                   Ord3(..){-instances-}
  65                 )
  66 \end{code}
  67
  68 Data types
  69 ~~~~~~~~~~
  70
  71 \begin{code}
  72 type Type  = GenType TyVar UVar -- Used after typechecker
  73
  74 data GenType tyvar uvar -- Parameterised over type and usage variables
  75   = TyVarTy tyvar
  76
  77   | AppTy
  78         (GenType tyvar uvar)
  79         (GenType tyvar uvar)
  80
  81   | TyConTy     -- Constants of a specified kind
  82         TyCon   -- Must *not* be a SynTyCon
  83         (GenUsage uvar) -- Usage gives uvar of the full application,
  84                         -- iff the full application is of kind Type
  85                         -- c.f. the Usage field in TyVars
  86
  87   | SynTy       -- Synonyms must be saturated, and contain their expansion
  88         TyCon   -- Must be a SynTyCon
  89         [GenType tyvar uvar]
  90         (GenType tyvar uvar)    -- Expansion!
  91
  92   | ForAllTy
  93         tyvar
  94         (GenType tyvar uvar)    -- TypeKind
  95
  96   | ForAllUsageTy
  97         uvar                    -- Quantify over this
  98         [uvar]                  -- Bounds; the quantified var must be
  99                                 -- less than or equal to all these
 100         (GenType tyvar uvar)
 101
 102         -- Two special cases that save a *lot* of administrative
 103         -- overhead:
 104
 105   | FunTy                       -- BoxedTypeKind
 106         (GenType tyvar uvar)    -- Both args are of TypeKind
 107         (GenType tyvar uvar)
 108         (GenUsage uvar)
 109
 110   | DictTy                      -- TypeKind
 111         Class                   -- Class
 112         (GenType tyvar uvar)    -- Arg has kind TypeKind
 113         (GenUsage uvar)
 114 \end{code}
 115
 116 \begin{code}
 117 type RhoType   = Type
 118 type TauType   = Type
 119 type ThetaType = [(Class, Type)]
 120 type SigmaType = Type
 121 \end{code}
 122
 123
 124 Expand abbreviations
 125 ~~~~~~~~~~~~~~~~~~~~
 126 Removes just the top level of any abbreviations.
 127
 128 \begin{code}
 129 expandTy :: Type -> Type        -- Restricted to Type due to Dict expansion
 130
 131 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
 132 expandTy (SynTy _  _  t) = expandTy t
 133 expandTy (DictTy clas ty u)
 134   = case all_arg_tys of
 135
 136         [arg_ty] -> expandTy arg_ty     -- just the <whatever> itself
 137
 138                 -- The extra expandTy is to make sure that
 139                 -- the result isn't still a dict, which it might be
 140                 -- if the original guy was a dict with one superdict and
 141                 -- no methods!
 142
 143         other -> ASSERT(not (null all_arg_tys))
 144                 foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
 145
 146                 -- A tuple of 'em
 147                 -- Note: length of all_arg_tys can be 0 if the class is
 148                 --       CCallable, CReturnable (and anything else
 149                 --       *really weird* that the user writes).
 150   where
 151     (tyvar, super_classes, ops) = classSig clas
 152     super_dict_tys = map mk_super_ty super_classes
 153     class_op_tys   = map mk_op_ty ops
 154     all_arg_tys    = super_dict_tys ++ class_op_tys
 155     mk_super_ty sc = DictTy sc ty usageOmega
 156     mk_op_ty    op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
 157
 158 expandTy ty = ty
 159 \end{code}
 160
 161 Simple construction and analysis functions
 162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 163 \begin{code}
 164 mkTyVarTy  :: t   -> GenType t u
 165 mkTyVarTys :: [t] -> [GenType t y]
 166 mkTyVarTy  = TyVarTy
 167 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 168
 169 getTyVar :: String -> GenType t u -> t
 170 getTyVar msg (TyVarTy tv)   = tv
 171 getTyVar msg (SynTy _ _ t)  = getTyVar msg t
 172 getTyVar msg other          = panic ("getTyVar: " ++ msg)
 173
 174 getTyVar_maybe :: GenType t u -> Maybe t
 175 getTyVar_maybe (TyVarTy tv)  = Just tv
 176 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
 177 getTyVar_maybe other         = Nothing
 178
 179 isTyVarTy :: GenType t u -> Bool
 180 isTyVarTy (TyVarTy tv)  = True
 181 isTyVarTy (SynTy _ _ t) = isTyVarTy t
 182 isTyVarTy other = False
 183 \end{code}
 184
 185 \begin{code}
 186 mkAppTy = AppTy
 187
 188 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
 189 mkAppTys t ts = foldl AppTy t ts
 190
 191 splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
 192 splitAppTy t = go t []
 193   where
 194     go (AppTy t arg)     ts = go t (arg:ts)
 195     go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
 196     go (SynTy _ _ t)     ts = go t ts
 197     go t                 ts = (t,ts)
 198 \end{code}
 199
 200 \begin{code}
 201 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
 202 mkFunTy arg res = FunTy arg res usageOmega
 203
 204 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
 205 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
 206
 207 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
 208 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
 209 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
 210                  | isFunTyCon tycon = Just (arg, res)
 211 getFunTy_maybe (SynTy _ _ t)        = getFunTy_maybe t
 212 getFunTy_maybe other                = Nothing
 213
 214 splitFunTy                :: GenType t u -> ([GenType t u], GenType t u)
 215 splitFunTyWithDictsAsArgs :: Type        -> ([Type], Type)
 216   -- splitFunTy *must* have the general type given, which
 217   -- means it *can't* do the DictTy jiggery-pokery that
 218   -- *is* sometimes required.  The relationship between these
 219   -- two functions is like that between eqTy and eqSimpleTy.
 220
 221 splitFunTy t = go t []
 222   where
 223     go (FunTy arg res _) ts = go res (arg:ts)
 224     go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
 225         | isFunTyCon tycon  = go res (arg:ts)
 226     go (SynTy _ _ t) ts     = go t ts
 227     go t ts                 = (reverse ts, t)
 228
 229 splitFunTyWithDictsAsArgs t = go t []
 230   where
 231     go (FunTy arg res _) ts = go res (arg:ts)
 232     go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
 233         | isFunTyCon tycon  = go res (arg:ts)
 234     go (SynTy _ _ t) ts     = go t ts
 235
 236         -- For a dictionary type we try expanding it to see if we get a simple
 237         -- function; if so we thunder on; if not we throw away the expansion.
 238     go t@(DictTy _ _ _) ts | null ts'  = (reverse ts, t)
 239                            | otherwise = (reverse ts ++ ts', t')
 240                            where
 241                              (ts', t') = go (expandTy t) []
 242
 243     go t ts = (reverse ts, t)
 244 \end{code}
 245
 246 \begin{code}
 247 -- NB applyTyCon puts in usageOmega, for now at least
 248 mkTyConTy tycon
 249   = ASSERT(not (isSynTyCon tycon))
 250     TyConTy tycon usageOmega
 251
 252 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
 253 applyTyCon tycon tys
 254   = ASSERT (not (isSynTyCon tycon))
 255     foldl AppTy (TyConTy tycon usageOmega) tys
 256
 257 getTyCon_maybe :: GenType t u -> Maybe TyCon
 258 getTyCon_maybe (TyConTy tycon _) = Just tycon
 259 getTyCon_maybe (SynTy _ _ t)     = getTyCon_maybe t
 260 getTyCon_maybe other_ty          = Nothing
 261 \end{code}
 262
 263 \begin{code}
 264 mkSynTy syn_tycon tys
 265   = ASSERT(isSynTyCon syn_tycon)
 266     SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body)
 267   where
 268     (tyvars, body) = getSynTyConDefn syn_tycon
 269 \end{code}
 270
 271 Tau stuff
 272 ~~~~~~~~~
 273 \begin{code}
 274 isTauTy :: GenType t u -> Bool
 275 isTauTy (TyVarTy v)        = True
 276 isTauTy (TyConTy _ _)      = True
 277 isTauTy (AppTy a b)        = isTauTy a && isTauTy b
 278 isTauTy (FunTy a b _)      = isTauTy a && isTauTy b
 279 isTauTy (SynTy _ _ ty)     = isTauTy ty
 280 isTauTy other              = False
 281 \end{code}
 282
 283 Rho stuff
 284 ~~~~~~~~~
 285 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
 286
 287 \begin{code}
 288 mkDictTy :: Class -> GenType t u -> GenType t u
 289 mkDictTy clas ty = DictTy clas ty usageOmega
 290
 291 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
 292 mkRhoTy theta ty =
 293   foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
 294
 295 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
 296 splitRhoTy t =
 297   go t []
 298  where
 299   go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
 300   go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
 301         | isFunTyCon tycon
 302         = go r ((c,t):ts)
 303   go (SynTy _ _ t) ts = go t ts
 304   go t ts = (reverse ts, t)
 305 \end{code}
 306
 307
 308 Forall stuff
 309 ~~~~~~~~~~~~
 310 \begin{code}
 311 mkForAllTy = ForAllTy
 312
 313 mkForAllTys :: [t] -> GenType t u -> GenType t u
 314 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 315
 316 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
 317 getForAllTy_maybe (SynTy _ _ t)      = getForAllTy_maybe t
 318 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 319 getForAllTy_maybe _                  = Nothing
 320
 321 splitForAllTy :: GenType t u-> ([t], GenType t u)
 322 splitForAllTy t = go t []
 323                where
 324                     go (ForAllTy tv t) tvs = go t (tv:tvs)
 325                     go (SynTy _ _ t)   tvs = go t tvs
 326                     go t               tvs = (reverse tvs, t)
 327 \end{code}
 328
 329 \begin{code}
 330 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
 331 mkForAllUsageTy = ForAllUsageTy
 332
 333 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
 334 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
 335 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
 336 getForAllUsageTy _ = Nothing
 337 \end{code}
 338
 339 Applied tycons (includes FunTyCons)
 340 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 341 \begin{code}
 342 maybeAppTyCon
 343         :: GenType tyvar uvar
 344         -> Maybe (TyCon,                -- the type constructor
 345                   [GenType tyvar uvar]) -- types to which it is applied
 346
 347 maybeAppTyCon ty
 348   = case (getTyCon_maybe app_ty) of
 349         Nothing    -> Nothing
 350         Just tycon -> Just (tycon, arg_tys)
 351   where
 352     (app_ty, arg_tys) = splitAppTy ty
 353
 354
 355 getAppTyCon
 356         :: GenType tyvar uvar
 357         -> (TyCon,                      -- the type constructor
 358             [GenType tyvar uvar])       -- types to which it is applied
 359
 360 getAppTyCon ty
 361   = case maybeAppTyCon ty of
 362       Just stuff -> stuff
 363 #ifdef DEBUG
 364       Nothing    -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
 365 #endif
 366 \end{code}
 367
 368 Applied data tycons (give back constrs)
 369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 370 \begin{code}
 371 maybeAppDataTyCon
 372         :: GenType tyvar uvar
 373         -> Maybe (TyCon,                -- the type constructor
 374                   [GenType tyvar uvar], -- types to which it is applied
 375                   [Id])                 -- its family of data-constructors
 376
 377 maybeAppDataTyCon ty
 378   = case (getTyCon_maybe app_ty) of
 379         Just tycon |  isDataTyCon tycon &&
 380                       tyConArity tycon == length arg_tys
 381                         -- Must be saturated for ty to be a data type
 382                    -> Just (tycon, arg_tys, tyConDataCons tycon)
 383
 384         other      -> Nothing
 385   where
 386     (app_ty, arg_tys) = splitAppTy ty
 387
 388
 389 getAppDataTyCon
 390         :: GenType tyvar uvar
 391         -> (TyCon,                      -- the type constructor
 392             [GenType tyvar uvar],       -- types to which it is applied
 393             [Id])                       -- its family of data-constructors
 394
 395 getAppDataTyCon ty
 396   = case maybeAppDataTyCon ty of
 397       Just stuff -> stuff
 398 #ifdef DEBUG
 399       Nothing    -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty)
 400 #endif
 401
 402
 403 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
 404
 405 maybeBoxedPrimType ty
 406   = case (maybeAppDataTyCon ty) of              -- Data type,
 407       Just (tycon, tys_applied, [data_con])     -- with exactly one constructor
 408         -> case (dataConArgTys data_con tys_applied) of
 409              [data_con_arg_ty]                  -- Applied to exactly one type,
 410                 | isPrimType data_con_arg_ty    -- which is primitive
 411                 -> Just (data_con, data_con_arg_ty)
 412              other_cases -> Nothing
 413       other_cases -> Nothing
 414 \end{code}
 415
 416 \begin{code}
 417 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
 418 splitSigmaTy ty =
 419   (tyvars, theta, tau)
 420  where
 421   (tyvars,rho) = splitForAllTy ty
 422   (theta,tau)  = splitRhoTy rho
 423
 424 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 425 \end{code}
 426
 427
 428 Finding the kind of a type
 429 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 430 \begin{code}
 431 typeKind :: GenType (GenTyVar any) u -> Kind
 432 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 433 typeKind (TyConTy tycon usage)  = tyConKind tycon
 434 typeKind (SynTy _ _ ty)         = typeKind ty
 435 typeKind (FunTy fun arg _)      = mkBoxedTypeKind
 436 typeKind (DictTy clas arg _)    = mkBoxedTypeKind
 437 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 438 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 439 typeKind (ForAllUsageTy _ _ _)  = mkBoxedTypeKind
 440 \end{code}
 441
 442
 443 Free variables of a type
 444 ~~~~~~~~~~~~~~~~~~~~~~~~
 445 \begin{code}
 446 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
 447
 448 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 449 tyVarsOfType (TyConTy tycon usage)      = emptyTyVarSet
 450 tyVarsOfType (SynTy _ tys ty)           = tyVarsOfTypes tys
 451 tyVarsOfType (FunTy arg res _)          = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 452 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 453 tyVarsOfType (DictTy clas ty _)         = tyVarsOfType ty
 454 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 455 tyVarsOfType (ForAllUsageTy _ _ ty)     = tyVarsOfType ty
 456
 457 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
 458 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 459 \end{code}
 460
 461
 462 Instantiating a type
 463 ~~~~~~~~~~~~~~~~~~~~
 464 \begin{code}
 465 applyTy :: Eq t => GenType t u -> GenType t u -> GenType t u
 466 applyTy (SynTy _ _ fun)  arg = applyTy fun arg
 467 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
 468 applyTy other            arg = panic "applyTy"
 469
 470 instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u
 471 instantiateTy tenv ty
 472   = go ty
 473   where
 474     go (TyVarTy tv)             = case [ty | (tv',ty) <- tenv, tv==tv'] of
 475                                   []     -> TyVarTy tv
 476                                   (ty:_) -> ty
 477     go ty@(TyConTy tycon usage) = ty
 478     go (SynTy tycon tys ty)     = SynTy tycon (map go tys) (go ty)
 479     go (FunTy arg res usage)    = FunTy (go arg) (go res) usage
 480     go (AppTy fun arg)          = AppTy (go fun) (go arg)
 481     go (DictTy clas ty usage)   = DictTy clas (go ty) usage
 482     go (ForAllTy tv ty)         = ASSERT(null tv_bound)
 483                                   ForAllTy tv (go ty)
 484                                 where
 485                                   tv_bound = [() | (tv',_) <- tenv, tv==tv']
 486
 487     go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
 488
 489
 490 -- instantiateTauTy works only (a) on types with no ForAlls,
 491 --      and when               (b) all the type variables are being instantiated
 492 -- In return it is more polymorphic than instantiateTy
 493
 494 instantiateTauTy :: Eq t => [(t, GenType t' u)] -> GenType t u -> GenType t' u
 495 instantiateTauTy tenv ty
 496   = go ty
 497   where
 498     go (TyVarTy tv)             = case [ty | (tv',ty) <- tenv, tv==tv'] of
 499                                   (ty:_) -> ty
 500                                   []     -> panic "instantiateTauTy"
 501     go (TyConTy tycon usage)    = TyConTy tycon usage
 502     go (SynTy tycon tys ty)     = SynTy tycon (map go tys) (go ty)
 503     go (FunTy arg res usage)    = FunTy (go arg) (go res) usage
 504     go (AppTy fun arg)          = AppTy (go fun) (go arg)
 505     go (DictTy clas ty usage)   = DictTy clas (go ty) usage
 506
 507 instantiateUsage
 508         :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
 509 instantiateUsage = error "instantiateUsage: not implemented"
 510 \end{code}
 511
 512 \begin{code}
 513 type TypeEnv = TyVarEnv Type
 514
 515 applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType
 516 applyTypeEnvToTy tenv ty
 517   = mapOverTyVars v_fn ty
 518   where
 519     v_fn v = case (lookupTyVarEnv tenv v) of
 520                 Just ty -> ty
 521                 Nothing -> TyVarTy v
 522 \end{code}
 523
 524 @mapOverTyVars@ is a local function which actually does the work.  It
 525 does no cloning or other checks for shadowing, so be careful when
 526 calling this on types with Foralls in them.
 527
 528 \begin{code}
 529 mapOverTyVars :: (TyVar -> Type) -> Type -> Type
 530
 531 mapOverTyVars v_fn ty
 532   = let
 533         mapper = mapOverTyVars v_fn
 534     in
 535     case ty of
 536       TyVarTy v         -> v_fn v
 537       SynTy c as e      -> SynTy c (map mapper as) (mapper e)
 538       FunTy a r u       -> FunTy (mapper a) (mapper r) u
 539       AppTy f a         -> AppTy (mapper f) (mapper a)
 540       DictTy c t u      -> DictTy c (mapper t) u
 541       ForAllTy v t      -> ForAllTy v (mapper t)
 542       tc@(TyConTy _ _)  -> tc
 543 \end{code}
 544
 545 At present there are no unboxed non-primitive types, so
 546 isUnboxedType is the same as isPrimType.
 547
 548 \begin{code}
 549 isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool
 550
 551 isPrimType (AppTy ty _)      = isPrimType ty
 552 isPrimType (SynTy _ _ ty)    = isPrimType ty
 553 isPrimType (TyConTy tycon _) = isPrimTyCon tycon
 554 isPrimType _                 = False
 555
 556 isUnboxedType = isPrimType
 557 \end{code}
 558
 559 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
 560 \begin{code}
 561 typePrimRep :: GenType tyvar uvar -> PrimRep
 562
 563 typePrimRep (SynTy _ _ ty)  = typePrimRep ty
 564 typePrimRep (TyConTy tc _)  = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep
 565 typePrimRep (AppTy ty _)    = typePrimRep ty
 566 typePrimRep _               = PtrRep -- the "default"
 567 \end{code}
 568
 569 %************************************************************************
 570 %*                                                                      *
 571 \subsection{Matching on types}
 572 %*                                                                      *
 573 %************************************************************************
 574
 575 Matching is a {\em unidirectional} process, matching a type against a
 576 template (which is just a type with type variables in it).  The
 577 matcher assumes that there are no repeated type variables in the
 578 template, so that it simply returns a mapping of type variables to
 579 types.  It also fails on nested foralls.
 580
 581 @matchTys@ matches corresponding elements of a list of templates and
 582 types.
 583
 584 \begin{code}
 585 matchTy :: GenType t1 u1                -- Template
 586         -> GenType t2 u2                -- Proposed instance of template
 587         -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
 588
 589 matchTys :: [GenType t1 u1]             -- Templates
 590          -> [GenType t2 u2]             -- Proposed instance of template
 591          -> Maybe [(t1,GenType t2 u2)]  -- Matching substitution
 592
 593 matchTy  ty1  ty2  = match  [] [] ty1 ty2
 594 matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2)
 595 \end{code}
 596
 597 @match@ is the main function.
 598
 599 \begin{code}
 600 match :: [(t1, GenType t2 u2)]                  -- r, the accumulating result
 601       -> [(GenType t1 u1, GenType t2 u2)]       -- w, the work list
 602       -> GenType t1 u1 -> GenType t2 u2         -- Current match pair
 603       -> Maybe [(t1, GenType t2 u2)]
 604
 605 match r w (TyVarTy v)          ty                   = match' ((v,ty) : r) w
 606 match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
 607 match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
 608 match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
 609 match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
 610 match r w (SynTy _ _ ty1)      ty2                  = match r w ty1 ty2
 611 match r w ty1                  (SynTy _ _ ty2)      = match r w ty1 ty2
 612
 613         -- With type synonyms, we have to be careful for the exact
 614         -- same reasons as in the unifier.  Please see the
 615         -- considerable commentary there before changing anything
 616         -- here! (WDP 95/05)
 617
 618 -- Catch-all fails
 619 match _ _ _ _ = Nothing
 620
 621 match' r []            = Just r
 622 match' r ((ty1,ty2):w) = match r w ty1 ty2
 623 \end{code}
 624
 625 %************************************************************************
 626 %*                                                                      *
 627 \subsection{Equality on types}
 628 %*                                                                      *
 629 %************************************************************************
 630
 631 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
 632 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
 633 dictionaries or polymorphic types).  The function eqTy has a more
 634 specific type, but does the `right thing' for all types.
 635
 636 \begin{code}
 637 eqSimpleTheta :: (Eq t,Eq u) =>
 638     [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
 639
 640 eqSimpleTheta [] [] = True
 641 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
 642   c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
 643 eqSimpleTheta other1 other2 = False
 644 \end{code}
 645
 646 \begin{code}
 647 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
 648
 649 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
 650   tv1 == tv2
 651 (AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
 652   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
 653 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
 654   tc1 == tc2 && u1 == u2
 655
 656 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
 657   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
 658 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
 659   -- Expand t1 just in case t2 matches that version
 660   (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
 661 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
 662   -- Expand t2 just in case t1 matches that version
 663   t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 664
 665 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
 666   (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
 667   || t1 `eqSimpleTy` t2
 668 (SynTy _ _ t1) `eqSimpleTy` t2 =
 669   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 670 t1 `eqSimpleTy` (SynTy _ _ t2) =
 671   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 672
 673 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
 674 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
 675
 676 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
 677 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
 678
 679 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
 680 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
 681
 682 _ `eqSimpleTy` _ = False
 683 \end{code}
 684
 685 Types are ordered so we can sort on types in the renamer etc.  DNT: Since
 686 this class is also used in CoreLint and other such places, we DO expand out
 687 Fun/Syn/Dict types (if necessary).
 688
 689 \begin{code}
 690 eqTy :: Type -> Type -> Bool
 691
 692 eqTy t1 t2 =
 693   eq nullTyVarEnv nullUVarEnv t1 t2
 694  where
 695   eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
 696     tv1 == tv2 ||
 697     case (lookupTyVarEnv tve tv1) of
 698       Just tv -> tv == tv2
 699       Nothing -> False
 700   eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
 701     eq tve uve f1 f2 && eq tve uve a1 a2
 702   eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
 703     tc1 == tc2 && eqUsage uve u1 u2
 704
 705   eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
 706     eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
 707   eq tve uve (FunTy f1 a1 u1) t2 =
 708     -- Expand t1 just in case t2 matches that version
 709     eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
 710   eq tve uve t1 (FunTy f2 a2 u2) =
 711     -- Expand t2 just in case t1 matches that version
 712     eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 713
 714   eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
 715     | c1 == c2
 716     = eq tve uve t1 t2 && eqUsage uve u1 u2
 717         -- NB we use a guard for c1==c2 so that if they aren't equal we
 718         -- fall through into expanding the type.  Why?  Because brain-dead
 719         -- people might write
 720         --      class Foo a => Baz a where {}
 721         -- and that means that a Foo dictionary and a Baz dictionary are identical
 722         -- Sigh.  Let's hope we don't spend too much time in here!
 723
 724   eq tve uve t1@(DictTy _ _ _) t2 =
 725     eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
 726   eq tve uve t1 t2@(DictTy _ _ _) =
 727     eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
 728
 729   eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
 730     (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
 731     || eq tve uve t1 t2
 732   eq tve uve (SynTy _ _ t1) t2 =
 733     eq tve uve t1 t2  -- Expand the abbrevation and try again
 734   eq tve uve t1 (SynTy _ _ t2) =
 735     eq tve uve t1 t2  -- Expand the abbrevation and try again
 736
 737   eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
 738     eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
 739   eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
 740     eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
 741
 742   eq _ _ _ _ = False
 743
 744   eqBounds uve [] [] = True
 745   eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
 746   eqBounds uve _ _ = False
 747 \end{code}