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