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