compiler/types/Type.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[Type]{Type - public interface}
   5
   6 \begin{code}
   7 module Type (
   8         -- re-exports from TypeRep
   9         TyThing(..), Type, PredType(..), ThetaType,
  10         funTyCon,
  11
  12         -- Re-exports from Kind
  13         module Kind,
  14
  15         -- Re-exports from TyCon
  16         PrimRep(..),
  17
  18         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
  19
  20         mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
  21
  22         mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
  23         splitFunTys, splitFunTysN,
  24         funResultTy, funArgTy, zipFunTys, isFunTy,
  25
  26         mkTyConApp, mkTyConTy,
  27         tyConAppTyCon, tyConAppArgs,
  28         splitTyConApp_maybe, splitTyConApp,
  29
  30         repType, typePrimRep, coreView, tcView,
  31
  32         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
  33         applyTy, applyTys, isForAllTy, dropForAlls,
  34
  35         -- Source types
  36         predTypeRep, mkPredTy, mkPredTys,
  37
  38         -- Newtypes
  39         splitRecNewType_maybe,
  40
  41         -- Lifting and boxity
  42         isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
  43         isStrictType, isStrictPred,
  44
  45         -- Free variables
  46         tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
  47         typeKind, addFreeTyVars,
  48
  49         -- Tidying up for printing
  50         tidyType,      tidyTypes,
  51         tidyOpenType,  tidyOpenTypes,
  52         tidyTyVarBndr, tidyFreeTyVars,
  53         tidyOpenTyVar, tidyOpenTyVars,
  54         tidyTopType,   tidyPred,
  55         tidyKind,
  56
  57         -- Comparison
  58         coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
  59         tcEqPred, tcCmpPred, tcEqTypeX,
  60
  61         -- Seq
  62         seqType, seqTypes,
  63
  64         -- Type substitutions
  65         TvSubstEnv, emptyTvSubstEnv,    -- Representation widely visible
  66         TvSubst(..), emptyTvSubst,      -- Representation visible to a few friends
  67         mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
  68         getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
  69         extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
  70
  71         -- Performing substitution on types
  72         substTy, substTys, substTyWith, substTheta,
  73         substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar,
  74
  75         -- Pretty-printing
  76         pprType, pprParendType, pprTyThingCategory,
  77         pprPred, pprTheta, pprThetaArrow, pprClassPred
  78     ) where
  79
  80 #include "HsVersions.h"
  81
  82 -- We import the representation and primitive functions from TypeRep.
  83 -- Many things are reexported, but not the representation!
  84
  85 import TypeRep
  86
  87 -- friends:
  88 import Kind
  89 import Var      ( Var, TyVar, tyVarKind, tyVarName, setTyVarName, mkTyVar )
  90 import VarEnv
  91 import VarSet
  92
  93 import OccName  ( tidyOccName )
  94 import Name     ( NamedThing(..), mkInternalName, tidyNameOcc )
  95 import Class    ( Class, classTyCon )
  96 import TyCon    ( TyCon, isRecursiveTyCon, isPrimTyCon,
  97                   isUnboxedTupleTyCon, isUnLiftedTyCon,
  98                   isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
  99                   isAlgTyCon, tyConArity,
 100                   tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 101                   tyConKind, PrimRep(..), tyConPrimRep,
 102                 )
 103
 104 -- others
 105 import StaticFlags      ( opt_DictsStrict )
 106 import SrcLoc           ( noSrcLoc )
 107 import Util             ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual, all2 )
 108 import Outputable
 109 import UniqSet          ( sizeUniqSet )         -- Should come via VarSet
 110 import Maybe            ( isJust )
 111 \end{code}
 112
 113
 114 %************************************************************************
 115 %*                                                                      *
 116                 Type representation
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 In Core, we "look through" non-recursive newtypes and PredTypes.
 121
 122 \begin{code}
 123 {-# INLINE coreView #-}
 124 coreView :: Type -> Maybe Type
 125 -- Srips off the *top layer only* of a type to give
 126 -- its underlying representation type.
 127 -- Returns Nothing if there is nothing to look through.
 128 --
 129 -- In the case of newtypes, it returns
 130 --      *either* a vanilla TyConApp (recursive newtype, or non-saturated)
 131 --      *or*     the newtype representation (otherwise), meaning the
 132 --                      type written in the RHS of the newtype decl,
 133 --                      which may itself be a newtype
 134 --
 135 -- Example: newtype R = MkR S
 136 --          newtype S = MkS T
 137 --          newtype T = MkT (T -> T)
 138 --   expandNewTcApp on R gives Just S
 139 --                  on S gives Just T
 140 --                  on T gives Nothing   (no expansion)
 141
 142 -- By being non-recursive and inlined, this case analysis gets efficiently
 143 -- joined onto the case analysis that the caller is already doing
 144 coreView (NoteTy _ ty)     = Just ty
 145 coreView (PredTy p)        = Just (predTypeRep p)
 146 coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
 147                            = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
 148                                 -- Its important to use mkAppTys, rather than (foldl AppTy),
 149                                 -- because the function part might well return a
 150                                 -- partially-applied type constructor; indeed, usually will!
 151 coreView ty                = Nothing
 152
 153 -----------------------------------------------
 154 {-# INLINE tcView #-}
 155 tcView :: Type -> Maybe Type
 156 -- Same, but for the type checker, which just looks through synonyms
 157 tcView (NoteTy _ ty)     = Just ty
 158 tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
 159                          = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
 160 tcView ty                = Nothing
 161 \end{code}
 162
 163
 164 %************************************************************************
 165 %*                                                                      *
 166 \subsection{Constructor-specific functions}
 167 %*                                                                      *
 168 %************************************************************************
 169
 170
 171 ---------------------------------------------------------------------
 172                                 TyVarTy
 173                                 ~~~~~~~
 174 \begin{code}
 175 mkTyVarTy  :: TyVar   -> Type
 176 mkTyVarTy  = TyVarTy
 177
 178 mkTyVarTys :: [TyVar] -> [Type]
 179 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 180
 181 getTyVar :: String -> Type -> TyVar
 182 getTyVar msg ty = case getTyVar_maybe ty of
 183                     Just tv -> tv
 184                     Nothing -> panic ("getTyVar: " ++ msg)
 185
 186 isTyVarTy :: Type -> Bool
 187 isTyVarTy ty = isJust (getTyVar_maybe ty)
 188
 189 getTyVar_maybe :: Type -> Maybe TyVar
 190 getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
 191 getTyVar_maybe (TyVarTy tv)                 = Just tv
 192 getTyVar_maybe other                        = Nothing
 193 \end{code}
 194
 195
 196 ---------------------------------------------------------------------
 197                                 AppTy
 198                                 ~~~~~
 199 We need to be pretty careful with AppTy to make sure we obey the
 200 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 201 invariant: use it.
 202
 203 \begin{code}
 204 mkAppTy orig_ty1 orig_ty2
 205   = mk_app orig_ty1
 206   where
 207     mk_app (NoteTy _ ty1)    = mk_app ty1
 208     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
 209     mk_app ty1               = AppTy orig_ty1 orig_ty2
 210         -- Note that the TyConApp could be an
 211         -- under-saturated type synonym.  GHC allows that; e.g.
 212         --      type Foo k = k a -> k a
 213         --      type Id x = x
 214         --      foo :: Foo Id -> Foo Id
 215         --
 216         -- Here Id is partially applied in the type sig for Foo,
 217         -- but once the type synonyms are expanded all is well
 218
 219 mkAppTys :: Type -> [Type] -> Type
 220 mkAppTys orig_ty1 []        = orig_ty1
 221         -- This check for an empty list of type arguments
 222         -- avoids the needless loss of a type synonym constructor.
 223         -- For example: mkAppTys Rational []
 224         --   returns to (Ratio Integer), which has needlessly lost
 225         --   the Rational part.
 226 mkAppTys orig_ty1 orig_tys2
 227   = mk_app orig_ty1
 228   where
 229     mk_app (NoteTy _ ty1)    = mk_app ty1
 230     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 231                                 -- mkTyConApp: see notes with mkAppTy
 232     mk_app ty1               = foldl AppTy orig_ty1 orig_tys2
 233
 234 splitAppTy_maybe :: Type -> Maybe (Type, Type)
 235 splitAppTy_maybe ty | Just ty' <- coreView ty = splitAppTy_maybe ty'
 236 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 237 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 238 splitAppTy_maybe (TyConApp tc tys) = case snocView tys of
 239                                         Nothing         -> Nothing
 240                                         Just (tys',ty') -> Just (TyConApp tc tys', ty')
 241 splitAppTy_maybe other             = Nothing
 242
 243 splitAppTy :: Type -> (Type, Type)
 244 splitAppTy ty = case splitAppTy_maybe ty of
 245                         Just pr -> pr
 246                         Nothing -> panic "splitAppTy"
 247
 248 splitAppTys :: Type -> (Type, [Type])
 249 splitAppTys ty = split ty ty []
 250   where
 251     split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
 252     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 253     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
 254     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 255                                                (TyConApp funTyCon [], [ty1,ty2])
 256     split orig_ty ty                    args = (orig_ty, args)
 257 \end{code}
 258
 259
 260 ---------------------------------------------------------------------
 261                                 FunTy
 262                                 ~~~~~
 263
 264 \begin{code}
 265 mkFunTy :: Type -> Type -> Type
 266 mkFunTy arg res = FunTy arg res
 267
 268 mkFunTys :: [Type] -> Type -> Type
 269 mkFunTys tys ty = foldr FunTy ty tys
 270
 271 isFunTy :: Type -> Bool
 272 isFunTy ty = isJust (splitFunTy_maybe ty)
 273
 274 splitFunTy :: Type -> (Type, Type)
 275 splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'
 276 splitFunTy (FunTy arg res)   = (arg, res)
 277 splitFunTy other             = pprPanic "splitFunTy" (ppr other)
 278
 279 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 280 splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'
 281 splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
 282 splitFunTy_maybe other             = Nothing
 283
 284 splitFunTys :: Type -> ([Type], Type)
 285 splitFunTys ty = split [] ty ty
 286   where
 287     split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
 288     split args orig_ty (FunTy arg res)   = split (arg:args) res res
 289     split args orig_ty ty                = (reverse args, orig_ty)
 290
 291 splitFunTysN :: Int -> Type -> ([Type], Type)
 292 -- Split off exactly n arg tys
 293 splitFunTysN 0 ty = ([], ty)
 294 splitFunTysN n ty = case splitFunTy ty of { (arg, res) ->
 295                     case splitFunTysN (n-1) res of { (args, res) ->
 296                     (arg:args, res) }}
 297
 298 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
 299 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
 300   where
 301     split acc []     nty ty                = (reverse acc, nty)
 302     split acc xs     nty ty
 303           | Just ty' <- coreView ty        = split acc xs nty ty'
 304     split acc (x:xs) nty (FunTy arg res)   = split ((x,arg):acc) xs res res
 305     split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
 306
 307 funResultTy :: Type -> Type
 308 funResultTy ty | Just ty' <- coreView ty = funResultTy ty'
 309 funResultTy (FunTy arg res)   = res
 310 funResultTy ty                = pprPanic "funResultTy" (ppr ty)
 311
 312 funArgTy :: Type -> Type
 313 funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
 314 funArgTy (FunTy arg res)   = arg
 315 funArgTy ty                = pprPanic "funArgTy" (ppr ty)
 316 \end{code}
 317
 318
 319 ---------------------------------------------------------------------
 320                                 TyConApp
 321                                 ~~~~~~~~
 322 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy,
 323 as apppropriate.
 324
 325 \begin{code}
 326 mkTyConApp :: TyCon -> [Type] -> Type
 327 mkTyConApp tycon tys
 328   | isFunTyCon tycon, [ty1,ty2] <- tys
 329   = FunTy ty1 ty2
 330
 331   | otherwise
 332   = TyConApp tycon tys
 333
 334 mkTyConTy :: TyCon -> Type
 335 mkTyConTy tycon = mkTyConApp tycon []
 336
 337 -- splitTyConApp "looks through" synonyms, because they don't
 338 -- mean a distinct type, but all other type-constructor applications
 339 -- including functions are returned as Just ..
 340
 341 tyConAppTyCon :: Type -> TyCon
 342 tyConAppTyCon ty = fst (splitTyConApp ty)
 343
 344 tyConAppArgs :: Type -> [Type]
 345 tyConAppArgs ty = snd (splitTyConApp ty)
 346
 347 splitTyConApp :: Type -> (TyCon, [Type])
 348 splitTyConApp ty = case splitTyConApp_maybe ty of
 349                         Just stuff -> stuff
 350                         Nothing    -> pprPanic "splitTyConApp" (ppr ty)
 351
 352 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 353 splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'
 354 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 355 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 356 splitTyConApp_maybe other             = Nothing
 357 \end{code}
 358
 359
 360 ---------------------------------------------------------------------
 361                                 SynTy
 362                                 ~~~~~
 363
 364 Notes on type synonyms
 365 ~~~~~~~~~~~~~~~~~~~~~~
 366 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 367 to return type synonyms whereever possible. Thus
 368
 369         type Foo a = a -> a
 370
 371 we want
 372         splitFunTys (a -> Foo a) = ([a], Foo a)
 373 not                                ([a], a -> a)
 374
 375 The reason is that we then get better (shorter) type signatures in
 376 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 377
 378
 379                 Representation types
 380                 ~~~~~~~~~~~~~~~~~~~~
 381 repType looks through
 382         (a) for-alls, and
 383         (b) synonyms
 384         (c) predicates
 385         (d) usage annotations
 386         (e) all newtypes, including recursive ones
 387 It's useful in the back end.
 388
 389 \begin{code}
 390 repType :: Type -> Type
 391 -- Only applied to types of kind *; hence tycons are saturated
 392 repType ty | Just ty' <- coreView ty = repType ty'
 393 repType (ForAllTy _ ty)  = repType ty
 394 repType (TyConApp tc tys)
 395   | isNewTyCon tc        = -- Recursive newtypes are opaque to coreView
 396                            -- but we must expand them here.  Sure to
 397                            -- be saturated because repType is only applied
 398                            -- to types of kind *
 399                            ASSERT( isRecursiveTyCon tc &&
 400                                    tys `lengthIs` tyConArity tc )
 401                            repType (new_type_rep tc tys)
 402 repType ty = ty
 403
 404 -- new_type_rep doesn't ask any questions:
 405 -- it just expands newtype, whether recursive or not
 406 new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
 407                              case newTyConRep new_tycon of
 408                                  (tvs, rep_ty) -> substTyWith tvs tys rep_ty
 409
 410 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 411 -- of inspecting the type directly.
 412 typePrimRep :: Type -> PrimRep
 413 typePrimRep ty = case repType ty of
 414                    TyConApp tc _ -> tyConPrimRep tc
 415                    FunTy _ _     -> PtrRep
 416                    AppTy _ _     -> PtrRep      -- See note below
 417                    TyVarTy _     -> PtrRep
 418                    other         -> pprPanic "typePrimRep" (ppr ty)
 419         -- Types of the form 'f a' must be of kind *, not *#, so
 420         -- we are guaranteed that they are represented by pointers.
 421         -- The reason is that f must have kind *->*, not *->*#, because
 422         -- (we claim) there is no way to constrain f's kind any other
 423         -- way.
 424
 425 \end{code}
 426
 427
 428 ---------------------------------------------------------------------
 429                                 ForAllTy
 430                                 ~~~~~~~~
 431
 432 \begin{code}
 433 mkForAllTy :: TyVar -> Type -> Type
 434 mkForAllTy tyvar ty
 435   = mkForAllTys [tyvar] ty
 436
 437 mkForAllTys :: [TyVar] -> Type -> Type
 438 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 439
 440 isForAllTy :: Type -> Bool
 441 isForAllTy (NoteTy _ ty)  = isForAllTy ty
 442 isForAllTy (ForAllTy _ _) = True
 443 isForAllTy other_ty       = False
 444
 445 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 446 splitForAllTy_maybe ty = splitFAT_m ty
 447   where
 448     splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty'
 449     splitFAT_m (ForAllTy tyvar ty)          = Just(tyvar, ty)
 450     splitFAT_m _                            = Nothing
 451
 452 splitForAllTys :: Type -> ([TyVar], Type)
 453 splitForAllTys ty = split ty ty []
 454    where
 455      split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
 456      split orig_ty (ForAllTy tv ty)  tvs = split ty ty (tv:tvs)
 457      split orig_ty t                 tvs = (reverse tvs, orig_ty)
 458
 459 dropForAlls :: Type -> Type
 460 dropForAlls ty = snd (splitForAllTys ty)
 461 \end{code}
 462
 463 -- (mkPiType now in CoreUtils)
 464
 465 applyTy, applyTys
 466 ~~~~~~~~~~~~~~~~~
 467 Instantiate a for-all type with one or more type arguments.
 468 Used when we have a polymorphic function applied to type args:
 469         f t1 t2
 470 Then we use (applyTys type-of-f [t1,t2]) to compute the type of
 471 the expression.
 472
 473 \begin{code}
 474 applyTy :: Type -> Type -> Type
 475 applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
 476 applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
 477 applyTy other            arg = panic "applyTy"
 478
 479 applyTys :: Type -> [Type] -> Type
 480 -- This function is interesting because
 481 --      a) the function may have more for-alls than there are args
 482 --      b) less obviously, it may have fewer for-alls
 483 -- For case (b) think of
 484 --      applyTys (forall a.a) [forall b.b, Int]
 485 -- This really can happen, via dressing up polymorphic types with newtype
 486 -- clothing.  Here's an example:
 487 --      newtype R = R (forall a. a->a)
 488 --      foo = case undefined :: R of
 489 --              R f -> f ()
 490
 491 applyTys orig_fun_ty []      = orig_fun_ty
 492 applyTys orig_fun_ty arg_tys
 493   | n_tvs == n_args     -- The vastly common case
 494   = substTyWith tvs arg_tys rho_ty
 495   | n_tvs > n_args      -- Too many for-alls
 496   = substTyWith (take n_args tvs) arg_tys
 497                 (mkForAllTys (drop n_args tvs) rho_ty)
 498   | otherwise           -- Too many type args
 499   = ASSERT2( n_tvs > 0, ppr orig_fun_ty )       -- Zero case gives infnite loop!
 500     applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
 501              (drop n_tvs arg_tys)
 502   where
 503     (tvs, rho_ty) = splitForAllTys orig_fun_ty
 504     n_tvs = length tvs
 505     n_args = length arg_tys
 506 \end{code}
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511 \subsection{Source types}
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 A "source type" is a type that is a separate type as far as the type checker is
 516 concerned, but which has low-level representation as far as the back end is concerned.
 517
 518 Source types are always lifted.
 519
 520 The key function is predTypeRep which gives the representation of a source type:
 521
 522 \begin{code}
 523 mkPredTy :: PredType -> Type
 524 mkPredTy pred = PredTy pred
 525
 526 mkPredTys :: ThetaType -> [Type]
 527 mkPredTys preds = map PredTy preds
 528
 529 predTypeRep :: PredType -> Type
 530 -- Convert a PredType to its "representation type";
 531 -- the post-type-checking type used by all the Core passes of GHC.
 532 -- Unwraps only the outermost level; for example, the result might
 533 -- be a newtype application
 534 predTypeRep (IParam _ ty)     = ty
 535 predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 536         -- Result might be a newtype application, but the consumer will
 537         -- look through that too if necessary
 538 \end{code}
 539
 540
 541 %************************************************************************
 542 %*                                                                      *
 543                 NewTypes
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 \begin{code}
 548 splitRecNewType_maybe :: Type -> Maybe Type
 549 -- Sometimes we want to look through a recursive newtype, and that's what happens here
 550 -- It only strips *one layer* off, so the caller will usually call itself recursively
 551 -- Only applied to types of kind *, hence the newtype is always saturated
 552 splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty'
 553 splitRecNewType_maybe (TyConApp tc tys)
 554   | isNewTyCon tc
 555   = ASSERT( tys `lengthIs` tyConArity tc )      -- splitRecNewType_maybe only be applied
 556                                                 --      to *types* (of kind *)
 557     ASSERT( isRecursiveTyCon tc )               -- Guaranteed by coreView
 558     case newTyConRhs tc of
 559         (tvs, rep_ty) -> ASSERT( length tvs == length tys )
 560                          Just (substTyWith tvs tys rep_ty)
 561
 562 splitRecNewType_maybe other = Nothing
 563 \end{code}
 564
 565
 566 %************************************************************************
 567 %*                                                                      *
 568 \subsection{Kinds and free variables}
 569 %*                                                                      *
 570 %************************************************************************
 571
 572 ---------------------------------------------------------------------
 573                 Finding the kind of a type
 574                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 575 \begin{code}
 576 typeKind :: Type -> Kind
 577
 578 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 579 typeKind (TyConApp tycon tys)   = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
 580 typeKind (NoteTy _ ty)          = typeKind ty
 581 typeKind (PredTy _)             = liftedTypeKind -- Predicates are always
 582                                                  -- represented by lifted types
 583 typeKind (AppTy fun arg)        = kindFunResult (typeKind fun)
 584 typeKind (FunTy arg res)        = liftedTypeKind
 585 typeKind (ForAllTy tv ty)       = typeKind ty
 586 \end{code}
 587
 588
 589 ---------------------------------------------------------------------
 590                 Free variables of a type
 591                 ~~~~~~~~~~~~~~~~~~~~~~~~
 592 \begin{code}
 593 tyVarsOfType :: Type -> TyVarSet
 594 -- NB: for type synonyms tyVarsOfType does *not* expand the synonym
 595 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 596 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 597 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 598 tyVarsOfType (PredTy sty)               = tyVarsOfPred sty
 599 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 600 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 601 tyVarsOfType (ForAllTy tyvar ty)        = delVarSet (tyVarsOfType ty) tyvar
 602
 603 tyVarsOfTypes :: [Type] -> TyVarSet
 604 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 605
 606 tyVarsOfPred :: PredType -> TyVarSet
 607 tyVarsOfPred (IParam _ ty)  = tyVarsOfType ty
 608 tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
 609
 610 tyVarsOfTheta :: ThetaType -> TyVarSet
 611 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
 612
 613 -- Add a Note with the free tyvars to the top of the type
 614 addFreeTyVars :: Type -> Type
 615 addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
 616 addFreeTyVars ty                             = NoteTy (FTVNote (tyVarsOfType ty)) ty
 617 \end{code}
 618
 619
 620 %************************************************************************
 621 %*                                                                      *
 622 \subsection{TidyType}
 623 %*                                                                      *
 624 %************************************************************************
 625
 626 tidyTy tidies up a type for printing in an error message, or in
 627 an interface file.
 628
 629 It doesn't change the uniques at all, just the print names.
 630
 631 \begin{code}
 632 tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 633 tidyTyVarBndr (tidy_env, subst) tyvar
 634   = case tidyOccName tidy_env (getOccName name) of
 635       (tidy', occ') ->  ((tidy', subst'), tyvar')
 636                     where
 637                         subst' = extendVarEnv subst tyvar tyvar'
 638                         tyvar' = setTyVarName tyvar name'
 639                         name'  = tidyNameOcc name occ'
 640   where
 641     name = tyVarName tyvar
 642
 643 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 644 -- Add the free tyvars to the env in tidy form,
 645 -- so that we can tidy the type they are free in
 646 tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
 647
 648 tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 649 tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
 650
 651 tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 652 -- Treat a new tyvar as a binder, and give it a fresh tidy name
 653 tidyOpenTyVar env@(tidy_env, subst) tyvar
 654   = case lookupVarEnv subst tyvar of
 655         Just tyvar' -> (env, tyvar')            -- Already substituted
 656         Nothing     -> tidyTyVarBndr env tyvar  -- Treat it as a binder
 657
 658 tidyType :: TidyEnv -> Type -> Type
 659 tidyType env@(tidy_env, subst) ty
 660   = go ty
 661   where
 662     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 663                                 Nothing  -> TyVarTy tv
 664                                 Just tv' -> TyVarTy tv'
 665     go (TyConApp tycon tys) = let args = map go tys
 666                               in args `seqList` TyConApp tycon args
 667     go (NoteTy note ty)     = (NoteTy $! (go_note note)) $! (go ty)
 668     go (PredTy sty)         = PredTy (tidyPred env sty)
 669     go (AppTy fun arg)      = (AppTy $! (go fun)) $! (go arg)
 670     go (FunTy fun arg)      = (FunTy $! (go fun)) $! (go arg)
 671     go (ForAllTy tv ty)     = ForAllTy tvp $! (tidyType envp ty)
 672                               where
 673                                 (envp, tvp) = tidyTyVarBndr env tv
 674
 675     go_note note@(FTVNote ftvs) = note  -- No need to tidy the free tyvars
 676
 677 tidyTypes env tys = map (tidyType env) tys
 678
 679 tidyPred :: TidyEnv -> PredType -> PredType
 680 tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
 681 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
 682 \end{code}
 683
 684
 685 @tidyOpenType@ grabs the free type variables, tidies them
 686 and then uses @tidyType@ to work over the type itself
 687
 688 \begin{code}
 689 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 690 tidyOpenType env ty
 691   = (env', tidyType env' ty)
 692   where
 693     env' = tidyFreeTyVars env (tyVarsOfType ty)
 694
 695 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 696 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 697
 698 tidyTopType :: Type -> Type
 699 tidyTopType ty = tidyType emptyTidyEnv ty
 700 \end{code}
 701
 702
 703 %************************************************************************
 704 %*                                                                      *
 705                 Tidying Kinds
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 We use a grevious hack for tidying KindVars.  A TidyEnv contains
 710 a (VarEnv Var) substitution, to express the renaming; but
 711 KindVars are not Vars.  The Right Thing ultimately is to make them
 712 into Vars (and perhaps make Kinds into Types), but I just do a hack
 713 here: I make up a TyVar just to remember the new OccName for the
 714 renamed KindVar
 715
 716 \begin{code}
 717 tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
 718 tidyKind env@(tidy_env, subst) (KindVar kvar)
 719   | Just tv <- lookupVarEnv_Directly subst uniq
 720   = (env, KindVar (setKindVarOcc kvar (getOccName tv)))
 721   | otherwise
 722   = ((tidy', subst'), KindVar kvar')
 723   where
 724     uniq = kindVarUniq kvar
 725     (tidy', occ') = tidyOccName tidy_env (kindVarOcc kvar)
 726     kvar'   = setKindVarOcc kvar occ'
 727     fake_tv = mkTyVar tv_name (panic "tidyKind:fake tv kind")
 728     tv_name = mkInternalName uniq occ' noSrcLoc
 729     subst'  = extendVarEnv subst fake_tv fake_tv
 730
 731 tidyKind env (FunKind k1 k2)
 732   = (env2, FunKind k1' k2')
 733   where
 734     (env1, k1') = tidyKind env  k1
 735     (env2, k2') = tidyKind env1 k2
 736
 737 tidyKind env k = (env, k)       -- Atomic kinds
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743 \subsection{Liftedness}
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 \begin{code}
 748 isUnLiftedType :: Type -> Bool
 749         -- isUnLiftedType returns True for forall'd unlifted types:
 750         --      x :: forall a. Int#
 751         -- I found bindings like these were getting floated to the top level.
 752         -- They are pretty bogus types, mind you.  It would be better never to
 753         -- construct them
 754
 755 isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
 756 isUnLiftedType (ForAllTy tv ty)  = isUnLiftedType ty
 757 isUnLiftedType (TyConApp tc _)   = isUnLiftedTyCon tc
 758 isUnLiftedType other             = False
 759
 760 isUnboxedTupleType :: Type -> Bool
 761 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 762                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
 763                            other              -> False
 764
 765 -- Should only be applied to *types*; hence the assert
 766 isAlgType :: Type -> Bool
 767 isAlgType ty = case splitTyConApp_maybe ty of
 768                         Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
 769                                               isAlgTyCon tc
 770                         other              -> False
 771 \end{code}
 772
 773 @isStrictType@ computes whether an argument (or let RHS) should
 774 be computed strictly or lazily, based only on its type.
 775 Works just like isUnLiftedType, except that it has a special case
 776 for dictionaries.  Since it takes account of ClassP, you might think
 777 this function should be in TcType, but isStrictType is used by DataCon,
 778 which is below TcType in the hierarchy, so it's convenient to put it here.
 779
 780 \begin{code}
 781 isStrictType (PredTy pred)     = isStrictPred pred
 782 isStrictType ty | Just ty' <- coreView ty = isStrictType ty'
 783 isStrictType (ForAllTy tv ty)  = isStrictType ty
 784 isStrictType (TyConApp tc _)   = isUnLiftedTyCon tc
 785 isStrictType other             = False
 786
 787 isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
 788 isStrictPred other           = False
 789         -- We may be strict in dictionary types, but only if it
 790         -- has more than one component.
 791         -- [Being strict in a single-component dictionary risks
 792         --  poking the dictionary component, which is wrong.]
 793 \end{code}
 794
 795 \begin{code}
 796 isPrimitiveType :: Type -> Bool
 797 -- Returns types that are opaque to Haskell.
 798 -- Most of these are unlifted, but now that we interact with .NET, we
 799 -- may have primtive (foreign-imported) types that are lifted
 800 isPrimitiveType ty = case splitTyConApp_maybe ty of
 801                         Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
 802                                               isPrimTyCon tc
 803                         other              -> False
 804 \end{code}
 805
 806
 807 %************************************************************************
 808 %*                                                                      *
 809 \subsection{Sequencing on types
 810 %*                                                                      *
 811 %************************************************************************
 812
 813 \begin{code}
 814 seqType :: Type -> ()
 815 seqType (TyVarTy tv)      = tv `seq` ()
 816 seqType (AppTy t1 t2)     = seqType t1 `seq` seqType t2
 817 seqType (FunTy t1 t2)     = seqType t1 `seq` seqType t2
 818 seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
 819 seqType (PredTy p)        = seqPred p
 820 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 821 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
 822
 823 seqTypes :: [Type] -> ()
 824 seqTypes []       = ()
 825 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
 826
 827 seqNote :: TyNote -> ()
 828 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 829
 830 seqPred :: PredType -> ()
 831 seqPred (ClassP c tys) = c  `seq` seqTypes tys
 832 seqPred (IParam n ty)  = n  `seq` seqType ty
 833 \end{code}
 834
 835
 836 %************************************************************************
 837 %*                                                                      *
 838                 Equality for Core types
 839         (We don't use instances so that we know where it happens)
 840 %*                                                                      *
 841 %************************************************************************
 842
 843 Note that eqType works right even for partial applications of newtypes.
 844 See Note [Newtype eta] in TyCon.lhs
 845
 846 \begin{code}
 847 coreEqType :: Type -> Type -> Bool
 848 coreEqType t1 t2
 849   = eq rn_env t1 t2
 850   where
 851     rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
 852
 853     eq env (TyVarTy tv1)       (TyVarTy tv2)     = rnOccL env tv1 == rnOccR env tv2
 854     eq env (ForAllTy tv1 t1)   (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2
 855     eq env (AppTy s1 t1)       (AppTy s2 t2)     = eq env s1 s2 && eq env t1 t2
 856     eq env (FunTy s1 t1)       (FunTy s2 t2)     = eq env s1 s2 && eq env t1 t2
 857     eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2)
 858         | tc1 == tc2, all2 (eq env) tys1 tys2 = True
 859                         -- The lengths should be equal because
 860                         -- the two types have the same kind
 861         -- NB: if the type constructors differ that does not
 862         --     necessarily mean that the types aren't equal
 863         --     (synonyms, newtypes)
 864         -- Even if the type constructors are the same, but the arguments
 865         -- differ, the two types could be the same (e.g. if the arg is just
 866         -- ignored in the RHS).  In both these cases we fall through to an
 867         -- attempt to expand one side or the other.
 868
 869         -- Now deal with newtypes, synonyms, pred-tys
 870     eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2
 871                  | Just t2' <- coreView t2 = eq env t1 t2'
 872
 873         -- Fall through case; not equal!
 874     eq env t1 t2 = False
 875 \end{code}
 876
 877
 878 %************************************************************************
 879 %*                                                                      *
 880                 Comparision for source types
 881         (We don't use instances so that we know where it happens)
 882 %*                                                                      *
 883 %************************************************************************
 884
 885 Note that
 886         tcEqType, tcCmpType
 887 do *not* look through newtypes, PredTypes
 888
 889 \begin{code}
 890 tcEqType :: Type -> Type -> Bool
 891 tcEqType t1 t2 = isEqual $ cmpType t1 t2
 892
 893 tcEqTypes :: [Type] -> [Type] -> Bool
 894 tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
 895
 896 tcCmpType :: Type -> Type -> Ordering
 897 tcCmpType t1 t2 = cmpType t1 t2
 898
 899 tcCmpTypes :: [Type] -> [Type] -> Ordering
 900 tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
 901
 902 tcEqPred :: PredType -> PredType -> Bool
 903 tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
 904
 905 tcCmpPred :: PredType -> PredType -> Ordering
 906 tcCmpPred p1 p2 = cmpPred p1 p2
 907
 908 tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool
 909 tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
 910 \end{code}
 911
 912 Now here comes the real worker
 913
 914 \begin{code}
 915 cmpType :: Type -> Type -> Ordering
 916 cmpType t1 t2 = cmpTypeX rn_env t1 t2
 917   where
 918     rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
 919
 920 cmpTypes :: [Type] -> [Type] -> Ordering
 921 cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2
 922   where
 923     rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2))
 924
 925 cmpPred :: PredType -> PredType -> Ordering
 926 cmpPred p1 p2 = cmpPredX rn_env p1 p2
 927   where
 928     rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2))
 929
 930 cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse
 931 cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2
 932                    | Just t2' <- tcView t2 = cmpTypeX env t1 t2'
 933
 934 cmpTypeX env (TyVarTy tv1)       (TyVarTy tv2)       = rnOccL env tv1 `compare` rnOccR env tv2
 935 cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
 936 cmpTypeX env (AppTy s1 t1)       (AppTy s2 t2)       = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
 937 cmpTypeX env (FunTy s1 t1)       (FunTy s2 t2)       = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
 938 cmpTypeX env (PredTy p1)         (PredTy p2)         = cmpPredX env p1 p2
 939 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2
 940 cmpTypeX env t1                 (NoteTy _ t2)        = cmpTypeX env t1 t2
 941
 942     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
 943 cmpTypeX env (AppTy _ _) (TyVarTy _) = GT
 944
 945 cmpTypeX env (FunTy _ _) (TyVarTy _) = GT
 946 cmpTypeX env (FunTy _ _) (AppTy _ _) = GT
 947
 948 cmpTypeX env (TyConApp _ _) (TyVarTy _) = GT
 949 cmpTypeX env (TyConApp _ _) (AppTy _ _) = GT
 950 cmpTypeX env (TyConApp _ _) (FunTy _ _) = GT
 951
 952 cmpTypeX env (ForAllTy _ _) (TyVarTy _)    = GT
 953 cmpTypeX env (ForAllTy _ _) (AppTy _ _)    = GT
 954 cmpTypeX env (ForAllTy _ _) (FunTy _ _)    = GT
 955 cmpTypeX env (ForAllTy _ _) (TyConApp _ _) = GT
 956
 957 cmpTypeX env (PredTy _)   t2            = GT
 958
 959 cmpTypeX env _ _ = LT
 960
 961 -------------
 962 cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
 963 cmpTypesX env []        []        = EQ
 964 cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2
 965 cmpTypesX env []        tys       = LT
 966 cmpTypesX env ty        []        = GT
 967
 968 -------------
 969 cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering
 970 cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2
 971         -- Compare types as well as names for implicit parameters
 972         -- This comparison is used exclusively (I think) for the
 973         -- finite map built in TcSimplify
 974 cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2
 975 cmpPredX env (IParam _ _)     (ClassP _ _)     = LT
 976 cmpPredX env (ClassP _ _)     (IParam _ _)     = GT
 977 \end{code}
 978
 979 PredTypes are used as a FM key in TcSimplify,
 980 so we take the easy path and make them an instance of Ord
 981
 982 \begin{code}
 983 instance Eq  PredType where { (==)    = tcEqPred }
 984 instance Ord PredType where { compare = tcCmpPred }
 985 \end{code}
 986
 987
 988 %************************************************************************
 989 %*                                                                      *
 990                 Type substitutions
 991 %*                                                                      *
 992 %************************************************************************
 993
 994 \begin{code}
 995 data TvSubst
 996   = TvSubst InScopeSet  -- The in-scope type variables
 997             TvSubstEnv  -- The substitution itself
 998                         -- See Note [Apply Once]
 999
1000 {- ----------------------------------------------------------
1001                 Note [Apply Once]
1002
1003 We use TvSubsts to instantiate things, and we might instantiate
1004         forall a b. ty
1005 \with the types
1006         [a, b], or [b, a].
1007 So the substition might go [a->b, b->a].  A similar situation arises in Core
1008 when we find a beta redex like
1009         (/\ a /\ b -> e) b a
1010 Then we also end up with a substition that permutes type variables. Other
1011 variations happen to; for example [a -> (a, b)].
1012
1013         ***************************************************
1014         *** So a TvSubst must be applied precisely once ***
1015         ***************************************************
1016
1017 A TvSubst is not idempotent, but, unlike the non-idempotent substitution
1018 we use during unifications, it must not be repeatedly applied.
1019 -------------------------------------------------------------- -}
1020
1021
1022 type TvSubstEnv = TyVarEnv Type
1023         -- A TvSubstEnv is used both inside a TvSubst (with the apply-once
1024         -- invariant discussed in Note [Apply Once]), and also independently
1025         -- in the middle of matching, and unification (see Types.Unify)
1026         -- So you have to look at the context to know if it's idempotent or
1027         -- apply-once or whatever
1028 emptyTvSubstEnv :: TvSubstEnv
1029 emptyTvSubstEnv = emptyVarEnv
1030
1031 composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv
1032 -- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1
1033 -- It assumes that both are idempotent
1034 -- Typically, env1 is the refinement to a base substitution env2
1035 composeTvSubst in_scope env1 env2
1036   = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2
1037         -- First apply env1 to the range of env2
1038         -- Then combine the two, making sure that env1 loses if
1039         -- both bind the same variable; that's why env1 is the
1040         --  *left* argument to plusVarEnv, because the right arg wins
1041   where
1042     subst1 = TvSubst in_scope env1
1043
1044 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
1045
1046 isEmptyTvSubst :: TvSubst -> Bool
1047 isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
1048
1049 mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
1050 mkTvSubst = TvSubst
1051
1052 getTvSubstEnv :: TvSubst -> TvSubstEnv
1053 getTvSubstEnv (TvSubst _ env) = env
1054
1055 getTvInScope :: TvSubst -> InScopeSet
1056 getTvInScope (TvSubst in_scope _) = in_scope
1057
1058 isInScope :: Var -> TvSubst -> Bool
1059 isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope
1060
1061 notElemTvSubst :: TyVar -> TvSubst -> Bool
1062 notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
1063
1064 setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
1065 setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
1066
1067 extendTvInScope :: TvSubst -> [Var] -> TvSubst
1068 extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
1069
1070 extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
1071 extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
1072
1073 extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst
1074 extendTvSubstList (TvSubst in_scope env) tvs tys
1075   = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
1076
1077 -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
1078 -- the types given; but it's just a thunk so with a bit of luck
1079 -- it'll never be evaluated
1080
1081 mkOpenTvSubst :: TvSubstEnv -> TvSubst
1082 mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
1083
1084 zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst
1085 zipOpenTvSubst tyvars tys
1086 #ifdef DEBUG
1087   | length tyvars /= length tys
1088   = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
1089   | otherwise
1090 #endif
1091   = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys)
1092
1093 -- mkTopTvSubst is called when doing top-level substitutions.
1094 -- Here we expect that the free vars of the range of the
1095 -- substitution will be empty.
1096 mkTopTvSubst :: [(TyVar, Type)] -> TvSubst
1097 mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs)
1098
1099 zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst
1100 zipTopTvSubst tyvars tys
1101 #ifdef DEBUG
1102   | length tyvars /= length tys
1103   = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
1104   | otherwise
1105 #endif
1106   = TvSubst emptyInScopeSet (zipTyEnv tyvars tys)
1107
1108 zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
1109 zipTyEnv tyvars tys
1110 #ifdef DEBUG
1111   | length tyvars /= length tys
1112   = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
1113   | otherwise
1114 #endif
1115   = zip_ty_env tyvars tys emptyVarEnv
1116
1117 -- Later substitutions in the list over-ride earlier ones,
1118 -- but there should be no loops
1119 zip_ty_env []       []       env = env
1120 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty)
1121         -- There used to be a special case for when
1122         --      ty == TyVarTy tv
1123         -- (a not-uncommon case) in which case the substitution was dropped.
1124         -- But the type-tidier changes the print-name of a type variable without
1125         -- changing the unique, and that led to a bug.   Why?  Pre-tidying, we had
1126         -- a type {Foo t}, where Foo is a one-method class.  So Foo is really a newtype.
1127         -- And it happened that t was the type variable of the class.  Post-tiding,
1128         -- it got turned into {Foo t2}.  The ext-core printer expanded this using
1129         -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
1130         -- and so generated a rep type mentioning t not t2.
1131         --
1132         -- Simplest fix is to nuke the "optimisation"
1133 zip_ty_env tvs      tys      env   = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env
1134 -- zip_ty_env _ _ env = env
1135
1136 instance Outputable TvSubst where
1137   ppr (TvSubst ins env)
1138     = sep[ ptext SLIT("<TvSubst"),
1139            nest 2 (ptext SLIT("In scope:") <+> ppr ins),
1140            nest 2 (ptext SLIT("Env:") <+> ppr env) ]
1141 \end{code}
1142
1143 %************************************************************************
1144 %*                                                                      *
1145                 Performing type substitutions
1146 %*                                                                      *
1147 %************************************************************************
1148
1149 \begin{code}
1150 substTyWith :: [TyVar] -> [Type] -> Type -> Type
1151 substTyWith tvs tys = ASSERT( length tvs == length tys )
1152                       substTy (zipOpenTvSubst tvs tys)
1153
1154 substTy :: TvSubst -> Type  -> Type
1155 substTy subst ty | isEmptyTvSubst subst = ty
1156                  | otherwise            = subst_ty subst ty
1157
1158 substTys :: TvSubst -> [Type] -> [Type]
1159 substTys subst tys | isEmptyTvSubst subst = tys
1160                    | otherwise            = map (subst_ty subst) tys
1161
1162 substTheta :: TvSubst -> ThetaType -> ThetaType
1163 substTheta subst theta
1164   | isEmptyTvSubst subst = theta
1165   | otherwise            = map (substPred subst) theta
1166
1167 substPred :: TvSubst -> PredType -> PredType
1168 substPred subst (IParam n ty)     = IParam n (subst_ty subst ty)
1169 substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
1170
1171 deShadowTy :: TyVarSet -> Type -> Type  -- Remove any nested binders mentioning tvs
1172 deShadowTy tvs ty
1173   = subst_ty (mkTvSubst in_scope emptyTvSubstEnv) ty
1174   where
1175     in_scope = mkInScopeSet tvs
1176
1177 -- Note that the in_scope set is poked only if we hit a forall
1178 -- so it may often never be fully computed
1179 subst_ty subst ty
1180    = go ty
1181   where
1182     go (TyVarTy tv)                = substTyVar subst tv
1183     go (TyConApp tc tys)           = let args = map go tys
1184                                      in  args `seqList` TyConApp tc args
1185
1186     go (PredTy p)                  = PredTy $! (substPred subst p)
1187
1188     go (NoteTy (FTVNote _) ty2)    = go ty2             -- Discard the free tyvar note
1189
1190     go (FunTy arg res)             = (FunTy $! (go arg)) $! (go res)
1191     go (AppTy fun arg)             = mkAppTy (go fun) $! (go arg)
1192                 -- The mkAppTy smart constructor is important
1193                 -- we might be replacing (a Int), represented with App
1194                 -- by [Int], represented with TyConApp
1195     go (ForAllTy tv ty)            = case substTyVarBndr subst tv of
1196                                         (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
1197
1198 substTyVar :: TvSubst -> TyVar  -> Type
1199 substTyVar subst tv
1200   = case lookupTyVar subst tv of
1201         Nothing  -> TyVarTy tv
1202         Just ty' -> ty' -- See Note [Apply Once]
1203
1204 lookupTyVar :: TvSubst -> TyVar  -> Maybe Type
1205 lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
1206
1207 substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
1208 substTyVarBndr subst@(TvSubst in_scope env) old_var
1209   | old_var == new_var  -- No need to clone
1210                         -- But we *must* zap any current substitution for the variable.
1211                         --  For example:
1212                         --      (\x.e) with id_subst = [x |-> e']
1213                         -- Here we must simply zap the substitution for x
1214                         --
1215                         -- The new_id isn't cloned, but it may have a different type
1216                         -- etc, so we must return it, not the old id
1217   = (TvSubst (in_scope `extendInScopeSet` new_var)
1218              (delVarEnv env old_var),
1219      new_var)
1220
1221   | otherwise   -- The new binder is in scope so
1222                 -- we'd better rename it away from the in-scope variables
1223                 -- Extending the substitution to do this renaming also
1224                 -- has the (correct) effect of discarding any existing
1225                 -- substitution for that variable
1226   = (TvSubst (in_scope `extendInScopeSet` new_var)
1227              (extendVarEnv env old_var (TyVarTy new_var)),
1228      new_var)
1229   where
1230     new_var = uniqAway in_scope old_var
1231         -- The uniqAway part makes sure the new variable is not already in scope
1232 \end{code}