723ce0671e94fe00340e24e0731a7579453789fc
[ghc.git] / compiler / typecheck / Inst.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 The @Inst@ type: dictionaries or method instances
7
8 \begin{code}
9 {-# LANGUAGE CPP #-}
10 {-# OPTIONS_GHC -fno-warn-tabs #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and
13 -- detab the module (please do the detabbing in a separate patch). See
14 --     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
15 -- for details
16
17 module Inst ( 
18        deeplySkolemise, 
19        deeplyInstantiate, instCall, instStupidTheta,
20        emitWanted, emitWanteds,
21
22        newOverloadedLit, mkOverLit, 
23      
24        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
25        tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
26        tcSyntaxName,
27
28        -- Simple functions over evidence variables
29        tyVarsOfWC, tyVarsOfBag, 
30        tyVarsOfCt, tyVarsOfCts, 
31
32        tidyEvVar, tidyCt, tidySkolemInfo
33     ) where
34
35 #include "HsVersions.h"
36
37 import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
38 import {-# SOURCE #-}   TcUnify( unifyType )
39
40 import FastString
41 import HsSyn
42 import TcHsSyn
43 import TcRnMonad
44 import TcEnv
45 import TcEvidence
46 import InstEnv
47 import FunDeps
48 import TcMType
49 import Type
50 import Coercion ( Role(..) )
51 import TcType
52 import Unify
53 import HscTypes
54 import Id
55 import Name
56 import Var      ( EvVar, varType, setVarType )
57 import VarEnv
58 import VarSet
59 import PrelNames
60 import SrcLoc
61 import DynFlags
62 import Bag
63 import Maybes
64 import Util
65 import Outputable
66 import Data.List( mapAccumL )
67 \end{code}
68
69
70
71 %************************************************************************
72 %*                                                                      *
73                 Emitting constraints
74 %*                                                                      *
75 %************************************************************************
76
77 \begin{code}
78 emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
79 emitWanteds origin theta = mapM (emitWanted origin) theta
80
81 emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
82 emitWanted origin pred 
83   = do { loc <- getCtLoc origin
84        ; ev  <- newWantedEvVar pred
85        ; emitFlat $ mkNonCanonical $
86              CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
87        ; return ev }
88
89 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
90 -- Used when Name is the wired-in name for a wired-in class method,
91 -- so the caller knows its type for sure, which should be of form
92 --    forall a. C a => <blah>
93 -- newMethodFromName is supposed to instantiate just the outer 
94 -- type variable and constraint
95
96 newMethodFromName origin name inst_ty
97   = do { id <- tcLookupId name
98               -- Use tcLookupId not tcLookupGlobalId; the method is almost
99               -- always a class op, but with -XRebindableSyntax GHC is
100               -- meant to find whatever thing is in scope, and that may
101               -- be an ordinary function. 
102
103        ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
104              (the_tv:rest) = tvs
105              subst = zipOpenTvSubst [the_tv] [inst_ty]
106
107        ; wrap <- ASSERT( null rest && isSingleton theta )
108                  instCall origin [inst_ty] (substTheta subst theta)
109        ; return (mkHsWrap wrap (HsVar id)) }
110 \end{code}
111
112
113 %************************************************************************
114 %*                                                                      *
115         Deep instantiation and skolemisation
116 %*                                                                      *
117 %************************************************************************
118
119 Note [Deep skolemisation]
120 ~~~~~~~~~~~~~~~~~~~~~~~~~
121 deeplySkolemise decomposes and skolemises a type, returning a type
122 with all its arrows visible (ie not buried under foralls)
123
124 Examples:
125
126   deeplySkolemise (Int -> forall a. Ord a => blah)  
127     =  ( wp, [a], [d:Ord a], Int -> blah )
128     where wp = \x:Int. /\a. \(d:Ord a). <hole> x
129
130   deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)  
131     =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
132     where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
133
134 In general,
135   if      deeplySkolemise ty = (wrap, tvs, evs, rho)
136     and   e :: rho
137   then    wrap e :: ty
138     and   'wrap' binds tvs, evs
139
140 ToDo: this eta-abstraction plays fast and loose with termination,
141       because it can introduce extra lambdas.  Maybe add a `seq` to
142       fix this
143
144
145 \begin{code}
146 deeplySkolemise
147   :: TcSigmaType
148   -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
149
150 deeplySkolemise ty
151   | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
152   = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
153        ; (subst, tvs1) <- tcInstSkolTyVars tvs
154        ; ev_vars1 <- newEvVars (substTheta subst theta)
155        ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
156        ; return ( mkWpLams ids1
157                    <.> mkWpTyLams tvs1
158                    <.> mkWpLams ev_vars1
159                    <.> wrap
160                    <.> mkWpEvVarApps ids1
161                 , tvs1     ++ tvs2
162                 , ev_vars1 ++ ev_vars2
163                 , mkFunTys arg_tys rho ) }
164
165   | otherwise
166   = return (idHsWrapper, [], [], ty)
167
168 deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
169 --   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
170 -- In general if
171 -- if    deeplyInstantiate ty = (wrap, rho)
172 -- and   e :: ty
173 -- then  wrap e :: rho
174
175 deeplyInstantiate orig ty
176   | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
177   = do { (_, tys, subst) <- tcInstTyVars tvs
178        ; ids1  <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
179        ; wrap1 <- instCall orig tys (substTheta subst theta)
180        ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
181        ; return (mkWpLams ids1 
182                     <.> wrap2
183                     <.> wrap1 
184                     <.> mkWpEvVarApps ids1,
185                  mkFunTys arg_tys rho2) }
186
187   | otherwise = return (idHsWrapper, ty)
188 \end{code}
189
190
191 %************************************************************************
192 %*                                                                      *
193             Instantiating a call
194 %*                                                                      *
195 %************************************************************************
196
197 \begin{code}
198 ----------------
199 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
200 -- Instantiate the constraints of a call
201 --      (instCall o tys theta)
202 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
203 -- (b) Throws these dictionaries into the LIE
204 -- (c) Returns an HsWrapper ([.] tys dicts)
205
206 instCall orig tys theta 
207   = do  { dict_app <- instCallConstraints orig theta
208         ; return (dict_app <.> mkWpTyApps tys) }
209
210 ----------------
211 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
212 -- Instantiates the TcTheta, puts all constraints thereby generated
213 -- into the LIE, and returns a HsWrapper to enclose the call site.
214
215 instCallConstraints orig preds
216   | null preds 
217   = return idHsWrapper
218   | otherwise
219   = do { evs <- mapM go preds
220        ; traceTc "instCallConstraints" (ppr evs)
221        ; return (mkWpEvApps evs) }
222   where
223     go pred 
224      | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
225      = do  { co <- unifyType ty1 ty2
226            ; return (EvCoercion co) }
227      | otherwise
228      = do { ev_var <- emitWanted orig pred
229           ; return (EvId ev_var) }
230
231 ----------------
232 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
233 -- Similar to instCall, but only emit the constraints in the LIE
234 -- Used exclusively for the 'stupid theta' of a data constructor
235 instStupidTheta orig theta
236   = do  { _co <- instCallConstraints orig theta -- Discard the coercion
237         ; return () }
238 \end{code}
239
240 %************************************************************************
241 %*                                                                      *
242                 Literals
243 %*                                                                      *
244 %************************************************************************
245
246 In newOverloadedLit we convert directly to an Int or Integer if we
247 know that's what we want.  This may save some time, by not
248 temporarily generating overloaded literals, but it won't catch all
249 cases (the rest are caught in lookupInst).
250
251 \begin{code}
252 newOverloadedLit :: CtOrigin
253                  -> HsOverLit Name
254                  -> TcRhoType
255                  -> TcM (HsOverLit TcId)
256 newOverloadedLit orig lit res_ty
257     = do dflags <- getDynFlags
258          newOverloadedLit' dflags orig lit res_ty
259
260 newOverloadedLit' :: DynFlags
261                   -> CtOrigin
262                   -> HsOverLit Name
263                   -> TcRhoType
264                   -> TcM (HsOverLit TcId)
265 newOverloadedLit' dflags orig
266   lit@(OverLit { ol_val = val, ol_rebindable = rebindable
267                , ol_witness = meth_name }) res_ty
268
269   | not rebindable
270   , Just expr <- shortCutLit dflags val res_ty 
271         -- Do not generate a LitInst for rebindable syntax.  
272         -- Reason: If we do, tcSimplify will call lookupInst, which
273         --         will call tcSyntaxName, which does unification, 
274         --         which tcSimplify doesn't like
275   = return (lit { ol_witness = expr, ol_type = res_ty })
276
277   | otherwise
278   = do  { hs_lit <- mkOverLit val
279         ; let lit_ty = hsLitType hs_lit
280         ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
281                 -- Overloaded literals must have liftedTypeKind, because
282                 -- we're instantiating an overloaded function here,
283                 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
284                 -- However this'll be picked up by tcSyntaxOp if necessary
285         ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
286         ; return (lit { ol_witness = witness, ol_type = res_ty }) }
287
288 ------------
289 mkOverLit :: OverLitVal -> TcM HsLit
290 mkOverLit (HsIntegral i) 
291   = do  { integer_ty <- tcMetaTy integerTyConName
292         ; return (HsInteger i integer_ty) }
293
294 mkOverLit (HsFractional r)
295   = do  { rat_ty <- tcMetaTy rationalTyConName
296         ; return (HsRat r rat_ty) }
297
298 mkOverLit (HsIsString s) = return (HsString s)
299 \end{code}
300
301
302
303
304 %************************************************************************
305 %*                                                                      *
306                 Re-mappable syntax
307     
308      Used only for arrow syntax -- find a way to nuke this
309 %*                                                                      *
310 %************************************************************************
311
312 Suppose we are doing the -XRebindableSyntax thing, and we encounter
313 a do-expression.  We have to find (>>) in the current environment, which is
314 done by the rename. Then we have to check that it has the same type as
315 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
316 this:
317
318   (>>) :: HB m n mn => m a -> n b -> mn b
319
320 So the idea is to generate a local binding for (>>), thus:
321
322         let then72 :: forall a b. m a -> m b -> m b
323             then72 = ...something involving the user's (>>)...
324         in
325         ...the do-expression...
326
327 Now the do-expression can proceed using then72, which has exactly
328 the expected type.
329
330 In fact tcSyntaxName just generates the RHS for then72, because we only
331 want an actual binding in the do-expression case. For literals, we can 
332 just use the expression inline.
333
334 \begin{code}
335 tcSyntaxName :: CtOrigin
336              -> TcType                  -- Type to instantiate it at
337              -> (Name, HsExpr Name)     -- (Standard name, user name)
338              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
339 -- USED ONLY FOR CmdTop (sigh) ***
340 -- See Note [CmdSyntaxTable] in HsExpr
341
342 tcSyntaxName orig ty (std_nm, HsVar user_nm)
343   | std_nm == user_nm
344   = do rhs <- newMethodFromName orig std_nm ty
345        return (std_nm, rhs)
346
347 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
348     std_id <- tcLookupId std_nm
349     let 
350         -- C.f. newMethodAtLoc
351         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
352         sigma1          = substTyWith [tv] [ty] tau
353         -- Actually, the "tau-type" might be a sigma-type in the
354         -- case of locally-polymorphic methods.
355
356     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
357
358         -- Check that the user-supplied thing has the
359         -- same type as the standard one.  
360         -- Tiresome jiggling because tcCheckSigma takes a located expression
361      span <- getSrcSpanM
362      expr <- tcPolyExpr (L span user_nm_expr) sigma1
363      return (std_nm, unLoc expr)
364
365 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
366                -> TcRn (TidyEnv, SDoc)
367 syntaxNameCtxt name orig ty tidy_env
368   = do { inst_loc <- getCtLoc orig
369        ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
370                           <+> ptext (sLit "(needed by a syntactic construct)")
371                         , nest 2 (ptext (sLit "has the required type:")
372                                   <+> ppr (tidyType tidy_env ty))
373                         , nest 2 (pprArisingAt inst_loc) ]
374        ; return (tidy_env, msg) }
375 \end{code}
376
377
378 %************************************************************************
379 %*                                                                      *
380                 Instances
381 %*                                                                      *
382 %************************************************************************
383
384 \begin{code}
385 getOverlapFlag :: TcM OverlapFlag
386 getOverlapFlag
387   = do  { dflags <- getDynFlags
388         ; let overlap_ok    = xopt Opt_OverlappingInstances dflags
389               incoherent_ok = xopt Opt_IncoherentInstances  dflags
390               use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
391                                   , overlapMode   = x }
392               overlap_flag | incoherent_ok = use Incoherent
393                            | overlap_ok    = use Overlaps
394                            | otherwise     = use NoOverlap
395
396         ; return overlap_flag }
397
398 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
399 -- Gets both the external-package inst-env
400 -- and the home-pkg inst env (includes module being compiled)
401 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
402                      return (eps_inst_env eps, tcg_inst_env env) }
403
404 tcGetInsts :: TcM [ClsInst]
405 -- Gets the local class instances.
406 tcGetInsts = fmap tcg_insts getGblEnv
407
408 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
409   -- Add new locally-defined instances
410 tcExtendLocalInstEnv dfuns thing_inside
411  = do { traceDFuns dfuns
412       ; env <- getGblEnv
413       ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
414       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
415                          tcg_inst_env = inst_env' }
416       ; setGblEnv env' thing_inside }
417
418 addLocalInst :: InstEnv -> ClsInst -> TcM InstEnv
419 -- Check that the proposed new instance is OK, 
420 -- and then add it to the home inst env
421 -- If overwrite_inst, then we can overwrite a direct match
422 addLocalInst home_ie ispec
423    = do {
424          -- Instantiate the dfun type so that we extend the instance
425          -- envt with completely fresh template variables
426          -- This is important because the template variables must
427          -- not overlap with anything in the things being looked up
428          -- (since we do unification).  
429              --
430              -- We use tcInstSkolType because we don't want to allocate fresh
431              --  *meta* type variables.
432              --
433              -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
434              -- these variables must be bindable by tcUnifyTys.  See
435              -- the call to tcUnifyTys in InstEnv, and the special
436              -- treatment that instanceBindFun gives to isOverlappableTyVar
437              -- This is absurdly delicate.
438
439              -- Load imported instances, so that we report
440              -- duplicates correctly
441            eps <- getEps
442          ; let inst_envs = (eps_inst_env eps, home_ie)
443                (tvs, cls, tys) = instanceHead ispec
444
445              -- Check functional dependencies
446          ; case checkFunDeps inst_envs ispec of
447              Just specs -> funDepErr ispec specs
448              Nothing    -> return ()
449
450              -- Check for duplicate instance decls
451          ; let (matches, unifs, _) = lookupInstEnv inst_envs cls tys
452                dup_ispecs = [ dup_ispec 
453                             | (dup_ispec, _) <- matches
454                             , let dup_tys = is_tys dup_ispec
455                             , isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)]
456                              
457              -- Find memebers of the match list which ispec itself matches.
458              -- If the match is 2-way, it's a duplicate
459              -- If it's a duplicate, but we can overwrite home package dups, then overwrite
460          ; isGHCi <- getIsGHCi
461          ; overlapFlag <- getOverlapFlag
462          ; case isGHCi of
463              False -> case dup_ispecs of
464                  dup : _ -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec)
465                  []      -> return (extendInstEnv home_ie ispec)
466              True  -> case (dup_ispecs, home_ie_matches, unifs, overlapMode overlapFlag) of
467                  (_, _:_, _, _)      -> return (overwriteInstEnv home_ie ispec)
468                  (dup:_, [], _, _)   -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec)
469                  ([], _, u:_, NoOverlap)    -> overlappingInstErr ispec u >> return (extendInstEnv home_ie ispec)
470                  _                   -> return (extendInstEnv home_ie ispec)
471                where (homematches, _) = lookupInstEnv' home_ie cls tys
472                      home_ie_matches = [ dup_ispec 
473                          | (dup_ispec, _) <- homematches
474                          , let dup_tys = is_tys dup_ispec
475                          , isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)] }
476
477 traceDFuns :: [ClsInst] -> TcRn ()
478 traceDFuns ispecs
479   = traceTc "Adding instances:" (vcat (map pp ispecs))
480   where
481     pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
482                   2 (ppr ispec)
483         -- Print the dfun name itself too
484
485 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
486 funDepErr ispec ispecs
487   = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
488                     (ispec : ispecs)
489
490 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
491 dupInstErr ispec dup_ispec
492   = addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
493                     [ispec, dup_ispec]
494
495 overlappingInstErr :: ClsInst -> ClsInst -> TcRn ()
496 overlappingInstErr ispec dup_ispec
497   = addClsInstsErr (ptext (sLit "Overlapping instance declarations:")) 
498                     [ispec, dup_ispec]
499
500 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
501 addClsInstsErr herald ispecs
502   = setSrcSpan (getSrcSpan (head sorted)) $
503     addErr (hang herald 2 (pprInstances sorted))
504  where
505    sorted = sortWith getSrcLoc ispecs
506    -- The sortWith just arranges that instances are dislayed in order
507    -- of source location, which reduced wobbling in error messages,
508    -- and is better for users
509 \end{code}
510
511 %************************************************************************
512 %*                                                                      *
513         Simple functions over evidence variables
514 %*                                                                      *
515 %************************************************************************
516
517 \begin{code}
518 ---------------- Getting free tyvars -------------------------
519 tyVarsOfCt :: Ct -> TcTyVarSet
520 -- NB: the 
521 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
522 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
523 tyVarsOfCt (CDictCan { cc_tyargs = tys })               = tyVarsOfTypes tys
524 tyVarsOfCt (CIrredEvCan { cc_ev = ev })                 = tyVarsOfType (ctEvPred ev)
525 tyVarsOfCt (CHoleCan { cc_ev = ev })                    = tyVarsOfType (ctEvPred ev)
526 tyVarsOfCt (CNonCanonical { cc_ev = ev })               = tyVarsOfType (ctEvPred ev)
527
528 tyVarsOfCts :: Cts -> TcTyVarSet
529 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
530
531 tyVarsOfWC :: WantedConstraints -> TyVarSet
532 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
533 tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
534   = tyVarsOfCts flat `unionVarSet`
535     tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
536     tyVarsOfCts insol
537
538 tyVarsOfImplic :: Implication -> TyVarSet
539 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
540 tyVarsOfImplic (Implic { ic_skols = skols, ic_fsks = fsks
541                              , ic_given = givens, ic_wanted = wanted })
542   = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
543     `delVarSetList` skols `delVarSetList` fsks
544
545 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
546 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
547
548 ---------------- Tidying -------------------------
549
550 tidyCt :: TidyEnv -> Ct -> Ct
551 -- Used only in error reporting
552 -- Also converts it to non-canonical
553 tidyCt env ct 
554   = case ct of
555      CHoleCan { cc_ev = ev }
556        -> ct { cc_ev = tidy_ev env ev }
557      _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))
558   where 
559     tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
560      -- NB: we do not tidy the ctev_evtm/var field because we don't 
561      --     show it in error messages
562     tidy_ev env ctev@(CtGiven { ctev_pred = pred })
563       = ctev { ctev_pred = tidyType env pred }
564     tidy_ev env ctev@(CtWanted { ctev_pred = pred })
565       = ctev { ctev_pred = tidyType env pred }
566     tidy_ev env ctev@(CtDerived { ctev_pred = pred })
567       = ctev { ctev_pred = tidyType env pred }
568
569 tidyEvVar :: TidyEnv -> EvVar -> EvVar
570 tidyEvVar env var = setVarType var (tidyType env (varType var))
571
572 tidySkolemInfo :: TidyEnv -> SkolemInfo -> (TidyEnv, SkolemInfo)
573 tidySkolemInfo env (SigSkol cx ty) 
574   = (env', SigSkol cx ty')
575   where
576     (env', ty') = tidyOpenType env ty
577
578 tidySkolemInfo env (InferSkol ids) 
579   = (env', InferSkol ids')
580   where
581     (env', ids') = mapAccumL do_one env ids
582     do_one env (name, ty) = (env', (name, ty'))
583        where
584          (env', ty') = tidyOpenType env ty
585
586 tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) 
587   = (env1, UnifyForAllSkol skol_tvs' ty')
588   where
589     env1 = tidyFreeTyVars env (tyVarsOfType ty `delVarSetList` skol_tvs)
590     (env2, skol_tvs') = tidyTyVarBndrs env1 skol_tvs
591     ty'               = tidyType env2 ty
592
593 tidySkolemInfo env info = (env, info)
594 \end{code}