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}