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}