A little refactoring (remove redundant argument passed to isGoodRecEv)
[ghc.git] / compiler / typecheck / TcSMonad.lhs
1 \begin{code}
2 -- Type definitions for the constraint solver
3 module TcSMonad ( 
4
5        -- Canonical constraints
6     CanonicalCts, emptyCCan, andCCan, andCCans, 
7     singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, 
8     isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, 
9
10     CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
11     mkWantedConstraints, deCanonicaliseWanted, 
12     makeGivens, makeSolvedByInst,
13
14     CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, 
15     isGivenCt, isWantedCt, pprFlavorArising,
16
17     isFlexiTcsTv,
18
19     DerivedOrig (..), 
20     canRewrite, canSolve,
21     combineCtLoc, mkGivenFlavor, mkWantedFlavor,
22     getWantedLoc,
23
24     TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0,  -- Basic functionality 
25     tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS,
26     SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
27        
28        -- Creation of evidence variables
29
30     newWantedCoVar, newGivOrDerCoVar, newGivOrDerEvVar, 
31     newIPVar, newDictVar, newKindConstraint,
32
33        -- Setting evidence variables 
34     setWantedCoBind, setDerivedCoBind, 
35     setIPBind, setDictBind, setEvBind,
36
37     setWantedTyBind,
38
39     newTcEvBindsTcS,
40  
41     getInstEnvs, getFamInstEnvs,                -- Getting the environments 
42     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
43     getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, getTcSErrors,
44     getTcSErrorsBag, FrozenError (..),
45     addErrorTcS,
46     ErrorKind(..),
47
48     newFlattenSkolemTy,                         -- Flatten skolems 
49
50
51     instDFunTypes,                              -- Instantiation
52     instDFunConstraints,          
53     newFlexiTcSTy, 
54
55     isGoodRecEv,
56
57     compatKind,
58
59
60     TcsUntouchables,
61     isTouchableMetaTyVar,
62     isTouchableMetaTyVar_InRange, 
63
64     getDefaultInfo, getDynFlags,
65
66     matchClass, matchFam, MatchInstResult (..), 
67     checkWellStagedDFun, 
68     warnTcS,
69     pprEq,                                   -- Smaller utils, re-exported from TcM 
70                                              -- TODO (DV): these are only really used in the 
71                                              -- instance matcher in TcSimplify. I am wondering
72                                              -- if the whole instance matcher simply belongs
73                                              -- here 
74
75
76     mkWantedFunDepEqns                       -- Instantiation of 'Equations' from FunDeps
77
78 ) where 
79
80 #include "HsVersions.h"
81
82 import HscTypes
83 import BasicTypes 
84
85 import Inst
86 import InstEnv 
87 import FamInst 
88 import FamInstEnv
89
90 import NameSet ( addOneToNameSet ) 
91
92 import qualified TcRnMonad as TcM
93 import qualified TcMType as TcM
94 import qualified TcEnv as TcM 
95        ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
96 import TcType
97 import Module 
98 import DynFlags
99
100 import Coercion
101 import Class
102 import TyCon
103 import TypeRep 
104
105 import Name
106 import Var
107 import VarEnv
108 import Outputable
109 import Bag
110 import MonadUtils
111 import VarSet
112 import FastString
113
114 import HsBinds               -- for TcEvBinds stuff 
115 import Id 
116 import FunDeps
117
118 import TcRnTypes
119
120 import Control.Monad
121 import Data.IORef
122 \end{code}
123
124
125 %************************************************************************
126 %*                                                                      *
127 %*                       Canonical constraints                          *
128 %*                                                                      *
129 %*   These are the constraints the low-level simplifier works with      *
130 %*                                                                      *
131 %************************************************************************
132
133 \begin{code}
134 -- Types without any type functions inside.  However, note that xi
135 -- types CAN contain unexpanded type synonyms; however, the
136 -- (transitive) expansions of those type synonyms will not contain any
137 -- type functions.
138 type Xi = Type       -- In many comments, "xi" ranges over Xi
139
140 type CanonicalCts = Bag CanonicalCt
141  
142 data CanonicalCt
143   -- Atomic canonical constraints 
144   = CDictCan {  -- e.g.  Num xi
145       cc_id     :: EvVar,
146       cc_flavor :: CtFlavor, 
147       cc_class  :: Class, 
148       cc_tyargs :: [Xi]
149     }
150
151   | CIPCan {    -- ?x::tau
152       -- See note [Canonical implicit parameter constraints].
153       cc_id     :: EvVar,
154       cc_flavor :: CtFlavor,
155       cc_ip_nm  :: IPName Name,
156       cc_ip_ty  :: TcTauType
157     }
158
159   | CTyEqCan {  -- tv ~ xi      (recall xi means function free)
160        -- Invariant: 
161        --   * tv not in tvs(xi)   (occurs check)
162        --   * If constraint is given then typeKind xi `compatKind` typeKind tv 
163        --                See Note [Spontaneous solving and kind compatibility] 
164        --   * We prefer unification variables on the left *JUST* for efficiency
165       cc_id     :: EvVar, 
166       cc_flavor :: CtFlavor, 
167       cc_tyvar  :: TcTyVar, 
168       cc_rhs    :: Xi
169     }
170
171   | CFunEqCan {  -- F xis ~ xi  
172                  -- Invariant: * isSynFamilyTyCon cc_fun 
173                  --            * If constraint is given then 
174                  --                 typeKind (F xis) `compatKind` typeKind xi
175       cc_id     :: EvVar,
176       cc_flavor :: CtFlavor, 
177       cc_fun    :: TyCon,       -- A type function
178       cc_tyargs :: [Xi],        -- Either under-saturated or exactly saturated
179       cc_rhs    :: Xi           --    *never* over-saturated (because if so
180                                 --    we should have decomposed)
181                    
182     }
183
184 compatKind :: Kind -> Kind -> Bool 
185 compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 
186
187 makeGivens :: CanonicalCts -> CanonicalCts
188 makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
189            -- The UnkSkol doesn't matter because these givens are
190            -- not contradictory (else we'd have rejected them already)
191
192 makeSolvedByInst :: CanonicalCt -> CanonicalCt
193 -- Record that a constraint is now solved
194 --        Wanted         -> Derived
195 --        Given, Derived -> no-op
196 makeSolvedByInst ct 
197   | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc DerInst }
198   | otherwise                  = ct
199
200 mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
201 mkWantedConstraints flats implics 
202   = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics
203
204 deCanonicaliseWanted :: CanonicalCt -> WantedEvVar
205 deCanonicaliseWanted ct 
206   = WARN( not (isWanted $ cc_flavor ct), ppr ct ) 
207     let Wanted loc = cc_flavor ct 
208     in WantedEvVar (cc_id ct) loc
209
210 tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
211 tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
212 tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
213 tyVarsOfCanonical (CDictCan { cc_tyargs = tys })               = tyVarsOfTypes tys
214 tyVarsOfCanonical (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
215
216 tyVarsOfCDict :: CanonicalCt -> TcTyVarSet 
217 tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
218 tyVarsOfCDict _ct                            = emptyVarSet 
219
220 tyVarsOfCDicts :: CanonicalCts -> TcTyVarSet 
221 tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet
222
223 tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
224 tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
225
226 instance Outputable CanonicalCt where
227   ppr (CDictCan d fl cls tys)     
228       = ppr fl <+> ppr d  <+> dcolon <+> pprClassPred cls tys
229   ppr (CIPCan ip fl ip_nm ty)     
230       = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
231   ppr (CTyEqCan co fl tv ty)      
232       = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
233   ppr (CFunEqCan co fl tc tys ty) 
234       = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
235 \end{code}
236
237 Note [Canonical implicit parameter constraints]
238 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
239 The type in a canonical implicit parameter constraint doesn't need to
240 be a xi (type-function-free type) since we can defer the flattening
241 until checking this type for equality with another type.  If we
242 encounter two IP constraints with the same name, they MUST have the
243 same type, and at that point we can generate a flattened equality
244 constraint between the types.  (On the other hand, the types in two
245 class constraints for the same class MAY be equal, so they need to be
246 flattened in the first place to facilitate comparing them.)
247
248 \begin{code}
249 singleCCan :: CanonicalCt -> CanonicalCts 
250 singleCCan = unitBag 
251
252 andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts 
253 andCCan = unionBags
254
255 extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts 
256 extendCCans = snocBag 
257
258 andCCans :: [CanonicalCts] -> CanonicalCts 
259 andCCans = unionManyBags
260
261 emptyCCan :: CanonicalCts 
262 emptyCCan = emptyBag
263
264 isEmptyCCan :: CanonicalCts -> Bool
265 isEmptyCCan = isEmptyBag
266
267 isCTyEqCan :: CanonicalCt -> Bool 
268 isCTyEqCan (CTyEqCan {})  = True 
269 isCTyEqCan (CFunEqCan {}) = False
270 isCTyEqCan _              = False 
271
272 isCDictCan_Maybe :: CanonicalCt -> Maybe Class
273 isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
274 isCDictCan_Maybe _              = Nothing
275
276 isCIPCan_Maybe :: CanonicalCt -> Maybe (IPName Name)
277 isCIPCan_Maybe  (CIPCan {cc_ip_nm = nm }) = Just nm
278 isCIPCan_Maybe _                = Nothing
279
280 isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon
281 isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
282 isCFunEqCan_Maybe _ = Nothing
283
284 \end{code}
285
286 %************************************************************************
287 %*                                                                      *
288                     CtFlavor
289          The "flavor" of a canonical constraint
290 %*                                                                      *
291 %************************************************************************
292
293 \begin{code}
294 data CtFlavor 
295   = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
296   | Derived WantedLoc DerivedOrig
297                       -- We have evidence for this constraint in TcEvBinds;
298                       --   *however* this evidence can contain wanteds, so 
299                       --   it's valid only provisionally to the solution of
300                       --   these wanteds 
301   | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
302
303 data DerivedOrig = DerSC | DerInst 
304 -- Deriveds are either superclasses of other wanteds or deriveds, or partially 
305 -- solved wanteds from instances. 
306
307 instance Outputable CtFlavor where 
308   ppr (Given _)    = ptext (sLit "[Given]")
309   ppr (Wanted _)   = ptext (sLit "[Wanted]")
310   ppr (Derived {}) = ptext (sLit "[Derived]") 
311
312 isWanted :: CtFlavor -> Bool 
313 isWanted (Wanted {}) = True
314 isWanted _           = False
315
316 isGiven :: CtFlavor -> Bool 
317 isGiven (Given {}) = True 
318 isGiven _          = False 
319
320 isDerived :: CtFlavor -> Bool 
321 isDerived (Derived {}) = True
322 isDerived _            = False
323
324 isDerivedSC :: CtFlavor -> Bool 
325 isDerivedSC (Derived _ DerSC) = True 
326 isDerivedSC _                 = False 
327
328 isDerivedByInst :: CtFlavor -> Bool 
329 isDerivedByInst (Derived _ DerInst) = True 
330 isDerivedByInst _                   = False 
331
332 pprFlavorArising :: CtFlavor -> SDoc
333 pprFlavorArising (Derived wl _) = pprArisingAt wl
334 pprFlavorArising (Wanted  wl)   = pprArisingAt wl
335 pprFlavorArising (Given gl)     = pprArisingAt gl
336
337 getWantedLoc :: CanonicalCt -> WantedLoc
338 getWantedLoc ct 
339   = ASSERT (isWanted (cc_flavor ct))
340     case cc_flavor ct of 
341       Wanted wl -> wl 
342       _         -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty
343
344
345 isWantedCt :: CanonicalCt -> Bool 
346 isWantedCt ct = isWanted (cc_flavor ct)
347 isGivenCt :: CanonicalCt -> Bool 
348 isGivenCt ct = isGiven (cc_flavor ct) 
349
350 canSolve :: CtFlavor -> CtFlavor -> Bool 
351 -- canSolve ctid1 ctid2 
352 -- The constraint ctid1 can be used to solve ctid2 
353 -- "to solve" means a reaction where the active parts of the two constraints match.
354 --  active(F xis ~ xi) = F xis 
355 --  active(tv ~ xi)    = tv 
356 --  active(D xis)      = D xis 
357 --  active(IP nm ty)   = nm 
358 -----------------------------------------
359 canSolve (Given {})   _            = True 
360 canSolve (Derived {}) (Wanted {})  = True 
361 canSolve (Derived {}) (Derived {}) = True 
362 canSolve (Wanted {})  (Wanted {})  = True
363 canSolve _ _ = False
364
365 canRewrite :: CtFlavor -> CtFlavor -> Bool 
366 -- canRewrite ctid1 ctid2 
367 -- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 
368 canRewrite = canSolve 
369
370 combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
371 -- Precondition: At least one of them should be wanted 
372 combineCtLoc (Wanted loc) _    = loc 
373 combineCtLoc _ (Wanted loc)    = loc 
374 combineCtLoc (Derived loc _) _ = loc 
375 combineCtLoc _ (Derived loc _) = loc 
376 combineCtLoc _ _ = panic "combineCtLoc: both given"
377
378 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
379 mkGivenFlavor (Wanted  loc)   sk = Given (setCtLocOrigin loc sk)
380 mkGivenFlavor (Derived loc _) sk = Given (setCtLocOrigin loc sk)
381 mkGivenFlavor (Given   loc)   sk = Given (setCtLocOrigin loc sk)
382
383 mkWantedFlavor :: CtFlavor -> CtFlavor
384 mkWantedFlavor (Wanted  loc)   = Wanted loc
385 mkWantedFlavor (Derived loc _) = Wanted loc
386 mkWantedFlavor fl@(Given {})   = pprPanic "mkWantedFlavour" (ppr fl)
387 \end{code}
388
389
390 %************************************************************************
391 %*                                                                      *
392 %*              The TcS solver monad                                    *
393 %*                                                                      *
394 %************************************************************************
395
396 Note [The TcS monad]
397 ~~~~~~~~~~~~~~~~~~~~
398 The TcS monad is a weak form of the main Tc monad
399
400 All you can do is
401     * fail
402     * allocate new variables
403     * fill in evidence variables
404
405 Filling in a dictionary evidence variable means to create a binding
406 for it, so TcS carries a mutable location where the binding can be
407 added.  This is initialised from the innermost implication constraint.
408
409 \begin{code}
410 data TcSEnv
411   = TcSEnv { 
412       tcs_ev_binds :: EvBindsVar,
413           -- Evidence bindings
414
415       tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
416           -- Global type bindings
417
418       tcs_context :: SimplContext,
419                      
420       tcs_errors :: IORef (Bag FrozenError), 
421           -- Frozen errors that we defer reporting as much as possible, in order to
422           -- make them as informative as possible. See Note [Frozen Errors]
423
424       tcs_untch :: TcsUntouchables 
425     }
426
427 type TcsUntouchables = (Untouchables,TcTyVarSet)
428 -- Like the TcM Untouchables, 
429 -- but records extra TcsTv variables generated during simplification
430 -- See Note [Extra TcsTv untouchables] in TcSimplify
431
432 data FrozenError
433   = FrozenError ErrorKind CtFlavor TcType TcType 
434
435 data ErrorKind
436   = MisMatchError | OccCheckError | KindError
437
438 instance Outputable FrozenError where 
439   ppr (FrozenError _frknd fl ty1 ty2) = ppr fl <+> pprEq ty1 ty2 <+> text "(frozen)"
440
441 \end{code}
442
443 Note [Frozen Errors] 
444 ~~~~~~~~~~~~~~~~~~~~
445 Some of the errors that we get during canonicalization are best reported when all constraints
446 have been simplified as much as possible. For instance, assume that during simplification
447 the following constraints arise: 
448    
449  [Wanted]   F alpha ~  uf1 
450  [Wanted]   beta ~ uf1 beta 
451
452 When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail we will simply 
453 see a message: 
454     'Can't construct the infinite type  beta ~ uf1 beta' 
455 and the user has no idea what the uf1 variable is.
456
457 Instead our plan is that we will NOT fail immediately, but:
458     (1) Record the "frozen" error in the tcs_errors field 
459     (2) Isolate the offending constraint from the rest of the inerts 
460     (3) Keep on simplifying/canonicalizing
461
462 At the end, we will hopefully have substituted uf1 := F alpha, and we will be able to 
463 report a more informative error: 
464     'Can't construct the infinite type beta ~ F alpha beta'
465 \begin{code}
466
467 data SimplContext
468   = SimplInfer          -- Inferring type of a let-bound thing
469   | SimplRuleLhs        -- Inferring type of a RULE lhs
470   | SimplInteractive    -- Inferring type at GHCi prompt
471   | SimplCheck          -- Checking a type signature or RULE rhs
472
473 instance Outputable SimplContext where
474   ppr SimplInfer       = ptext (sLit "SimplInfer")
475   ppr SimplRuleLhs     = ptext (sLit "SimplRuleLhs")
476   ppr SimplInteractive = ptext (sLit "SimplInteractive")
477   ppr SimplCheck       = ptext (sLit "SimplCheck")
478
479 isInteractive :: SimplContext -> Bool
480 isInteractive SimplInteractive = True
481 isInteractive _                = False
482
483 simplEqsOnly :: SimplContext -> Bool
484 -- Simplify equalities only, not dictionaries
485 -- This is used for the LHS of rules; ee
486 -- Note [Simplifying RULE lhs constraints] in TcSimplify
487 simplEqsOnly SimplRuleLhs = True
488 simplEqsOnly _            = False
489
490 performDefaulting :: SimplContext -> Bool
491 performDefaulting SimplInfer       = False
492 performDefaulting SimplRuleLhs     = False
493 performDefaulting SimplInteractive = True
494 performDefaulting SimplCheck       = True
495
496 ---------------
497 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
498
499 instance Functor TcS where
500   fmap f m = TcS $ fmap f . unTcS m
501
502 instance Monad TcS where 
503   return x  = TcS (\_ -> return x) 
504   fail err  = TcS (\_ -> fail err) 
505   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
506
507 -- Basic functionality 
508 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
509 wrapTcS :: TcM a -> TcS a 
510 -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
511 -- and TcS is supposed to have limited functionality
512 wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
513
514 wrapErrTcS :: TcM a -> TcS a 
515 -- The thing wrapped should just fail
516 -- There's no static check; it's up to the user
517 -- Having a variant for each error message is too painful
518 wrapErrTcS = wrapTcS
519
520 wrapWarnTcS :: TcM a -> TcS a 
521 -- The thing wrapped should just add a warning, or no-op
522 -- There's no static check; it's up to the user
523 wrapWarnTcS = wrapTcS
524
525 failTcS, panicTcS :: SDoc -> TcS a
526 failTcS      = wrapTcS . TcM.failWith
527 panicTcS doc = pprPanic "TcCanonical" doc
528
529 traceTcS :: String -> SDoc -> TcS ()
530 traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
531
532 traceTcS0 :: String -> SDoc -> TcS ()
533 traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
534
535 runTcS :: SimplContext
536        -> Untouchables         -- Untouchables
537        -> TcS a                -- What to run
538        -> TcM (a, Bag FrozenError, Bag EvBind)
539 runTcS context untouch tcs 
540   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
541        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
542        ; err_ref <- TcM.newTcRef emptyBag
543        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
544                           , tcs_ty_binds = ty_binds_var
545                           , tcs_context  = context
546                           , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
547                           , tcs_errors   = err_ref
548                           }
549
550              -- Run the computation
551        ; res <- unTcS tcs env
552              -- Perform the type unifications required
553        ; ty_binds <- TcM.readTcRef ty_binds_var
554        ; mapM_ do_unification (varEnvElts ty_binds)
555
556              -- And return
557        ; frozen_errors <- TcM.readTcRef err_ref
558        ; ev_binds      <- TcM.readTcRef evb_ref
559        ; return (res, frozen_errors, evBindMapBinds ev_binds) }
560   where
561     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
562
563 nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a
564 nestImplicTcS ref untch (TcS thing_inside)
565   = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, 
566                      tcs_context = ctxt, 
567                      tcs_errors = err_ref } ->
568     let 
569        nest_env = TcSEnv { tcs_ev_binds = ref
570                          , tcs_ty_binds = ty_binds
571                          , tcs_untch    = untch
572                          , tcs_context  = ctxtUnderImplic ctxt 
573                          , tcs_errors   = err_ref }
574     in 
575     thing_inside nest_env
576
577 recoverTcS :: TcS a -> TcS a -> TcS a
578 recoverTcS (TcS recovery_code) (TcS thing_inside)
579   = TcS $ \ env ->
580     TcM.recoverM (recovery_code env) (thing_inside env)
581
582 ctxtUnderImplic :: SimplContext -> SimplContext
583 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
584 ctxtUnderImplic SimplRuleLhs = SimplCheck
585 ctxtUnderImplic ctxt         = ctxt
586
587 tryTcS :: TcS a -> TcS a
588 -- Like runTcS, but from within the TcS monad 
589 -- Ignore all the evidence generated, and do not affect caller's evidence!
590 tryTcS tcs 
591   = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
592                     ; ev_binds_var <- TcM.newTcEvBinds
593                     ; err_ref      <- TcM.newTcRef emptyBag
594                     ; let env1 = env { tcs_ev_binds = ev_binds_var
595                                      , tcs_ty_binds = ty_binds_var 
596                                      , tcs_errors   = err_ref }
597                     ; unTcS tcs env1 })
598
599 -- Update TcEvBinds 
600 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
601
602 getDynFlags :: TcS DynFlags
603 getDynFlags = wrapTcS TcM.getDOpts
604
605 getTcSContext :: TcS SimplContext
606 getTcSContext = TcS (return . tcs_context)
607
608 getTcEvBinds :: TcS EvBindsVar
609 getTcEvBinds = TcS (return . tcs_ev_binds) 
610
611 getUntouchables :: TcS TcsUntouchables
612 getUntouchables = TcS (return . tcs_untch)
613
614 getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
615 getTcSTyBinds = TcS (return . tcs_ty_binds)
616
617 getTcSErrors :: TcS (IORef (Bag FrozenError))
618 getTcSErrors = TcS (return . tcs_errors)
619
620 getTcSErrorsBag :: TcS (Bag FrozenError) 
621 getTcSErrorsBag = do { err_ref <- getTcSErrors 
622                      ; wrapTcS $ TcM.readTcRef err_ref }
623
624 getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) 
625 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
626
627
628 getTcEvBindsBag :: TcS EvBindMap
629 getTcEvBindsBag
630   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
631        ; wrapTcS $ TcM.readTcRef ev_ref }
632
633 setWantedCoBind :: CoVar -> Coercion -> TcS () 
634 setWantedCoBind cv co 
635   = setEvBind cv (EvCoercion co)
636      -- Was: wrapTcS $ TcM.writeWantedCoVar cv co 
637
638 setDerivedCoBind :: CoVar -> Coercion -> TcS () 
639 setDerivedCoBind cv co 
640   = setEvBind cv (EvCoercion co)
641
642 setWantedTyBind :: TcTyVar -> TcType -> TcS () 
643 -- Add a type binding
644 -- We never do this twice!
645 setWantedTyBind tv ty 
646   = do { ref <- getTcSTyBinds
647        ; wrapTcS $ 
648          do { ty_binds <- TcM.readTcRef ref
649 #ifdef DEBUG
650             ; TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
651               vcat [ text "TERRIBLE ERROR: double set of meta type variable"
652                    , ppr tv <+> text ":=" <+> ppr ty
653                    , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
654 #endif
655             ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
656
657 setIPBind :: EvVar -> EvTerm -> TcS () 
658 setIPBind = setEvBind 
659
660 setDictBind :: EvVar -> EvTerm -> TcS () 
661 setDictBind = setEvBind 
662
663 setEvBind :: EvVar -> EvTerm -> TcS () 
664 -- Internal
665 setEvBind ev rhs 
666   = do { tc_evbinds <- getTcEvBinds 
667        ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
668
669 newTcEvBindsTcS :: TcS EvBindsVar
670 newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
671
672 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
673 warnTcS loc warn_if doc 
674   | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
675   | otherwise = return ()
676
677 getDefaultInfo ::  TcS (SimplContext, [Type], (Bool, Bool))
678 getDefaultInfo 
679   = do { ctxt <- getTcSContext
680        ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
681        ; return (ctxt, tys, flags) }
682
683
684
685 -- Recording errors in the TcS monad
686 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
687
688 addErrorTcS :: ErrorKind -> CtFlavor -> TcType -> TcType -> TcS ()
689 addErrorTcS frknd fl ty1 ty2
690   = do { err_ref <- getTcSErrors
691        ; wrapTcS $ do
692        { TcM.updTcRef err_ref $ \ errs ->
693            consBag (FrozenError frknd fl ty1 ty2) errs
694
695            -- If there's an error in the *given* constraints,
696            -- stop right now, to avoid a cascade of errors
697            -- in the wanteds
698        ; when (isGiven fl) TcM.failM
699
700        ; return () } }
701
702 -- Just get some environments needed for instance looking up and matching
703 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
704
705 getInstEnvs :: TcS (InstEnv, InstEnv) 
706 getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs 
707
708 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) 
709 getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
710
711 getTopEnv :: TcS HscEnv 
712 getTopEnv = wrapTcS $ TcM.getTopEnv 
713
714 getGblEnv :: TcS TcGblEnv 
715 getGblEnv = wrapTcS $ TcM.getGblEnv 
716
717 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
718 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
719
720 checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS () 
721 checkWellStagedDFun pred dfun_id loc 
722   = wrapTcS $ TcM.setCtLoc loc $ 
723     do { use_stage <- TcM.getStage
724        ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
725   where
726     pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
727     bind_lvl = TcM.topIdLvl dfun_id
728
729 pprEq :: TcType -> TcType -> SDoc
730 pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
731
732 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
733 isTouchableMetaTyVar tv 
734   = do { untch <- getUntouchables
735        ; return $ isTouchableMetaTyVar_InRange untch tv } 
736
737 isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool 
738 isTouchableMetaTyVar_InRange (untch,untch_tcs) tv 
739   = case tcTyVarDetails tv of 
740       MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
741                         -- See Note [Touchable meta type variables] 
742       MetaTv {}      -> inTouchableRange untch tv 
743       _              -> False 
744
745
746 \end{code}
747
748
749 Note [Touchable meta type variables]
750 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
751 Meta type variables allocated *by the constraint solver itself* are always
752 touchable.  Example: 
753    instance C a b => D [a] where...
754 if we use this instance declaration we "make up" a fresh meta type
755 variable for 'b', which we must later guess.  (Perhaps C has a
756 functional dependency.)  But since we aren't in the constraint *generator*
757 we can't allocate a Unique in the touchable range for this implication
758 constraint.  Instead, we mark it as a "TcsTv", which makes it always-touchable.
759
760
761 \begin{code}
762 -- Flatten skolems
763 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
764
765 newFlattenSkolemTy :: TcType -> TcS TcType
766 newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
767
768 newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
769 newFlattenSkolemTyVar ty
770   = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique
771                             ; let name = mkSysTvName uniq (fsLit "f")
772                             ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } 
773        ; traceTcS "New Flatten Skolem Born" $ 
774            (ppr tv <+> text "[:= " <+> ppr ty <+> text "]")
775        ; return tv }
776
777 -- Instantiations 
778 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
779
780 instDFunTypes :: [Either TyVar TcType] -> TcS [TcType] 
781 instDFunTypes mb_inst_tys 
782   = mapM inst_tv mb_inst_tys
783   where
784     inst_tv :: Either TyVar TcType -> TcS Type
785     inst_tv (Left tv)  = mkTyVarTy <$> instFlexiTcS tv
786     inst_tv (Right ty) = return ty 
787
788 instDFunConstraints :: TcThetaType -> TcS [EvVar] 
789 instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds 
790
791
792 instFlexiTcS :: TyVar -> TcS TcTyVar 
793 -- Like TcM.instMetaTyVar but the variable that is created is always
794 -- touchable; we are supposed to guess its instantiation. 
795 -- See Note [Touchable meta type variables] 
796 instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) 
797
798 newFlexiTcSTy :: Kind -> TcS TcType  
799 newFlexiTcSTy knd 
800   = wrapTcS $
801     do { uniq <- TcM.newUnique 
802        ; ref  <- TcM.newMutVar  Flexi 
803        ; let name = mkSysTvName uniq (fsLit "uf")
804        ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) }
805
806 isFlexiTcsTv :: TyVar -> Bool
807 isFlexiTcsTv tv
808   | not (isTcTyVar tv)                  = False
809   | MetaTv TcsTv _ <- tcTyVarDetails tv = True
810   | otherwise                           = False
811
812 newKindConstraint :: TcTyVar -> Kind -> TcS CoVar
813 -- Create new wanted CoVar that constrains the type to have the specified kind. 
814 newKindConstraint tv knd 
815   = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd 
816        ; let ty_k = mkTyVarTy tv_k
817        ; co_var <- newWantedCoVar (mkTyVarTy tv) ty_k
818        ; return co_var }
819
820 instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
821 instFlexiTcSHelper tvname tvkind
822   = wrapTcS $ 
823     do { uniq <- TcM.newUnique 
824        ; ref  <- TcM.newMutVar  Flexi 
825        ; let name = setNameUnique tvname uniq 
826              kind = tvkind 
827        ; return (mkTcTyVar name kind (MetaTv TcsTv ref)) }
828
829 -- Superclasses and recursive dictionaries 
830 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
831
832 newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar 
833 newGivOrDerEvVar pty evtrm 
834   = do { ev <- wrapTcS $ TcM.newEvVar pty 
835        ; setEvBind ev evtrm 
836        ; return ev }
837
838 newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar 
839 -- Note we create immutable variables for given or derived, since we
840 -- must bind them to TcEvBinds (because their evidence may involve 
841 -- superclasses). However we should be able to override existing
842 -- 'derived' evidence, even in TcEvBinds 
843 newGivOrDerCoVar ty1 ty2 co 
844   = do { cv <- newCoVar ty1 ty2
845        ; setEvBind cv (EvCoercion co) 
846        ; return cv } 
847
848 newWantedCoVar :: TcType -> TcType -> TcS EvVar 
849 newWantedCoVar ty1 ty2 =  wrapTcS $ TcM.newWantedCoVar ty1 ty2 
850
851
852 newCoVar :: TcType -> TcType -> TcS EvVar 
853 newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 
854
855 newIPVar :: IPName Name -> TcType -> TcS EvVar 
856 newIPVar nm ty = wrapTcS $ TcM.newIP nm ty 
857
858 newDictVar :: Class -> [TcType] -> TcS EvVar 
859 newDictVar cl tys = wrapTcS $ TcM.newDict cl tys 
860 \end{code} 
861
862
863 \begin{code} 
864 isGoodRecEv :: EvVar -> EvVar -> TcS Bool
865 -- In a call (isGoodRecEv ev wv), we are considering solving wv 
866 -- using some term that involves ev, such as:
867 -- by setting           wv = ev
868 -- or                   wv = EvCast x |> ev
869 -- etc. 
870 -- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
871 -- in an "unguarded" way. So isGoodRecEv looks at the evidence ev 
872 -- recursively through the evidence binds, to see if uses of 'wv' are guarded.
873 --
874 -- Guarded means: more instance calls than superclass selections. We
875 -- compute this by chasing the evidence, adding +1 for every instance
876 -- call (constructor) and -1 for every superclass selection (destructor).
877 --
878 -- See Note [Superclasses and recursive dictionaries] in TcInteract
879 isGoodRecEv ev_var wv
880   = do { tc_evbinds <- getTcEvBindsBag 
881        ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var 
882        ; return $ case mb of 
883                     Nothing -> True 
884                     Just min_guardedness -> min_guardedness > 0
885        }
886
887   where chase_ev_var :: EvBindMap   -- Evidence binds 
888                  -> EvVar           -- Target variable whose gravity we want to return
889                  -> Int             -- Current gravity 
890                  -> [EvVar]         -- Visited nodes
891                  -> EvVar           -- Current node 
892                  -> TcS (Maybe Int)
893         chase_ev_var assocs trg curr_grav visited orig
894             | trg == orig         = return $ Just curr_grav
895             | orig `elem` visited = return $ Nothing 
896             | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
897             = chase_ev assocs trg curr_grav (orig:visited) ev_trm
898
899             | otherwise = return Nothing
900
901         chase_ev assocs trg curr_grav visited (EvId v) 
902             = chase_ev_var assocs trg curr_grav visited v
903         chase_ev assocs trg curr_grav visited (EvSuperClass d_id _) 
904             = chase_ev_var assocs trg (curr_grav-1) visited d_id
905         chase_ev assocs trg curr_grav visited (EvCast v co)
906             = do { m1 <- chase_ev_var assocs trg curr_grav visited v
907                  ; m2 <- chase_co assocs trg curr_grav visited co
908                  ; return (comb_chase_res Nothing [m1,m2]) } 
909
910         chase_ev assocs trg curr_grav visited (EvCoercion co)
911             = chase_co assocs trg curr_grav visited co
912         chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars) 
913             = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
914                  ; return (comb_chase_res Nothing chase_results) } 
915
916         chase_co assocs trg curr_grav visited co 
917             = -- Look for all the coercion variables in the coercion 
918               -- chase them, and combine the results. This is OK since the
919               -- coercion will not contain any superclass terms -- anything 
920               -- that involves dictionaries will be bound in assocs. 
921               let co_vars       = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
922                                              (tyVarsOfType co)
923               in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
924                     ; return (comb_chase_res Nothing chase_results) } 
925
926         comb_chase_res f []                   = f 
927         comb_chase_res f (Nothing:rest)       = comb_chase_res f rest 
928         comb_chase_res Nothing (Just n:rest)  = comb_chase_res (Just n) rest
929         comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest 
930
931
932 -- Matching and looking up classes and family instances
933 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
934
935 data MatchInstResult mi
936   = MatchInstNo         -- No matching instance 
937   | MatchInstSingle mi  -- Single matching instance
938   | MatchInstMany       -- Multiple matching instances
939
940
941 matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType])) 
942 -- Look up a class constraint in the instance environment
943 matchClass clas tys
944   = do  { let pred = mkClassPred clas tys 
945         ; instEnvs <- getInstEnvs
946         ; case lookupInstEnv instEnvs clas tys of {
947             ([], unifs)               -- Nothing matches  
948                 -> do { traceTcS "matchClass not matching"
949                                  (vcat [ text "dict" <+> ppr pred, 
950                                          text "unifs" <+> ppr unifs ]) 
951                       ; return MatchInstNo  
952                       } ;  
953             ([(ispec, inst_tys)], []) -- A single match 
954                 -> do   { let dfun_id = is_dfun ispec
955                         ; traceTcS "matchClass success"
956                                    (vcat [text "dict" <+> ppr pred, 
957                                           text "witness" <+> ppr dfun_id
958                                            <+> ppr (idType dfun_id) ])
959                                   -- Record that this dfun is needed
960                         ; record_dfun_usage dfun_id
961                         ; return $ MatchInstSingle (dfun_id, inst_tys) 
962                         } ;
963             (matches, unifs)          -- More than one matches 
964                 -> do   { traceTcS "matchClass multiple matches, deferring choice"
965                                    (vcat [text "dict" <+> ppr pred,
966                                           text "matches" <+> ppr matches,
967                                           text "unifs" <+> ppr unifs])
968                         ; return MatchInstMany 
969                         }
970         }
971         }
972   where record_dfun_usage :: Id -> TcS () 
973         record_dfun_usage dfun_id 
974           = do { hsc_env <- getTopEnv 
975                ; let  dfun_name = idName dfun_id
976                       dfun_mod  = ASSERT( isExternalName dfun_name ) 
977                                   nameModule dfun_name
978                ; if isInternalName dfun_name ||    -- Internal name => defined in this module
979                     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
980                  then return () -- internal, or in another package
981                  else do updInstUses dfun_id 
982                }
983
984         updInstUses :: Id -> TcS () 
985         updInstUses dfun_id 
986             = do { tcg_env <- getGblEnv 
987                  ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) 
988                                             (`addOneToNameSet` idName dfun_id) 
989                  }
990
991 matchFam :: TyCon 
992          -> [Type] 
993          -> TcS (MatchInstResult (TyCon, [Type]))
994 matchFam tycon args
995   = do { mb <- wrapTcS $ TcM.tcLookupFamInst tycon args
996        ; case mb of 
997            Nothing  -> return MatchInstNo 
998            Just res -> return $ MatchInstSingle res
999        -- DV: We never return MatchInstMany, since tcLookupFamInst never returns 
1000        -- multiple matches. Check. 
1001        }
1002
1003
1004 -- Functional dependencies, instantiation of equations
1005 -------------------------------------------------------
1006
1007 mkWantedFunDepEqns :: WantedLoc
1008                    -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
1009                    -> TcS [WantedEvVar] 
1010 mkWantedFunDepEqns _   [] = return []
1011 mkWantedFunDepEqns loc eqns
1012   = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
1013        ; wevvars <- mapM to_work_item eqns
1014        ; return $ concat wevvars }
1015   where
1016     to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
1017     to_work_item ((qtvs, pairs), d1, d2)
1018       = do { let tvs = varSetElems qtvs
1019            ; tvs' <- mapM instFlexiTcS tvs
1020            ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
1021                  loc'  = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
1022            ; mapM (do_one subst loc') pairs }
1023
1024     do_one subst loc' (ty1, ty2)
1025        = do { let sty1 = substTy subst ty1
1026                   sty2 = substTy subst ty2
1027             ; ev <- newWantedCoVar sty1 sty2
1028             ; return (WantedEvVar ev loc') }
1029
1030 pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
1031 pprEquationDoc (eqn, (p1, _), (p2, _)) 
1032   = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
1033
1034 mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
1035          -> TcM (TidyEnv, SDoc)
1036 mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
1037   = do  { pred1' <- TcM.zonkTcPredType pred1
1038         ; pred2' <- TcM.zonkTcPredType pred2
1039         ; let { pred1'' = tidyPred tidy_env pred1'
1040               ; pred2'' = tidyPred tidy_env pred2' }
1041         ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
1042                           nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
1043                           nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
1044         ; return (tidy_env, msg) }
1045 \end{code}