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