Re-jig simplifySuperClass (again)
[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, 
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 | DerSelf
304 -- Deriveds are either superclasses of other wanteds or deriveds, or partially 
305 -- solved wanteds from instances, or 'self' dictionaries containing yet wanted
306 -- superclasses. 
307
308 instance Outputable CtFlavor where 
309   ppr (Given _)    = ptext (sLit "[Given]")
310   ppr (Wanted _)   = ptext (sLit "[Wanted]")
311   ppr (Derived {}) = ptext (sLit "[Derived]") 
312
313 isWanted :: CtFlavor -> Bool 
314 isWanted (Wanted {}) = True
315 isWanted _           = False
316
317 isGiven :: CtFlavor -> Bool 
318 isGiven (Given {}) = True 
319 isGiven _          = False 
320
321 isDerived :: CtFlavor -> Bool 
322 isDerived (Derived {}) = True
323 isDerived _            = False
324
325 pprFlavorArising :: CtFlavor -> SDoc
326 pprFlavorArising (Derived wl _) = pprArisingAt wl
327 pprFlavorArising (Wanted  wl)   = pprArisingAt wl
328 pprFlavorArising (Given gl)     = pprArisingAt gl
329
330 getWantedLoc :: CanonicalCt -> WantedLoc
331 getWantedLoc ct 
332   = ASSERT (isWanted (cc_flavor ct))
333     case cc_flavor ct of 
334       Wanted wl -> wl 
335       _         -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty
336
337
338 isWantedCt :: CanonicalCt -> Bool 
339 isWantedCt ct = isWanted (cc_flavor ct)
340 isGivenCt :: CanonicalCt -> Bool 
341 isGivenCt ct = isGiven (cc_flavor ct) 
342
343 canSolve :: CtFlavor -> CtFlavor -> Bool 
344 -- canSolve ctid1 ctid2 
345 -- The constraint ctid1 can be used to solve ctid2 
346 -- "to solve" means a reaction where the active parts of the two constraints match.
347 --  active(F xis ~ xi) = F xis 
348 --  active(tv ~ xi)    = tv 
349 --  active(D xis)      = D xis 
350 --  active(IP nm ty)   = nm 
351 -----------------------------------------
352 canSolve (Given {})   _            = True 
353 canSolve (Derived {}) (Wanted {})  = True 
354 canSolve (Derived {}) (Derived {}) = True 
355 canSolve (Wanted {})  (Wanted {})  = True
356 canSolve _ _ = False
357
358 canRewrite :: CtFlavor -> CtFlavor -> Bool 
359 -- canRewrite ctid1 ctid2 
360 -- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 
361 canRewrite = canSolve 
362
363 combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
364 -- Precondition: At least one of them should be wanted 
365 combineCtLoc (Wanted loc) _    = loc 
366 combineCtLoc _ (Wanted loc)    = loc 
367 combineCtLoc (Derived loc _) _ = loc 
368 combineCtLoc _ (Derived loc _) = loc 
369 combineCtLoc _ _ = panic "combineCtLoc: both given"
370
371 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
372 mkGivenFlavor (Wanted  loc)   sk = Given (setCtLocOrigin loc sk)
373 mkGivenFlavor (Derived loc _) sk = Given (setCtLocOrigin loc sk)
374 mkGivenFlavor (Given   loc)   sk = Given (setCtLocOrigin loc sk)
375
376 mkWantedFlavor :: CtFlavor -> CtFlavor
377 mkWantedFlavor (Wanted  loc)   = Wanted loc
378 mkWantedFlavor (Derived loc _) = Wanted loc
379 mkWantedFlavor fl@(Given {})   = pprPanic "mkWantedFlavour" (ppr fl)
380 \end{code}
381
382
383 %************************************************************************
384 %*                                                                      *
385 %*              The TcS solver monad                                    *
386 %*                                                                      *
387 %************************************************************************
388
389 Note [The TcS monad]
390 ~~~~~~~~~~~~~~~~~~~~
391 The TcS monad is a weak form of the main Tc monad
392
393 All you can do is
394     * fail
395     * allocate new variables
396     * fill in evidence variables
397
398 Filling in a dictionary evidence variable means to create a binding
399 for it, so TcS carries a mutable location where the binding can be
400 added.  This is initialised from the innermost implication constraint.
401
402 \begin{code}
403 data TcSEnv
404   = TcSEnv { 
405       tcs_ev_binds :: EvBindsVar,
406           -- Evidence bindings
407
408       tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
409           -- Global type bindings
410
411       tcs_context :: SimplContext,
412                      
413       tcs_errors :: IORef (Bag FrozenError), 
414           -- Frozen errors that we defer reporting as much as possible, in order to
415           -- make them as informative as possible. See Note [Frozen Errors]
416
417       tcs_untch :: TcsUntouchables 
418     }
419
420 type TcsUntouchables = (Untouchables,TcTyVarSet)
421 -- Like the TcM Untouchables, 
422 -- but records extra TcsTv variables generated during simplification
423 -- See Note [Extra TcsTv untouchables] in TcSimplify
424
425 data FrozenError
426   = FrozenError ErrorKind CtFlavor TcType TcType 
427
428 data ErrorKind
429   = MisMatchError | OccCheckError | KindError
430
431 instance Outputable FrozenError where 
432   ppr (FrozenError _frknd fl ty1 ty2) = ppr fl <+> pprEq ty1 ty2 <+> text "(frozen)"
433
434 \end{code}
435
436 Note [Frozen Errors] 
437 ~~~~~~~~~~~~~~~~~~~~
438 Some of the errors that we get during canonicalization are best reported when all constraints
439 have been simplified as much as possible. For instance, assume that during simplification
440 the following constraints arise: 
441    
442  [Wanted]   F alpha ~  uf1 
443  [Wanted]   beta ~ uf1 beta 
444
445 When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail we will simply 
446 see a message: 
447     'Can't construct the infinite type  beta ~ uf1 beta' 
448 and the user has no idea what the uf1 variable is.
449
450 Instead our plan is that we will NOT fail immediately, but:
451     (1) Record the "frozen" error in the tcs_errors field 
452     (2) Isolate the offending constraint from the rest of the inerts 
453     (3) Keep on simplifying/canonicalizing
454
455 At the end, we will hopefully have substituted uf1 := F alpha, and we will be able to 
456 report a more informative error: 
457     'Can't construct the infinite type beta ~ F alpha beta'
458 \begin{code}
459
460 data SimplContext
461   = SimplInfer          -- Inferring type of a let-bound thing
462   | SimplRuleLhs        -- Inferring type of a RULE lhs
463   | SimplInteractive    -- Inferring type at GHCi prompt
464   | SimplCheck          -- Checking a type signature or RULE rhs
465
466 instance Outputable SimplContext where
467   ppr SimplInfer       = ptext (sLit "SimplInfer")
468   ppr SimplRuleLhs     = ptext (sLit "SimplRuleLhs")
469   ppr SimplInteractive = ptext (sLit "SimplInteractive")
470   ppr SimplCheck       = ptext (sLit "SimplCheck")
471
472 isInteractive :: SimplContext -> Bool
473 isInteractive SimplInteractive = True
474 isInteractive _                = False
475
476 simplEqsOnly :: SimplContext -> Bool
477 -- Simplify equalities only, not dictionaries
478 -- This is used for the LHS of rules; ee
479 -- Note [Simplifying RULE lhs constraints] in TcSimplify
480 simplEqsOnly SimplRuleLhs = True
481 simplEqsOnly _            = False
482
483 performDefaulting :: SimplContext -> Bool
484 performDefaulting SimplInfer       = False
485 performDefaulting SimplRuleLhs     = False
486 performDefaulting SimplInteractive = True
487 performDefaulting SimplCheck       = True
488
489 ---------------
490 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
491
492 instance Functor TcS where
493   fmap f m = TcS $ fmap f . unTcS m
494
495 instance Monad TcS where 
496   return x  = TcS (\_ -> return x) 
497   fail err  = TcS (\_ -> fail err) 
498   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
499
500 -- Basic functionality 
501 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
502 wrapTcS :: TcM a -> TcS a 
503 -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
504 -- and TcS is supposed to have limited functionality
505 wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
506
507 wrapErrTcS :: TcM a -> TcS a 
508 -- The thing wrapped should just fail
509 -- There's no static check; it's up to the user
510 -- Having a variant for each error message is too painful
511 wrapErrTcS = wrapTcS
512
513 wrapWarnTcS :: TcM a -> TcS a 
514 -- The thing wrapped should just add a warning, or no-op
515 -- There's no static check; it's up to the user
516 wrapWarnTcS = wrapTcS
517
518 failTcS, panicTcS :: SDoc -> TcS a
519 failTcS      = wrapTcS . TcM.failWith
520 panicTcS doc = pprPanic "TcCanonical" doc
521
522 traceTcS :: String -> SDoc -> TcS ()
523 traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
524
525 traceTcS0 :: String -> SDoc -> TcS ()
526 traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
527
528 runTcS :: SimplContext
529        -> Untouchables         -- Untouchables
530        -> TcS a                -- What to run
531        -> TcM (a, Bag FrozenError, Bag EvBind)
532 runTcS context untouch tcs 
533   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
534        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
535        ; err_ref <- TcM.newTcRef emptyBag
536        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
537                           , tcs_ty_binds = ty_binds_var
538                           , tcs_context  = context
539                           , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
540                           , tcs_errors   = err_ref
541                           }
542
543              -- Run the computation
544        ; res <- unTcS tcs env
545              -- Perform the type unifications required
546        ; ty_binds <- TcM.readTcRef ty_binds_var
547        ; mapM_ do_unification (varEnvElts ty_binds)
548
549              -- And return
550        ; frozen_errors <- TcM.readTcRef err_ref
551        ; ev_binds      <- TcM.readTcRef evb_ref
552        ; return (res, frozen_errors, evBindMapBinds ev_binds) }
553   where
554     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
555
556 nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a
557 nestImplicTcS ref untch (TcS thing_inside)
558   = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, 
559                      tcs_context = ctxt, 
560                      tcs_errors = err_ref } ->
561     let 
562        nest_env = TcSEnv { tcs_ev_binds = ref
563                          , tcs_ty_binds = ty_binds
564                          , tcs_untch    = untch
565                          , tcs_context  = ctxtUnderImplic ctxt 
566                          , tcs_errors   = err_ref }
567     in 
568     thing_inside nest_env
569
570 recoverTcS :: TcS a -> TcS a -> TcS a
571 recoverTcS (TcS recovery_code) (TcS thing_inside)
572   = TcS $ \ env ->
573     TcM.recoverM (recovery_code env) (thing_inside env)
574
575 ctxtUnderImplic :: SimplContext -> SimplContext
576 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
577 ctxtUnderImplic SimplRuleLhs = SimplCheck
578 ctxtUnderImplic ctxt         = ctxt
579
580 tryTcS :: TcS a -> TcS a
581 -- Like runTcS, but from within the TcS monad 
582 -- Ignore all the evidence generated, and do not affect caller's evidence!
583 tryTcS tcs 
584   = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
585                     ; ev_binds_var <- TcM.newTcEvBinds
586                     ; err_ref      <- TcM.newTcRef emptyBag
587                     ; let env1 = env { tcs_ev_binds = ev_binds_var
588                                      , tcs_ty_binds = ty_binds_var 
589                                      , tcs_errors   = err_ref }
590                     ; unTcS tcs env1 })
591
592 -- Update TcEvBinds 
593 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
594
595 getDynFlags :: TcS DynFlags
596 getDynFlags = wrapTcS TcM.getDOpts
597
598 getTcSContext :: TcS SimplContext
599 getTcSContext = TcS (return . tcs_context)
600
601 getTcEvBinds :: TcS EvBindsVar
602 getTcEvBinds = TcS (return . tcs_ev_binds) 
603
604 getUntouchables :: TcS TcsUntouchables
605 getUntouchables = TcS (return . tcs_untch)
606
607 getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
608 getTcSTyBinds = TcS (return . tcs_ty_binds)
609
610 getTcSErrors :: TcS (IORef (Bag FrozenError))
611 getTcSErrors = TcS (return . tcs_errors)
612
613 getTcSErrorsBag :: TcS (Bag FrozenError) 
614 getTcSErrorsBag = do { err_ref <- getTcSErrors 
615                      ; wrapTcS $ TcM.readTcRef err_ref }
616
617 getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) 
618 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
619
620
621 getTcEvBindsBag :: TcS EvBindMap
622 getTcEvBindsBag
623   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
624        ; wrapTcS $ TcM.readTcRef ev_ref }
625
626 setWantedCoBind :: CoVar -> Coercion -> TcS () 
627 setWantedCoBind cv co 
628   = setEvBind cv (EvCoercion co)
629      -- Was: wrapTcS $ TcM.writeWantedCoVar cv co 
630
631 setDerivedCoBind :: CoVar -> Coercion -> TcS () 
632 setDerivedCoBind cv co 
633   = setEvBind cv (EvCoercion co)
634
635 setWantedTyBind :: TcTyVar -> TcType -> TcS () 
636 -- Add a type binding
637 -- We never do this twice!
638 setWantedTyBind tv ty 
639   = do { ref <- getTcSTyBinds
640        ; wrapTcS $ 
641          do { ty_binds <- TcM.readTcRef ref
642 #ifdef DEBUG
643             ; TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
644               vcat [ text "TERRIBLE ERROR: double set of meta type variable"
645                    , ppr tv <+> text ":=" <+> ppr ty
646                    , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
647 #endif
648             ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
649
650 setIPBind :: EvVar -> EvTerm -> TcS () 
651 setIPBind = setEvBind 
652
653 setDictBind :: EvVar -> EvTerm -> TcS () 
654 setDictBind = setEvBind 
655
656 setEvBind :: EvVar -> EvTerm -> TcS () 
657 -- Internal
658 setEvBind ev rhs 
659   = do { tc_evbinds <- getTcEvBinds 
660        ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
661
662 newTcEvBindsTcS :: TcS EvBindsVar
663 newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
664
665 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
666 warnTcS loc warn_if doc 
667   | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
668   | otherwise = return ()
669
670 getDefaultInfo ::  TcS (SimplContext, [Type], (Bool, Bool))
671 getDefaultInfo 
672   = do { ctxt <- getTcSContext
673        ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
674        ; return (ctxt, tys, flags) }
675
676
677
678 -- Recording errors in the TcS monad
679 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
680
681 addErrorTcS :: ErrorKind -> CtFlavor -> TcType -> TcType -> TcS ()
682 addErrorTcS frknd fl ty1 ty2
683   = do { err_ref <- getTcSErrors
684        ; wrapTcS $ do
685        { TcM.updTcRef err_ref $ \ errs ->
686            consBag (FrozenError frknd fl ty1 ty2) errs
687
688            -- If there's an error in the *given* constraints,
689            -- stop right now, to avoid a cascade of errors
690            -- in the wanteds
691        ; when (isGiven fl) TcM.failM
692
693        ; return () } }
694
695 -- Just get some environments needed for instance looking up and matching
696 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
697
698 getInstEnvs :: TcS (InstEnv, InstEnv) 
699 getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs 
700
701 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) 
702 getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
703
704 getTopEnv :: TcS HscEnv 
705 getTopEnv = wrapTcS $ TcM.getTopEnv 
706
707 getGblEnv :: TcS TcGblEnv 
708 getGblEnv = wrapTcS $ TcM.getGblEnv 
709
710 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
711 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
712
713 checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS () 
714 checkWellStagedDFun pred dfun_id loc 
715   = wrapTcS $ TcM.setCtLoc loc $ 
716     do { use_stage <- TcM.getStage
717        ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
718   where
719     pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
720     bind_lvl = TcM.topIdLvl dfun_id
721
722 pprEq :: TcType -> TcType -> SDoc
723 pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
724
725 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
726 isTouchableMetaTyVar tv 
727   = do { untch <- getUntouchables
728        ; return $ isTouchableMetaTyVar_InRange untch tv } 
729
730 isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool 
731 isTouchableMetaTyVar_InRange (untch,untch_tcs) tv 
732   = case tcTyVarDetails tv of 
733       MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
734                         -- See Note [Touchable meta type variables] 
735       MetaTv {}      -> inTouchableRange untch tv 
736       _              -> False 
737
738
739 \end{code}
740
741
742 Note [Touchable meta type variables]
743 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
744 Meta type variables allocated *by the constraint solver itself* are always
745 touchable.  Example: 
746    instance C a b => D [a] where...
747 if we use this instance declaration we "make up" a fresh meta type
748 variable for 'b', which we must later guess.  (Perhaps C has a
749 functional dependency.)  But since we aren't in the constraint *generator*
750 we can't allocate a Unique in the touchable range for this implication
751 constraint.  Instead, we mark it as a "TcsTv", which makes it always-touchable.
752
753
754 \begin{code}
755 -- Flatten skolems
756 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
757
758 newFlattenSkolemTy :: TcType -> TcS TcType
759 newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
760
761 newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
762 newFlattenSkolemTyVar ty
763   = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique
764                             ; let name = mkSysTvName uniq (fsLit "f")
765                             ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } 
766        ; traceTcS "New Flatten Skolem Born" $ 
767            (ppr tv <+> text "[:= " <+> ppr ty <+> text "]")
768        ; return tv }
769
770 -- Instantiations 
771 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772
773 instDFunTypes :: [Either TyVar TcType] -> TcS [TcType] 
774 instDFunTypes mb_inst_tys 
775   = mapM inst_tv mb_inst_tys
776   where
777     inst_tv :: Either TyVar TcType -> TcS Type
778     inst_tv (Left tv)  = mkTyVarTy <$> instFlexiTcS tv
779     inst_tv (Right ty) = return ty 
780
781 instDFunConstraints :: TcThetaType -> TcS [EvVar] 
782 instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds 
783
784
785 instFlexiTcS :: TyVar -> TcS TcTyVar 
786 -- Like TcM.instMetaTyVar but the variable that is created is always
787 -- touchable; we are supposed to guess its instantiation. 
788 -- See Note [Touchable meta type variables] 
789 instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) 
790
791 newFlexiTcSTy :: Kind -> TcS TcType  
792 newFlexiTcSTy knd 
793   = wrapTcS $
794     do { uniq <- TcM.newUnique 
795        ; ref  <- TcM.newMutVar  Flexi 
796        ; let name = mkSysTvName uniq (fsLit "uf")
797        ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) }
798
799 isFlexiTcsTv :: TyVar -> Bool
800 isFlexiTcsTv tv
801   | not (isTcTyVar tv)                  = False
802   | MetaTv TcsTv _ <- tcTyVarDetails tv = True
803   | otherwise                           = False
804
805 newKindConstraint :: TcTyVar -> Kind -> TcS CoVar
806 -- Create new wanted CoVar that constrains the type to have the specified kind. 
807 newKindConstraint tv knd 
808   = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd 
809        ; let ty_k = mkTyVarTy tv_k
810        ; co_var <- newWantedCoVar (mkTyVarTy tv) ty_k
811        ; return co_var }
812
813 instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
814 instFlexiTcSHelper tvname tvkind
815   = wrapTcS $ 
816     do { uniq <- TcM.newUnique 
817        ; ref  <- TcM.newMutVar  Flexi 
818        ; let name = setNameUnique tvname uniq 
819              kind = tvkind 
820        ; return (mkTcTyVar name kind (MetaTv TcsTv ref)) }
821
822 -- Superclasses and recursive dictionaries 
823 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
824
825 newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar 
826 newGivOrDerEvVar pty evtrm 
827   = do { ev <- wrapTcS $ TcM.newEvVar pty 
828        ; setEvBind ev evtrm 
829        ; return ev }
830
831 newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar 
832 -- Note we create immutable variables for given or derived, since we
833 -- must bind them to TcEvBinds (because their evidence may involve 
834 -- superclasses). However we should be able to override existing
835 -- 'derived' evidence, even in TcEvBinds 
836 newGivOrDerCoVar ty1 ty2 co 
837   = do { cv <- newCoVar ty1 ty2
838        ; setEvBind cv (EvCoercion co) 
839        ; return cv } 
840
841 newWantedCoVar :: TcType -> TcType -> TcS EvVar 
842 newWantedCoVar ty1 ty2 =  wrapTcS $ TcM.newWantedCoVar ty1 ty2 
843
844
845 newCoVar :: TcType -> TcType -> TcS EvVar 
846 newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 
847
848 newIPVar :: IPName Name -> TcType -> TcS EvVar 
849 newIPVar nm ty = wrapTcS $ TcM.newIP nm ty 
850
851 newDictVar :: Class -> [TcType] -> TcS EvVar 
852 newDictVar cl tys = wrapTcS $ TcM.newDict cl tys 
853 \end{code} 
854
855
856 \begin{code} 
857 isGoodRecEv :: EvVar -> EvVar -> TcS Bool
858 -- In a call (isGoodRecEv ev wv), we are considering solving wv 
859 -- using some term that involves ev, such as:
860 -- by setting           wv = ev
861 -- or                   wv = EvCast x |> ev
862 -- etc. 
863 -- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
864 -- in an "unguarded" way. So isGoodRecEv looks at the evidence ev 
865 -- recursively through the evidence binds, to see if uses of 'wv' are guarded.
866 --
867 -- Guarded means: more instance calls than superclass selections. We
868 -- compute this by chasing the evidence, adding +1 for every instance
869 -- call (constructor) and -1 for every superclass selection (destructor).
870 --
871 -- See Note [Superclasses and recursive dictionaries] in TcInteract
872 isGoodRecEv ev_var wv
873   = do { tc_evbinds <- getTcEvBindsBag 
874        ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var 
875        ; return $ case mb of 
876                     Nothing -> True 
877                     Just min_guardedness -> min_guardedness > 0
878        }
879
880   where chase_ev_var :: EvBindMap   -- Evidence binds 
881                  -> EvVar           -- Target variable whose gravity we want to return
882                  -> Int             -- Current gravity 
883                  -> [EvVar]         -- Visited nodes
884                  -> EvVar           -- Current node 
885                  -> TcS (Maybe Int)
886         chase_ev_var assocs trg curr_grav visited orig
887             | trg == orig         = return $ Just curr_grav
888             | orig `elem` visited = return $ Nothing 
889             | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
890             = chase_ev assocs trg curr_grav (orig:visited) ev_trm
891
892             | otherwise = return Nothing
893
894         chase_ev assocs trg curr_grav visited (EvId v) 
895             = chase_ev_var assocs trg curr_grav visited v
896         chase_ev assocs trg curr_grav visited (EvSuperClass d_id _) 
897             = chase_ev_var assocs trg (curr_grav-1) visited d_id
898         chase_ev assocs trg curr_grav visited (EvCast v co)
899             = do { m1 <- chase_ev_var assocs trg curr_grav visited v
900                  ; m2 <- chase_co assocs trg curr_grav visited co
901                  ; return (comb_chase_res Nothing [m1,m2]) } 
902
903         chase_ev assocs trg curr_grav visited (EvCoercion co)
904             = chase_co assocs trg curr_grav visited co
905         chase_ev assocs trg curr_grav visited (EvDFunApp _ _ _ev_vars ev_deps)
906             = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps
907                                     -- Notice that we chase the ev_deps and not the ev_vars
908                                     -- See Note [Dependencies in self dictionaries] in TcSimplify
909                  ; return (comb_chase_res Nothing chase_results) }
910
911         chase_co assocs trg curr_grav visited co 
912             = -- Look for all the coercion variables in the coercion 
913               -- chase them, and combine the results. This is OK since the
914               -- coercion will not contain any superclass terms -- anything 
915               -- that involves dictionaries will be bound in assocs. 
916               let co_vars       = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
917                                              (tyVarsOfType co)
918               in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
919                     ; return (comb_chase_res Nothing chase_results) } 
920
921         comb_chase_res f []                   = f 
922         comb_chase_res f (Nothing:rest)       = comb_chase_res f rest 
923         comb_chase_res Nothing (Just n:rest)  = comb_chase_res (Just n) rest
924         comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest 
925
926
927 -- Matching and looking up classes and family instances
928 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
929
930 data MatchInstResult mi
931   = MatchInstNo         -- No matching instance 
932   | MatchInstSingle mi  -- Single matching instance
933   | MatchInstMany       -- Multiple matching instances
934
935
936 matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType])) 
937 -- Look up a class constraint in the instance environment
938 matchClass clas tys
939   = do  { let pred = mkClassPred clas tys 
940         ; instEnvs <- getInstEnvs
941         ; case lookupInstEnv instEnvs clas tys of {
942             ([], unifs)               -- Nothing matches  
943                 -> do { traceTcS "matchClass not matching"
944                                  (vcat [ text "dict" <+> ppr pred, 
945                                          text "unifs" <+> ppr unifs ]) 
946                       ; return MatchInstNo  
947                       } ;  
948             ([(ispec, inst_tys)], []) -- A single match 
949                 -> do   { let dfun_id = is_dfun ispec
950                         ; traceTcS "matchClass success"
951                                    (vcat [text "dict" <+> ppr pred, 
952                                           text "witness" <+> ppr dfun_id
953                                            <+> ppr (idType dfun_id) ])
954                                   -- Record that this dfun is needed
955                         ; record_dfun_usage dfun_id
956                         ; return $ MatchInstSingle (dfun_id, inst_tys) 
957                         } ;
958             (matches, unifs)          -- More than one matches 
959                 -> do   { traceTcS "matchClass multiple matches, deferring choice"
960                                    (vcat [text "dict" <+> ppr pred,
961                                           text "matches" <+> ppr matches,
962                                           text "unifs" <+> ppr unifs])
963                         ; return MatchInstMany 
964                         }
965         }
966         }
967   where record_dfun_usage :: Id -> TcS () 
968         record_dfun_usage dfun_id 
969           = do { hsc_env <- getTopEnv 
970                ; let  dfun_name = idName dfun_id
971                       dfun_mod  = ASSERT( isExternalName dfun_name ) 
972                                   nameModule dfun_name
973                ; if isInternalName dfun_name ||    -- Internal name => defined in this module
974                     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
975                  then return () -- internal, or in another package
976                  else do updInstUses dfun_id 
977                }
978
979         updInstUses :: Id -> TcS () 
980         updInstUses dfun_id 
981             = do { tcg_env <- getGblEnv 
982                  ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) 
983                                             (`addOneToNameSet` idName dfun_id) 
984                  }
985
986 matchFam :: TyCon 
987          -> [Type] 
988          -> TcS (MatchInstResult (TyCon, [Type]))
989 matchFam tycon args
990   = do { mb <- wrapTcS $ TcM.tcLookupFamInst tycon args
991        ; case mb of 
992            Nothing  -> return MatchInstNo 
993            Just res -> return $ MatchInstSingle res
994        -- DV: We never return MatchInstMany, since tcLookupFamInst never returns 
995        -- multiple matches. Check. 
996        }
997
998
999 -- Functional dependencies, instantiation of equations
1000 -------------------------------------------------------
1001
1002 mkWantedFunDepEqns :: WantedLoc
1003                    -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
1004                    -> TcS [WantedEvVar] 
1005 mkWantedFunDepEqns _   [] = return []
1006 mkWantedFunDepEqns loc eqns
1007   = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
1008        ; wevvars <- mapM to_work_item eqns
1009        ; return $ concat wevvars }
1010   where
1011     to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
1012     to_work_item ((qtvs, pairs), d1, d2)
1013       = do { let tvs = varSetElems qtvs
1014            ; tvs' <- mapM instFlexiTcS tvs
1015            ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
1016                  loc'  = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
1017            ; mapM (do_one subst loc') pairs }
1018
1019     do_one subst loc' (ty1, ty2)
1020        = do { let sty1 = substTy subst ty1
1021                   sty2 = substTy subst ty2
1022             ; ev <- newWantedCoVar sty1 sty2
1023             ; return (WantedEvVar ev loc') }
1024
1025 pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
1026 pprEquationDoc (eqn, (p1, _), (p2, _)) 
1027   = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
1028
1029 mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
1030          -> TcM (TidyEnv, SDoc)
1031 mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
1032   = do  { pred1' <- TcM.zonkTcPredType pred1
1033         ; pred2' <- TcM.zonkTcPredType pred2
1034         ; let { pred1'' = tidyPred tidy_env pred1'
1035               ; pred2'' = tidyPred tidy_env pred2' }
1036         ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
1037                           nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
1038                           nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
1039         ; return (tidy_env, msg) }
1040 \end{code}