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,
   8     CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals,
   9     mkWantedConstraints, deCanonicaliseWanted,
  10     makeGivens, makeSolved,
  11
  12     CtFlavor (..), isWanted, isGiven, isDerived, canRewrite,
  13     joinFlavors, mkGivenFlavor,
  14
  15     TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0,  -- Basic functionality
  16     tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS,
  17     SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
  18
  19        -- Creation of evidence variables
  20
  21     newWantedCoVar, newGivOrDerCoVar, newGivOrDerEvVar,
  22     newIPVar, newDictVar, newKindConstraint,
  23
  24        -- Setting evidence variables
  25     setWantedCoBind, setDerivedCoBind,
  26     setIPBind, setDictBind, setEvBind,
  27
  28     setWantedTyBind,
  29
  30     newTcEvBindsTcS,
  31
  32     getInstEnvs, getFamInstEnvs,                -- Getting the environments
  33     getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
  34     getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
  35
  36
  37     newFlattenSkolemTy,                         -- Flatten skolems
  38
  39
  40     instDFunTypes,                              -- Instantiation
  41     instDFunConstraints,
  42
  43     isGoodRecEv,
  44
  45     isTouchableMetaTyVar,
  46
  47     getDefaultInfo, getDynFlags,
  48
  49     matchClass, matchFam, MatchInstResult (..),
  50     checkWellStagedDFun,
  51     warnTcS,
  52     pprEq,                                   -- Smaller utils, re-exported from TcM
  53                                              -- TODO (DV): these are only really used in the
  54                                              -- instance matcher in TcSimplify. I am wondering
  55                                              -- if the whole instance matcher simply belongs
  56                                              -- here
  57
  58
  59     mkWantedFunDepEqns                       -- Instantiation of 'Equations' from FunDeps
  60
  61 ) where
  62
  63 #include "HsVersions.h"
  64
  65 import HscTypes
  66 import BasicTypes
  67
  68 import Inst
  69 import InstEnv
  70 import FamInst
  71 import FamInstEnv
  72
  73 import NameSet ( addOneToNameSet )
  74
  75 import qualified TcRnMonad as TcM
  76 import qualified TcMType as TcM
  77 import qualified TcEnv as TcM
  78        ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
  79 import TcType
  80 import Module
  81 import DynFlags
  82
  83 import Coercion
  84 import Class
  85 import TyCon
  86 import TypeRep
  87
  88 import Name
  89 import Var
  90 import VarEnv
  91 import Outputable
  92 import Bag
  93 import MonadUtils
  94 import VarSet
  95 import FastString
  96
  97 import HsBinds               -- for TcEvBinds stuff
  98 import Id
  99 import FunDeps
 100
 101 import TcRnTypes
 102
 103 import Control.Monad
 104 import Data.IORef
 105 \end{code}
 106
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 %*                       Canonical constraints                          *
 111 %*                                                                      *
 112 %*   These are the constraints the low-level simplifier works with      *
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 \begin{code}
 117 -- Types without any type functions inside.  However, note that xi
 118 -- types CAN contain unexpanded type synonyms; however, the
 119 -- (transitive) expansions of those type synonyms will not contain any
 120 -- type functions.
 121 type Xi = Type       -- In many comments, "xi" ranges over Xi
 122
 123 type CanonicalCts = Bag CanonicalCt
 124
 125 data CanonicalCt
 126   -- Atomic canonical constraints
 127   = CDictCan {  -- e.g.  Num xi
 128       cc_id     :: EvVar,
 129       cc_flavor :: CtFlavor,
 130       cc_class  :: Class,
 131       cc_tyargs :: [Xi]
 132     }
 133
 134   | CIPCan {    -- ?x::tau
 135       -- See note [Canonical implicit parameter constraints].
 136       cc_id     :: EvVar,
 137       cc_flavor :: CtFlavor,
 138       cc_ip_nm  :: IPName Name,
 139       cc_ip_ty  :: TcTauType
 140     }
 141
 142   | CTyEqCan {  -- tv ~ xi      (recall xi means function free)
 143        -- Invariant:
 144        --   * tv not in tvs(xi)   (occurs check)
 145        --   * If tv is a MetaTyVar, then typeKind xi <: typeKind tv
 146        --              a skolem,    then typeKind xi =  typeKind tv
 147       cc_id     :: EvVar,
 148       cc_flavor :: CtFlavor,
 149       cc_tyvar :: TcTyVar,
 150       cc_rhs   :: Xi
 151     }
 152
 153   | CFunEqCan {  -- F xis ~ xi
 154                  -- Invariant: * isSynFamilyTyCon cc_fun
 155                  --            * cc_rhs is not a touchable unification variable
 156                  --                   See Note [No touchables as FunEq RHS]
 157                  --            * typeKind (TyConApp cc_fun cc_tyargs) == typeKind cc_rhs
 158       cc_id     :: EvVar,
 159       cc_flavor :: CtFlavor,
 160       cc_fun    :: TyCon,       -- A type function
 161       cc_tyargs :: [Xi],        -- Either under-saturated or exactly saturated
 162       cc_rhs    :: Xi           --    *never* over-saturated (because if so
 163                                 --    we should have decomposed)
 164
 165     }
 166
 167 makeGivens :: CanonicalCts -> CanonicalCts
 168 makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
 169            -- The UnkSkol doesn't matter because these givens are
 170            -- not contradictory (else we'd have rejected them already)
 171
 172 makeSolved :: CanonicalCt -> CanonicalCt
 173 -- Record that a constraint is now solved
 174 --        Wanted         -> Derived
 175 --        Given, Derived -> no-op
 176 makeSolved ct
 177   | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc }
 178   | otherwise                  = ct
 179
 180 mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
 181 mkWantedConstraints flats implics
 182   = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics
 183
 184 deCanonicaliseWanted :: CanonicalCt -> WantedEvVar
 185 deCanonicaliseWanted ct
 186   = WARN( not (isWanted $ cc_flavor ct), ppr ct )
 187     let Wanted loc = cc_flavor ct
 188     in WantedEvVar (cc_id ct) loc
 189
 190 tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
 191 tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
 192 tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
 193 tyVarsOfCanonical (CDictCan { cc_tyargs = tys })               = tyVarsOfTypes tys
 194 tyVarsOfCanonical (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
 195
 196 tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
 197 tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
 198
 199 instance Outputable CanonicalCt where
 200   ppr (CDictCan d fl cls tys)
 201       = ppr fl <+> ppr d  <+> dcolon <+> pprClassPred cls tys
 202   ppr (CIPCan ip fl ip_nm ty)
 203       = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
 204   ppr (CTyEqCan co fl tv ty)
 205       = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
 206   ppr (CFunEqCan co fl tc tys ty)
 207       = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
 208 \end{code}
 209
 210
 211 Note [No touchables as FunEq RHS]
 212 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 213 Notice that (F xis ~ beta), where beta is an touchable unification
 214 variable, is not canonical.  Why?
 215   * If (F xis ~ beta) was the only wanted constraint, we'd
 216     definitely want to spontaneously-unify it
 217
 218   * But suppose we had an earlier wanted (beta ~ Int), and
 219     have already spontaneously unified it.  Then we have an
 220     identity given (id : beta ~ Int) in the inert set.
 221
 222   * But (F xis ~ beta) does not react with that given (because we
 223     don't subsitute on the RHS of a function equality).  So there's a
 224     serious danger that we'd spontaneously unify it a second time.
 225
 226 Hence the invariant.
 227
 228 Note [Canonical implicit parameter constraints]
 229 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 230 The type in a canonical implicit parameter constraint doesn't need to
 231 be a xi (type-function-free type) since we can defer the flattening
 232 until checking this type for equality with another type.  If we
 233 encounter two IP constraints with the same name, they MUST have the
 234 same type, and at that point we can generate a flattened equality
 235 constraint between the types.  (On the other hand, the types in two
 236 class constraints for the same class MAY be equal, so they need to be
 237 flattened in the first place to facilitate comparing them.)
 238
 239 \begin{code}
 240 singleCCan :: CanonicalCt -> CanonicalCts
 241 singleCCan = unitBag
 242
 243 andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts
 244 andCCan = unionBags
 245
 246 extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts
 247 extendCCans = snocBag
 248
 249 andCCans :: [CanonicalCts] -> CanonicalCts
 250 andCCans = unionManyBags
 251
 252 emptyCCan :: CanonicalCts
 253 emptyCCan = emptyBag
 254
 255 isEmptyCCan :: CanonicalCts -> Bool
 256 isEmptyCCan = isEmptyBag
 257 \end{code}
 258
 259 %************************************************************************
 260 %*                                                                      *
 261                     CtFlavor
 262          The "flavor" of a canonical constraint
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 data CtFlavor
 268   = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
 269   | Derived WantedLoc -- We have evidence for this constraint in TcEvBinds;
 270                       --   *however* this evidence can contain wanteds, so
 271                       --   it's valid only provisionally to the solution of
 272                       --   these wanteds
 273   | Wanted WantedLoc  -- We have no evidence bindings for this constraint.
 274
 275 instance Outputable CtFlavor where
 276   ppr (Given _)   = ptext (sLit "[Given]")
 277   ppr (Wanted _)  = ptext (sLit "[Wanted]")
 278   ppr (Derived _) = ptext (sLit "[Derived]")
 279
 280 isWanted :: CtFlavor -> Bool
 281 isWanted (Wanted {}) = True
 282 isWanted _           = False
 283
 284 isGiven :: CtFlavor -> Bool
 285 isGiven (Given {}) = True
 286 isGiven _          = False
 287
 288 isDerived :: CtFlavor -> Bool
 289 isDerived (Derived {}) = True
 290 isDerived _            = False
 291
 292 canRewrite :: CtFlavor -> CtFlavor -> Bool
 293 -- canRewrite ctid1 ctid2
 294 -- The constraint ctid1 can be used to rewrite ctid2
 295 canRewrite (Given {})   _            = True
 296 canRewrite (Derived {}) (Wanted {})  = True
 297 canRewrite (Derived {}) (Derived {}) = True
 298 canRewrite (Wanted {})  (Wanted {})  = True
 299 canRewrite _ _ = False
 300
 301 joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor
 302 joinFlavors (Wanted loc) _  = Wanted loc
 303 joinFlavors _ (Wanted loc)  = Wanted loc
 304 joinFlavors (Derived loc) _ = Derived loc
 305 joinFlavors _ (Derived loc) = Derived loc
 306 joinFlavors (Given loc) _   = Given loc
 307
 308 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
 309 mkGivenFlavor (Wanted  loc) sk = Given (setCtLocOrigin loc sk)
 310 mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
 311 mkGivenFlavor (Given   loc) sk = Given (setCtLocOrigin loc sk)
 312 \end{code}
 313
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 %*              The TcS solver monad                                    *
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 Note [The TcS monad]
 322 ~~~~~~~~~~~~~~~~~~~~
 323 The TcS monad is a weak form of the main Tc monad
 324
 325 All you can do is
 326     * fail
 327     * allocate new variables
 328     * fill in evidence variables
 329
 330 Filling in a dictionary evidence variable means to create a binding
 331 for it, so TcS carries a mutable location where the binding can be
 332 added.  This is initialised from the innermost implication constraint.
 333
 334 \begin{code}
 335 data TcSEnv
 336   = TcSEnv {
 337       tcs_ev_binds :: EvBindsVar,
 338           -- Evidence bindings
 339
 340       tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
 341           -- Global type bindings
 342
 343       tcs_context :: SimplContext
 344     }
 345
 346 data SimplContext
 347   = SimplInfer          -- Inferring type of a let-bound thing
 348   | SimplRuleLhs        -- Inferring type of a RULE lhs
 349   | SimplInteractive    -- Inferring type at GHCi prompt
 350   | SimplCheck          -- Checking a type signature or RULE rhs
 351
 352 instance Outputable SimplContext where
 353   ppr SimplInfer       = ptext (sLit "SimplInfer")
 354   ppr SimplRuleLhs     = ptext (sLit "SimplRuleLhs")
 355   ppr SimplInteractive = ptext (sLit "SimplInteractive")
 356   ppr SimplCheck       = ptext (sLit "SimplCheck")
 357
 358 isInteractive :: SimplContext -> Bool
 359 isInteractive SimplInteractive = True
 360 isInteractive _                = False
 361
 362 simplEqsOnly :: SimplContext -> Bool
 363 -- Simplify equalities only, not dictionaries
 364 -- This is used for the LHS of rules; ee
 365 -- Note [Simplifying RULE lhs constraints] in TcSimplify
 366 simplEqsOnly SimplRuleLhs = True
 367 simplEqsOnly _            = False
 368
 369 performDefaulting :: SimplContext -> Bool
 370 performDefaulting SimplInfer       = False
 371 performDefaulting SimplRuleLhs     = False
 372 performDefaulting SimplInteractive = True
 373 performDefaulting SimplCheck       = True
 374
 375 ---------------
 376 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
 377
 378 instance Functor TcS where
 379   fmap f m = TcS $ fmap f . unTcS m
 380
 381 instance Monad TcS where
 382   return x  = TcS (\_ -> return x)
 383   fail err  = TcS (\_ -> fail err)
 384   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
 385
 386 -- Basic functionality
 387 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 388 wrapTcS :: TcM a -> TcS a
 389 -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
 390 -- and TcS is supposed to have limited functionality
 391 wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
 392
 393 wrapErrTcS :: TcM a -> TcS a
 394 -- The thing wrapped should just fail
 395 -- There's no static check; it's up to the user
 396 -- Having a variant for each error message is too painful
 397 wrapErrTcS = wrapTcS
 398
 399 wrapWarnTcS :: TcM a -> TcS a
 400 -- The thing wrapped should just add a warning, or no-op
 401 -- There's no static check; it's up to the user
 402 wrapWarnTcS = wrapTcS
 403
 404 failTcS, panicTcS :: SDoc -> TcS a
 405 failTcS      = wrapTcS . TcM.failWith
 406 panicTcS doc = pprPanic "TcCanonical" doc
 407
 408 traceTcS :: String -> SDoc -> TcS ()
 409 traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
 410
 411 traceTcS0 :: String -> SDoc -> TcS ()
 412 traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
 413
 414 runTcS :: SimplContext
 415        -> TcTyVarSet           -- Untouchables
 416        -> TcS a                -- What to run
 417        -> TcM (a, Bag EvBind)
 418 runTcS context untouch tcs
 419   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
 420        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
 421        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
 422                           , tcs_ty_binds = ty_binds_var
 423                           , tcs_context = context }
 424
 425              -- Run the computation
 426        ; res <- TcM.setUntouchables untouch (unTcS tcs env)
 427
 428              -- Perform the type unifications required
 429        ; ty_binds <- TcM.readTcRef ty_binds_var
 430        ; mapM_ do_unification (varEnvElts ty_binds)
 431
 432              -- And return
 433        ; ev_binds <- TcM.readTcRef evb_ref
 434        ; return (res, evBindMapBinds ev_binds) }
 435   where
 436     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
 437
 438
 439 nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
 440 nestImplicTcS ref untouch tcs
 441   = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } ->
 442     let
 443        nest_env = TcSEnv { tcs_ev_binds = ref
 444                          , tcs_ty_binds = ty_binds
 445                          , tcs_context = ctxtUnderImplic ctxt }
 446     in
 447     TcM.setUntouchables untouch (unTcS tcs nest_env)
 448
 449 ctxtUnderImplic :: SimplContext -> SimplContext
 450 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
 451 ctxtUnderImplic SimplRuleLhs = SimplCheck
 452 ctxtUnderImplic ctxt         = ctxt
 453
 454 tryTcS :: TcTyVarSet -> TcS a -> TcS a
 455 -- Like runTcS, but from within the TcS monad
 456 -- Ignore all the evidence generated, and do not affect caller's evidence!
 457 tryTcS untch tcs
 458   = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
 459                     ; ev_binds_var <- TcM.newTcEvBinds
 460                     ; let env1 = env { tcs_ev_binds = ev_binds_var
 461                                      , tcs_ty_binds = ty_binds_var }
 462                     ; TcM.setUntouchables untch (unTcS tcs env1) })
 463
 464 -- Update TcEvBinds
 465 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 466
 467 getDynFlags :: TcS DynFlags
 468 getDynFlags = wrapTcS TcM.getDOpts
 469
 470 getTcSContext :: TcS SimplContext
 471 getTcSContext = TcS (return . tcs_context)
 472
 473 getTcEvBinds :: TcS EvBindsVar
 474 getTcEvBinds = TcS (return . tcs_ev_binds)
 475
 476 getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
 477 getTcSTyBinds = TcS (return . tcs_ty_binds)
 478
 479 getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
 480 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
 481
 482
 483 getTcEvBindsBag :: TcS EvBindMap
 484 getTcEvBindsBag
 485   = do { EvBindsVar ev_ref _ <- getTcEvBinds
 486        ; wrapTcS $ TcM.readTcRef ev_ref }
 487
 488 setWantedCoBind :: CoVar -> Coercion -> TcS ()
 489 setWantedCoBind cv co
 490   = setEvBind cv (EvCoercion co)
 491      -- Was: wrapTcS $ TcM.writeWantedCoVar cv co
 492
 493 setDerivedCoBind :: CoVar -> Coercion -> TcS ()
 494 setDerivedCoBind cv co
 495   = setEvBind cv (EvCoercion co)
 496
 497 setWantedTyBind :: TcTyVar -> TcType -> TcS ()
 498 -- Add a type binding
 499 setWantedTyBind tv ty
 500   = do { ref <- getTcSTyBinds
 501        ; wrapTcS $
 502          do { ty_binds <- TcM.readTcRef ref
 503             ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
 504
 505 setIPBind :: EvVar -> EvTerm -> TcS ()
 506 setIPBind = setEvBind
 507
 508 setDictBind :: EvVar -> EvTerm -> TcS ()
 509 setDictBind = setEvBind
 510
 511 setEvBind :: EvVar -> EvTerm -> TcS ()
 512 -- Internal
 513 setEvBind ev rhs
 514   = do { tc_evbinds <- getTcEvBinds
 515        ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
 516
 517 newTcEvBindsTcS :: TcS EvBindsVar
 518 newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
 519
 520 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
 521 warnTcS loc warn_if doc
 522   | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
 523   | otherwise = return ()
 524
 525 getDefaultInfo ::  TcS (SimplContext, [Type], (Bool, Bool))
 526 getDefaultInfo
 527   = do { ctxt <- getTcSContext
 528        ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
 529        ; return (ctxt, tys, flags) }
 530
 531 -- Just get some environments needed for instance looking up and matching
 532 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 533
 534 getInstEnvs :: TcS (InstEnv, InstEnv)
 535 getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs
 536
 537 getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
 538 getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
 539
 540 getTopEnv :: TcS HscEnv
 541 getTopEnv = wrapTcS $ TcM.getTopEnv
 542
 543 getGblEnv :: TcS TcGblEnv
 544 getGblEnv = wrapTcS $ TcM.getGblEnv
 545
 546 getUntouchablesTcS :: TcS TcTyVarSet
 547 getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
 548
 549 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 550 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 551
 552 checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS ()
 553 checkWellStagedDFun pred dfun_id loc
 554   = wrapTcS $ TcM.setCtLoc loc $
 555     do { use_stage <- TcM.getStage
 556        ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
 557   where
 558     pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
 559     bind_lvl = TcM.topIdLvl dfun_id
 560
 561 pprEq :: TcType -> TcType -> SDoc
 562 pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
 563
 564 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
 565 -- is touchable variable!
 566 isTouchableMetaTyVar v
 567   | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v;
 568                                  ; return (not untch) }
 569   | otherwise     = return False
 570
 571
 572 -- Flatten skolems
 573 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 574
 575 newFlattenSkolemTy :: TcType -> TcS TcType
 576 newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
 577   where newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
 578         newFlattenSkolemTyVar ty
 579             = wrapTcS $ do { uniq <- TcM.newUnique
 580                            ; let name = mkSysTvName uniq (fsLit "f")
 581                            ; return $
 582                              mkTcTyVar name (typeKind ty) (FlatSkol ty)
 583                            }
 584
 585 -- Instantiations
 586 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 587
 588 instDFunTypes :: [Either TyVar TcType] -> TcS [TcType]
 589 instDFunTypes mb_inst_tys =
 590   let inst_tv :: Either TyVar TcType -> TcS Type
 591       inst_tv (Left tv)  = wrapTcS $ TcM.tcInstTyVar tv >>= return . mkTyVarTy
 592       inst_tv (Right ty) = return ty
 593   in mapM inst_tv mb_inst_tys
 594
 595
 596 instDFunConstraints :: TcThetaType -> TcS [EvVar]
 597 instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds
 598
 599
 600 -- Superclasses and recursive dictionaries
 601 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 602
 603 newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar
 604 newGivOrDerEvVar pty evtrm
 605   = do { ev <- wrapTcS $ TcM.newEvVar pty
 606        ; setEvBind ev evtrm
 607        ; return ev }
 608
 609 newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar
 610 -- Note we create immutable variables for given or derived, since we
 611 -- must bind them to TcEvBinds (because their evidence may involve
 612 -- superclasses). However we should be able to override existing
 613 -- 'derived' evidence, even in TcEvBinds
 614 newGivOrDerCoVar ty1 ty2 co
 615   = do { cv <- newCoVar ty1 ty2
 616        ; setEvBind cv (EvCoercion co)
 617        ; return cv }
 618
 619 newWantedCoVar :: TcType -> TcType -> TcS EvVar
 620 newWantedCoVar ty1 ty2 =  wrapTcS $ TcM.newWantedCoVar ty1 ty2
 621
 622 newKindConstraint :: TcType -> Kind -> TcS (CoVar, TcType)
 623 newKindConstraint ty kind =  wrapTcS $ TcM.newKindConstraint ty kind
 624
 625 newCoVar :: TcType -> TcType -> TcS EvVar
 626 newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2
 627
 628 newIPVar :: IPName Name -> TcType -> TcS EvVar
 629 newIPVar nm ty = wrapTcS $ TcM.newIP nm ty
 630
 631 newDictVar :: Class -> [TcType] -> TcS EvVar
 632 newDictVar cl tys = wrapTcS $ TcM.newDict cl tys
 633 \end{code}
 634
 635
 636 \begin{code}
 637 isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool
 638 -- In a call (isGoodRecEv ev wv), we are considering solving wv
 639 -- using some term that involves ev, such as:
 640 -- by setting           wv = ev
 641 -- or                   wv = EvCast x |> ev
 642 -- etc.
 643 -- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
 644 -- in an "unguarded" way. So isGoodRecEv looks at the evidence ev
 645 -- recursively through the evidence binds, to see if uses of 'wv' are guarded.
 646 --
 647 -- Guarded means: more instance calls than superclass selections. We
 648 -- compute this by chasing the evidence, adding +1 for every instance
 649 -- call (constructor) and -1 for every superclass selection (destructor).
 650 --
 651 -- See Note [Superclasses and recursive dictionaries] in TcInteract
 652 isGoodRecEv ev_var (WantedEvVar wv _)
 653   = do { tc_evbinds <- getTcEvBindsBag
 654        ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var
 655        ; return $ case mb of
 656                     Nothing -> True
 657                     Just min_guardedness -> min_guardedness > 0
 658        }
 659
 660   where chase_ev_var :: EvBindMap   -- Evidence binds
 661                  -> EvVar           -- Target variable whose gravity we want to return
 662                  -> Int             -- Current gravity
 663                  -> [EvVar]         -- Visited nodes
 664                  -> EvVar           -- Current node
 665                  -> TcS (Maybe Int)
 666         chase_ev_var assocs trg curr_grav visited orig
 667             | trg == orig         = return $ Just curr_grav
 668             | orig `elem` visited = return $ Nothing
 669             | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
 670             = chase_ev assocs trg curr_grav (orig:visited) ev_trm
 671
 672 {-  No longer needed: evidence is in the EvBinds
 673             | isTcTyVar orig && isMetaTyVar orig
 674             = do { meta_details <- wrapTcS $ TcM.readWantedCoVar orig
 675                  ; case meta_details of
 676                      Flexi -> return Nothing
 677                      Indirect tyco -> chase_ev assocs trg curr_grav
 678                                              (orig:visited) (EvCoercion tyco)
 679                            }
 680 -}
 681             | otherwise = return Nothing
 682
 683         chase_ev assocs trg curr_grav visited (EvId v)
 684             = chase_ev_var assocs trg curr_grav visited v
 685         chase_ev assocs trg curr_grav visited (EvSuperClass d_id _)
 686             = chase_ev_var assocs trg (curr_grav-1) visited d_id
 687         chase_ev assocs trg curr_grav visited (EvCast v co)
 688             = do { m1 <- chase_ev_var assocs trg curr_grav visited v
 689                  ; m2 <- chase_co assocs trg curr_grav visited co
 690                  ; return (comb_chase_res Nothing [m1,m2]) }
 691
 692         chase_ev assocs trg curr_grav visited (EvCoercion co)
 693             = chase_co assocs trg curr_grav visited co
 694         chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars)
 695             = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
 696                  ; return (comb_chase_res Nothing chase_results) }
 697
 698         chase_co assocs trg curr_grav visited co
 699             = -- Look for all the coercion variables in the coercion
 700               -- chase them, and combine the results. This is OK since the
 701               -- coercion will not contain any superclass terms -- anything
 702               -- that involves dictionaries will be bound in assocs.
 703               let co_vars       = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
 704                                              (tyVarsOfType co)
 705               in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
 706                     ; return (comb_chase_res Nothing chase_results) }
 707
 708         comb_chase_res f []                   = f
 709         comb_chase_res f (Nothing:rest)       = comb_chase_res f rest
 710         comb_chase_res Nothing (Just n:rest)  = comb_chase_res (Just n) rest
 711         comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest
 712
 713
 714 -- Matching and looking up classes and family instances
 715 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 716
 717 data MatchInstResult mi
 718   = MatchInstNo         -- No matching instance
 719   | MatchInstSingle mi  -- Single matching instance
 720   | MatchInstMany       -- Multiple matching instances
 721
 722
 723 matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType]))
 724 -- Look up a class constraint in the instance environment
 725 matchClass clas tys
 726   = do  { let pred = mkClassPred clas tys
 727         ; instEnvs <- getInstEnvs
 728         ; case lookupInstEnv instEnvs clas tys of {
 729             ([], unifs)               -- Nothing matches
 730                 -> do { traceTcS "matchClass not matching"
 731                                  (vcat [ text "dict" <+> ppr pred,
 732                                          text "unifs" <+> ppr unifs ])
 733                       ; return MatchInstNo
 734                       } ;
 735             ([(ispec, inst_tys)], []) -- A single match
 736                 -> do   { let dfun_id = is_dfun ispec
 737                         ; traceTcS "matchClass success"
 738                                    (vcat [text "dict" <+> ppr pred,
 739                                           text "witness" <+> ppr dfun_id
 740                                            <+> ppr (idType dfun_id) ])
 741                                   -- Record that this dfun is needed
 742                         ; record_dfun_usage dfun_id
 743                         ; return $ MatchInstSingle (dfun_id, inst_tys)
 744                         } ;
 745             (matches, unifs)          -- More than one matches
 746                 -> do   { traceTcS "matchClass multiple matches, deferring choice"
 747                                    (vcat [text "dict" <+> ppr pred,
 748                                           text "matches" <+> ppr matches,
 749                                           text "unifs" <+> ppr unifs])
 750                         ; return MatchInstMany
 751                         }
 752         }
 753         }
 754   where record_dfun_usage :: Id -> TcS ()
 755         record_dfun_usage dfun_id
 756           = do { hsc_env <- getTopEnv
 757                ; let  dfun_name = idName dfun_id
 758                       dfun_mod  = ASSERT( isExternalName dfun_name )
 759                                   nameModule dfun_name
 760                ; if isInternalName dfun_name ||    -- Internal name => defined in this module
 761                     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 762                  then return () -- internal, or in another package
 763                  else do updInstUses dfun_id
 764                }
 765
 766         updInstUses :: Id -> TcS ()
 767         updInstUses dfun_id
 768             = do { tcg_env <- getGblEnv
 769                  ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env)
 770                                             (`addOneToNameSet` idName dfun_id)
 771                  }
 772
 773 matchFam :: TyCon
 774          -> [Type]
 775          -> TcS (MatchInstResult (TyCon, [Type]))
 776 matchFam tycon args
 777   = do { mb <- wrapTcS $ TcM.tcLookupFamInst tycon args
 778        ; case mb of
 779            Nothing  -> return MatchInstNo
 780            Just res -> return $ MatchInstSingle res
 781        -- DV: We never return MatchInstMany, since tcLookupFamInst never returns
 782        -- multiple matches. Check.
 783        }
 784
 785
 786 -- Functional dependencies, instantiation of equations
 787 -------------------------------------------------------
 788
 789 mkWantedFunDepEqns :: WantedLoc -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
 790                    -> TcS [WantedEvVar]
 791 mkWantedFunDepEqns _   [] = return []
 792 mkWantedFunDepEqns loc eqns
 793   = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
 794        ; wevvars <- mapM to_work_item eqns
 795        ; return $ concat wevvars }
 796   where
 797     to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
 798     to_work_item ((qtvs, pairs), _, _)
 799       = do { (_, _, tenv) <- wrapTcS $ TcM.tcInstTyVars (varSetElems qtvs)
 800            ; mapM (do_one tenv) pairs }
 801
 802     do_one tenv (ty1, ty2) = do { let sty1 = substTy tenv ty1
 803                                       sty2 = substTy tenv ty2
 804                                 ; ev <- newWantedCoVar sty1 sty2
 805                                 ; return (WantedEvVar ev loc) }
 806
 807 pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
 808 pprEquationDoc (eqn, (p1, _), (p2, _))
 809   = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
 810 \end{code}