compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The @Inst@ type: dictionaries or method instances
   7
   8 \begin{code}
   9 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module Inst (
  17         Inst,
  18
  19         pprInstances, pprDictsTheta, pprDictsInFull,    -- User error messages
  20         showLIE, pprInst, pprInsts, pprInstInFull,      -- Debugging messages
  21
  22         tidyInsts, tidyMoreInsts,
  23
  24         newDictBndr, newDictBndrs, newDictBndrsO,
  25         instCall, instStupidTheta,
  26         cloneDict,
  27         shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
  28         newMethod, newMethodFromName, newMethodWithGivenTy,
  29         tcInstClassOp,
  30         tcSyntaxName, isHsVar,
  31
  32         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  33         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  34         getDictClassTys, dictPred,
  35
  36         lookupSimpleInst, LookupInstResult(..),
  37         tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
  38
  39         isAbstractableInst, isEqInst,
  40         isDict, isClassDict, isMethod, isImplicInst,
  41         isIPDict, isInheritableInst, isMethodOrLit,
  42         isTyVarDict, isMethodFor,
  43
  44         zonkInst, zonkInsts,
  45         instToId, instToVar, instType, instName, instToDictBind,
  46         addInstToDictBind,
  47
  48         InstOrigin(..), InstLoc, pprInstLoc,
  49
  50         mkWantedCo, mkGivenCo,
  51         fromWantedCo, fromGivenCo,
  52         eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
  53         finalizeEqInst, writeWantedCoercion,
  54         eqInstType, updateEqInstCoercion,
  55         eqInstCoercion,
  56         eqInstLeftTy, eqInstRightTy
  57     ) where
  58
  59 #include "HsVersions.h"
  60
  61 import {-# SOURCE #-}   TcExpr( tcPolyExpr )
  62 import {-# SOURCE #-}   TcUnify( boxyUnify, unifyType )
  63
  64 import FastString(FastString)
  65 import HsSyn
  66 import TcHsSyn
  67 import TcRnMonad
  68 import TcEnv
  69 import InstEnv
  70 import FunDeps
  71 import TcMType
  72 import TcType
  73 import Type
  74 import TypeRep
  75 import Class
  76 import Unify
  77 import Module
  78 import Coercion
  79 import HscTypes
  80 import CoreFVs
  81 import DataCon
  82 import Id
  83 import Name
  84 import NameSet
  85 import Literal
  86 import Var      ( Var, TyVar )
  87 import qualified Var
  88 import VarEnv
  89 import VarSet
  90 import TysWiredIn
  91 import PrelNames
  92 import BasicTypes
  93 import SrcLoc
  94 import DynFlags
  95 import Bag
  96 import Maybes
  97 import Util
  98 import Outputable
  99 import Data.List
 100 import TypeRep
 101 import Class
 102
 103 import Control.Monad ( liftM )
 104 \end{code}
 105
 106
 107 Selection
 108 ~~~~~~~~~
 109 \begin{code}
 110 instName :: Inst -> Name
 111 instName (EqInst {tci_name = name}) = name
 112 instName inst = Var.varName (instToVar inst)
 113
 114 instToId :: Inst -> TcId
 115 instToId inst = WARN( not (isId id), ppr inst )
 116               id
 117               where
 118                 id = instToVar inst
 119
 120 instToVar :: Inst -> Var
 121 instToVar (LitInst {tci_name = nm, tci_ty = ty})
 122   = mkLocalId nm ty
 123 instToVar (Method {tci_id = id})
 124   = id
 125 instToVar (Dict {tci_name = nm, tci_pred = pred})
 126   | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
 127   | otherwise     = mkLocalId nm (mkPredTy pred)
 128 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
 129                        tci_wanted = wanteds})
 130   = mkLocalId nm (mkImplicTy tvs givens wanteds)
 131 instToVar i@(EqInst {})
 132   = eitherEqInst i id (\(TyVarTy covar) -> covar)
 133
 134 instType :: Inst -> Type
 135 instType (LitInst {tci_ty = ty})  = ty
 136 instType (Method {tci_id = id})   = idType id
 137 instType (Dict {tci_pred = pred}) = mkPredTy pred
 138 instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
 139                                                (tci_wanted imp)
 140 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
 141 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
 142
 143 mkImplicTy tvs givens wanteds   -- The type of an implication constraint
 144   = ASSERT( all isDict givens )
 145     -- pprTrace "mkImplicTy" (ppr givens) $
 146     -- See [Equational Constraints in Implication Constraints]
 147     let dict_wanteds = filter (not . isEqInst) wanteds
 148     in
 149       mkForAllTys tvs $
 150       mkPhiTy (map dictPred givens) $
 151       if isSingleton dict_wanteds then
 152         instType (head dict_wanteds)
 153       else
 154         mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
 155
 156 dictPred (Dict {tci_pred = pred}) = pred
 157 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
 158 dictPred inst                     = pprPanic "dictPred" (ppr inst)
 159
 160 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
 161 getDictClassTys inst                     = pprPanic "getDictClassTys" (ppr inst)
 162
 163 -- fdPredsOfInst is used to get predicates that contain functional
 164 -- dependencies *or* might do so.  The "might do" part is because
 165 -- a constraint (C a b) might have a superclass with FDs
 166 -- Leaving these in is really important for the call to fdPredsOfInsts
 167 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 168 -- which is supposed to be conservative
 169 fdPredsOfInst (Dict {tci_pred = pred})       = [pred]
 170 fdPredsOfInst (Method {tci_theta = theta})   = theta
 171 fdPredsOfInst (ImplicInst {tci_given = gs,
 172                            tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
 173 fdPredsOfInst (LitInst {})                   = []
 174 fdPredsOfInst (EqInst {})                    = []
 175
 176 fdPredsOfInsts :: [Inst] -> [PredType]
 177 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 178
 179 isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
 180 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
 181 isInheritableInst other                        = True
 182
 183
 184 ---------------------------------
 185 -- Get the implicit parameters mentioned by these Insts
 186 -- NB: the results of these functions are insensitive to zonking
 187
 188 ipNamesOfInsts :: [Inst] -> [Name]
 189 ipNamesOfInst  :: Inst   -> [Name]
 190 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 191
 192 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
 193 ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
 194 ipNamesOfInst other                          = []
 195
 196 ---------------------------------
 197 tyVarsOfInst :: Inst -> TcTyVarSet
 198 tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
 199 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
 200 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
 201                                  -- The id might have free type variables; in the case of
 202                                  -- locally-overloaded class methods, for example
 203 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
 204   = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
 205     `minusVarSet` mkVarSet tvs
 206     `unionVarSet` unionVarSets (map varTypeTyVars tvs)
 207                 -- Remember the free tyvars of a coercion
 208 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
 209
 210 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 211 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 212
 213
 214 --------------------------
 215 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
 216 instToDictBind inst rhs
 217   = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
 218
 219 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
 220 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
 221 \end{code}
 222
 223 Predicates
 224 ~~~~~~~~~~
 225 \begin{code}
 226
 227 isAbstractableInst :: Inst -> Bool
 228 isAbstractableInst inst = isDict inst || isEqInst inst
 229
 230 isEqInst :: Inst -> Bool
 231 isEqInst (EqInst {}) = True
 232 isEqInst other       = False
 233
 234 isDict :: Inst -> Bool
 235 isDict (Dict {}) = True
 236 isDict other     = False
 237
 238 isClassDict :: Inst -> Bool
 239 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
 240 isClassDict other                    = False
 241
 242 isTyVarDict :: Inst -> Bool
 243 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
 244 isTyVarDict other                    = False
 245
 246 isIPDict :: Inst -> Bool
 247 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
 248 isIPDict other                    = False
 249
 250 isImplicInst (ImplicInst {}) = True
 251 isImplicInst other           = False
 252
 253 isMethod :: Inst -> Bool
 254 isMethod (Method {}) = True
 255 isMethod other       = False
 256
 257 isMethodFor :: TcIdSet -> Inst -> Bool
 258 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
 259 isMethodFor ids inst                    = False
 260
 261 isMethodOrLit :: Inst -> Bool
 262 isMethodOrLit (Method {})  = True
 263 isMethodOrLit (LitInst {}) = True
 264 isMethodOrLit other        = False
 265 \end{code}
 266
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection{Building dictionaries}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 -- newDictBndrs makes a dictionary at a binding site
 275 -- instCall makes a dictionary at an occurrence site
 276 --      and throws it into the LIE
 277
 278 \begin{code}
 279 ----------------
 280 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
 281 newDictBndrsO orig theta = do { loc <- getInstLoc orig
 282                               ; newDictBndrs loc theta }
 283
 284 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
 285 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
 286
 287 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 288 newDictBndr inst_loc pred@(EqPred ty1 ty2)
 289   = do { uniq <- newUnique
 290         ; let name = mkPredName uniq inst_loc pred
 291         ; return (EqInst {tci_name  = name,
 292                           tci_loc   = inst_loc,
 293                           tci_left  = ty1,
 294                           tci_right = ty2,
 295                           tci_co    = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
 296        }
 297 newDictBndr inst_loc pred
 298   = do  { uniq <- newUnique
 299         ; let name = mkPredName uniq inst_loc pred
 300         ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
 301
 302 ----------------
 303 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 304 -- Instantiate the constraints of a call
 305 --      (instCall o tys theta)
 306 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 307 -- (b) Throws these dictionaries into the LIE
 308 -- (c) Returns an HsWrapper ([.] tys dicts)
 309
 310 instCall orig tys theta
 311   = do  { loc <- getInstLoc orig
 312         ; dict_app <- instCallDicts loc theta
 313         ; return (dict_app <.> mkWpTyApps tys) }
 314
 315 ----------------
 316 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
 317 -- Similar to instCall, but only emit the constraints in the LIE
 318 -- Used exclusively for the 'stupid theta' of a data constructor
 319 instStupidTheta orig theta
 320   = do  { loc <- getInstLoc orig
 321         ; _co <- instCallDicts loc theta        -- Discard the coercion
 322         ; return () }
 323
 324 ----------------
 325 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
 326 -- Instantiates the TcTheta, puts all constraints thereby generated
 327 -- into the LIE, and returns a HsWrapper to enclose the call site.
 328 -- This is the key place where equality predicates
 329 -- are unleashed into the world
 330 instCallDicts loc [] = return idHsWrapper
 331
 332 -- instCallDicts loc (EqPred ty1 ty2 : preds)
 333 --   = do  { unifyType ty1 ty2  -- For now, we insist that they unify right away
 334 --                              -- Later on, when we do associated types,
 335 --                              -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
 336 --      ; (dicts, co_fn) <- instCallDicts loc preds
 337 --      ; return (dicts, co_fn <.> WpTyApp ty1) }
 338 --      -- We use type application to apply the function to the
 339 --      -- coercion; here ty1 *is* the appropriate identity coercion
 340
 341 instCallDicts loc (EqPred ty1 ty2 : preds)
 342   = do  { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
 343         ; coi <- boxyUnify ty1 ty2
 344 --      ; coi <- unifyType ty1 ty2
 345         ; let co = fromCoI coi ty1
 346         ; co_fn <- instCallDicts loc preds
 347         ; return (co_fn <.> WpTyApp co) }
 348
 349 instCallDicts loc (pred : preds)
 350   = do  { uniq <- newUnique
 351         ; let name = mkPredName uniq loc pred
 352               dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
 353         ; extendLIE dict
 354         ; co_fn <- instCallDicts loc preds
 355         ; return (co_fn <.> WpApp (instToId dict)) }
 356
 357 -------------
 358 cloneDict :: Inst -> TcM Inst
 359 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
 360                                      ; return (dict {tci_name = setNameUnique nm uniq}) }
 361 cloneDict eq@(EqInst {})        = return eq
 362 cloneDict other = pprPanic "cloneDict" (ppr other)
 363
 364 -- For vanilla implicit parameters, there is only one in scope
 365 -- at any time, so we used to use the name of the implicit parameter itself
 366 -- But with splittable implicit parameters there may be many in
 367 -- scope, so we make up a new namea.
 368 newIPDict :: InstOrigin -> IPName Name -> Type
 369           -> TcM (IPName Id, Inst)
 370 newIPDict orig ip_name ty
 371   = getInstLoc orig                     `thenM` \ inst_loc ->
 372     newUnique                           `thenM` \ uniq ->
 373     let
 374         pred = IParam ip_name ty
 375         name = mkPredName uniq inst_loc pred
 376         dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
 377     in
 378     returnM (mapIPName (\n -> instToId dict) ip_name, dict)
 379 \end{code}
 380
 381
 382 \begin{code}
 383 mkPredName :: Unique -> InstLoc -> PredType -> Name
 384 mkPredName uniq loc pred_ty
 385   = mkInternalName uniq occ (instLocSpan loc)
 386   where
 387     occ = case pred_ty of
 388             ClassP cls _ -> mkDictOcc (getOccName cls)
 389             IParam ip  _ -> getOccName (ipNameName ip)
 390             EqPred ty  _ -> mkEqPredCoOcc baseOcc
 391               where
 392                 -- we use the outermost tycon of the lhs, if there is one, to
 393                 -- improve readability of Core code
 394                 baseOcc = case splitTyConApp_maybe ty of
 395                             Nothing      -> mkOccName tcName "$"
 396                             Just (tc, _) -> getOccName tc
 397 \end{code}
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection{Building methods (calls of overloaded functions)}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405
 406 \begin{code}
 407 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
 408 newMethodFromName origin ty name
 409   = tcLookupId name             `thenM` \ id ->
 410         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 411         -- always a class op, but with -fno-implicit-prelude GHC is
 412         -- meant to find whatever thing is in scope, and that may
 413         -- be an ordinary function.
 414     getInstLoc origin           `thenM` \ loc ->
 415     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 416     extendLIE inst              `thenM_`
 417     returnM (instToId inst)
 418
 419 newMethodWithGivenTy orig id tys
 420   = getInstLoc orig             `thenM` \ loc ->
 421     newMethod loc id tys        `thenM` \ inst ->
 422     extendLIE inst              `thenM_`
 423     returnM (instToId inst)
 424
 425 --------------------------------------------
 426 -- tcInstClassOp, and newMethod do *not* drop the
 427 -- Inst into the LIE; they just returns the Inst
 428 -- This is important because they are used by TcSimplify
 429 -- to simplify Insts
 430
 431 -- NB: the kind of the type variable to be instantiated
 432 --     might be a sub-kind of the type to which it is applied,
 433 --     notably when the latter is a type variable of kind ??
 434 --     Hence the call to checkKind
 435 -- A worry: is this needed anywhere else?
 436 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 437 tcInstClassOp inst_loc sel_id tys
 438   = let
 439         (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
 440     in
 441     zipWithM_ checkKind tyvars tys      `thenM_`
 442     newMethod inst_loc sel_id tys
 443
 444 checkKind :: TyVar -> TcType -> TcM ()
 445 -- Ensure that the type has a sub-kind of the tyvar
 446 checkKind tv ty
 447   = do  { let ty1 = ty
 448                 -- ty1 <- zonkTcType ty
 449         ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
 450           then return ()
 451           else
 452
 453     pprPanic "checkKind: adding kind constraint"
 454              (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
 455                     ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
 456         }
 457 --    do        { tv1 <- tcInstTyVar tv
 458 --      ; unifyType ty1 (mkTyVarTy tv1) } }
 459
 460
 461 ---------------------------
 462 newMethod inst_loc id tys
 463   = newUnique           `thenM` \ new_uniq ->
 464     let
 465         (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
 466         meth_id     = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 467         inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
 468                               tci_theta = theta, tci_loc = inst_loc}
 469         loc         = instLocSpan inst_loc
 470     in
 471     returnM inst
 472 \end{code}
 473
 474 \begin{code}
 475 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
 476 shortCutIntLit i ty
 477   | isIntTy ty && inIntRange i          -- Short cut for Int
 478   = Just (HsLit (HsInt i))
 479   | isIntegerTy ty                      -- Short cut for Integer
 480   = Just (HsLit (HsInteger i ty))
 481   | otherwise = Nothing
 482
 483 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
 484 shortCutFracLit f ty
 485   | isFloatTy ty
 486   = Just (mk_lit floatDataCon (HsFloatPrim f))
 487   | isDoubleTy ty
 488   = Just (mk_lit doubleDataCon (HsDoublePrim f))
 489   | otherwise = Nothing
 490   where
 491     mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 492
 493 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
 494 shortCutStringLit s ty
 495   | isStringTy ty                       -- Short cut for String
 496   = Just (HsLit (HsString s))
 497   | otherwise = Nothing
 498
 499 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 500 mkIntegerLit i
 501   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 502     getSrcSpanM                 `thenM` \ span ->
 503     returnM (L span $ HsLit (HsInteger i integer_ty))
 504
 505 mkRatLit :: Rational -> TcM (LHsExpr TcId)
 506 mkRatLit r
 507   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 508     getSrcSpanM                 `thenM` \ span ->
 509     returnM (L span $ HsLit (HsRat r rat_ty))
 510
 511 mkStrLit :: FastString -> TcM (LHsExpr TcId)
 512 mkStrLit s
 513   = --tcMetaTy stringTyConName  `thenM` \ string_ty ->
 514     getSrcSpanM                 `thenM` \ span ->
 515     returnM (L span $ HsLit (HsString s))
 516
 517 isHsVar :: HsExpr Name -> Name -> Bool
 518 isHsVar (HsVar f) g = f==g
 519 isHsVar other     g = False
 520 \end{code}
 521
 522
 523 %************************************************************************
 524 %*                                                                      *
 525 \subsection{Zonking}
 526 %*                                                                      *
 527 %************************************************************************
 528
 529 Zonking makes sure that the instance types are fully zonked.
 530
 531 \begin{code}
 532 zonkInst :: Inst -> TcM Inst
 533 zonkInst dict@(Dict { tci_pred = pred})
 534   = zonkTcPredType pred                 `thenM` \ new_pred ->
 535     returnM (dict {tci_pred = new_pred})
 536
 537 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
 538   = zonkId id                   `thenM` \ new_id ->
 539         -- Essential to zonk the id in case it's a local variable
 540         -- Can't use zonkIdOcc because the id might itself be
 541         -- an InstId, in which case it won't be in scope
 542
 543     zonkTcTypes tys             `thenM` \ new_tys ->
 544     zonkTcThetaType theta       `thenM` \ new_theta ->
 545     returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
 546         -- No need to zonk the tci_id
 547
 548 zonkInst lit@(LitInst {tci_ty = ty})
 549   = zonkTcType ty                       `thenM` \ new_ty ->
 550     returnM (lit {tci_ty = new_ty})
 551
 552 zonkInst implic@(ImplicInst {})
 553   = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
 554     do  { givens'  <- zonkInsts (tci_given  implic)
 555         ; wanteds' <- zonkInsts (tci_wanted implic)
 556         ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
 557
 558 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
 559   = do { co' <- eitherEqInst eqinst
 560                   (\covar -> return (mkWantedCo covar))
 561                   (\co    -> liftM mkGivenCo $ zonkTcType co)
 562        ; ty1' <- zonkTcType ty1
 563        ; ty2' <- zonkTcType ty2
 564        ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
 565        }
 566
 567 zonkInsts insts = mappM zonkInst insts
 568 \end{code}
 569
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection{Printing}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 578 relevant in error messages.
 579
 580 \begin{code}
 581 instance Outputable Inst where
 582     ppr inst = pprInst inst
 583
 584 pprDictsTheta :: [Inst] -> SDoc
 585 -- Print in type-like fashion (Eq a, Show b)
 586 -- The Inst can be an implication constraint, but not a Method or LitInst
 587 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
 588
 589 pprDictsInFull :: [Inst] -> SDoc
 590 -- Print in type-like fashion, but with source location
 591 pprDictsInFull dicts
 592   = vcat (map go dicts)
 593   where
 594     go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
 595
 596 pprInsts :: [Inst] -> SDoc
 597 -- Debugging: print the evidence :: type
 598 pprInsts insts = brackets (interpp'SP insts)
 599
 600 pprInst, pprInstInFull :: Inst -> SDoc
 601 -- Debugging: print the evidence :: type
 602 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
 603         = eitherEqInst i
 604                 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
 605                 (\co    -> text "Given"  <+> ppr co              <+> dcolon <+> ppr (EqPred ty1 ty2))
 606 pprInst inst = ppr (instName inst) <+> dcolon
 607                 <+> (braces (ppr (instType inst)) $$
 608                      ifPprDebug implic_stuff)
 609   where
 610     implic_stuff | isImplicInst inst = ppr (tci_reft inst)
 611                  | otherwise         = empty
 612
 613 pprInstInFull inst@(EqInst {}) = pprInst inst
 614 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
 615
 616 tidyInst :: TidyEnv -> Inst -> Inst
 617 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
 618   eq { tci_left  = tidyType env lty
 619      , tci_right = tidyType env rty
 620      , tci_co    = either Left (Right . tidyType env) co
 621      }
 622 tidyInst env lit@(LitInst {tci_ty = ty})   = lit {tci_ty = tidyType env ty}
 623 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
 624 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
 625 tidyInst env implic@(ImplicInst {})
 626   = implic { tci_tyvars = tvs'
 627            , tci_given  = map (tidyInst env') (tci_given  implic)
 628            , tci_wanted = map (tidyInst env') (tci_wanted implic) }
 629   where
 630     (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
 631
 632 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 633 -- This function doesn't assume that the tyvars are in scope
 634 -- so it works like tidyOpenType, returning a TidyEnv
 635 tidyMoreInsts env insts
 636   = (env', map (tidyInst env') insts)
 637   where
 638     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 639
 640 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 641 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 642
 643 showLIE :: SDoc -> TcM ()       -- Debugging
 644 showLIE str
 645   = do { lie_var <- getLIEVar ;
 646          lie <- readMutVar lie_var ;
 647          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 648 \end{code}
 649
 650
 651 %************************************************************************
 652 %*                                                                      *
 653         Extending the instance environment
 654 %*                                                                      *
 655 %************************************************************************
 656
 657 \begin{code}
 658 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
 659   -- Add new locally-defined instances
 660 tcExtendLocalInstEnv dfuns thing_inside
 661  = do { traceDFuns dfuns
 662       ; env <- getGblEnv
 663       ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
 664       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 665                          tcg_inst_env = inst_env' }
 666       ; setGblEnv env' thing_inside }
 667
 668 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
 669 -- Check that the proposed new instance is OK,
 670 -- and then add it to the home inst env
 671 addLocalInst home_ie ispec
 672   = do  {       -- Instantiate the dfun type so that we extend the instance
 673                 -- envt with completely fresh template variables
 674                 -- This is important because the template variables must
 675                 -- not overlap with anything in the things being looked up
 676                 -- (since we do unification).
 677                 -- We use tcInstSkolType because we don't want to allocate fresh
 678                 --  *meta* type variables.
 679           let dfun = instanceDFunId ispec
 680         ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
 681         ; let   (cls, tys') = tcSplitDFunHead tau'
 682                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 683                 ispec'      = setInstanceDFunId ispec dfun'
 684
 685                 -- Load imported instances, so that we report
 686                 -- duplicates correctly
 687         ; eps <- getEps
 688         ; let inst_envs = (eps_inst_env eps, home_ie)
 689
 690                 -- Check functional dependencies
 691         ; case checkFunDeps inst_envs ispec' of
 692                 Just specs -> funDepErr ispec' specs
 693                 Nothing    -> return ()
 694
 695                 -- Check for duplicate instance decls
 696         ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
 697               ; dup_ispecs = [ dup_ispec
 698                              | (dup_ispec, _) <- matches
 699                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
 700                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 701                 -- Find memebers of the match list which ispec itself matches.
 702                 -- If the match is 2-way, it's a duplicate
 703         ; case dup_ispecs of
 704             dup_ispec : _ -> dupInstErr ispec' dup_ispec
 705             []            -> return ()
 706
 707                 -- OK, now extend the envt
 708         ; return (extendInstEnv home_ie ispec') }
 709
 710 getOverlapFlag :: TcM OverlapFlag
 711 getOverlapFlag
 712   = do  { dflags <- getDOpts
 713         ; let overlap_ok    = dopt Opt_OverlappingInstances dflags
 714               incoherent_ok = dopt Opt_IncoherentInstances  dflags
 715               overlap_flag | incoherent_ok = Incoherent
 716                            | overlap_ok    = OverlapOk
 717                            | otherwise     = NoOverlap
 718
 719         ; return overlap_flag }
 720
 721 traceDFuns ispecs
 722   = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
 723   where
 724     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 725         -- Print the dfun name itself too
 726
 727 funDepErr ispec ispecs
 728   = addDictLoc ispec $
 729     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 730                2 (pprInstances (ispec:ispecs)))
 731 dupInstErr ispec dup_ispec
 732   = addDictLoc ispec $
 733     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 734                2 (pprInstances [ispec, dup_ispec]))
 735
 736 addDictLoc ispec thing_inside
 737   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 738   where
 739    loc = getSrcLoc ispec
 740 \end{code}
 741
 742
 743 %************************************************************************
 744 %*                                                                      *
 745 \subsection{Looking up Insts}
 746 %*                                                                      *
 747 %************************************************************************
 748
 749 \begin{code}
 750 data LookupInstResult
 751   = NoInstance
 752   | GenInst [Inst] (LHsExpr TcId)       -- The expression and its needed insts
 753
 754 lookupSimpleInst :: Inst -> TcM LookupInstResult
 755 -- This is "simple" in that it returns NoInstance for implication constraints
 756
 757 -- It's important that lookupInst does not put any new stuff into
 758 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 759 -- the LookupInstResult, where they can be further processed by tcSimplify
 760
 761 lookupSimpleInst (EqInst {}) = return NoInstance
 762
 763 --------------------- Implications ------------------------
 764 lookupSimpleInst (ImplicInst {}) = return NoInstance
 765
 766 --------------------- Methods ------------------------
 767 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
 768   = do  { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
 769         ; let co_fn = dict_app <.> mkWpTyApps tys
 770         ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
 771   where
 772     span = instLocSpan loc
 773
 774 --------------------- Literals ------------------------
 775 -- Look for short cuts first: if the literal is *definitely* a
 776 -- int, integer, float or a double, generate the real thing here.
 777 -- This is essential (see nofib/spectral/nucleic).
 778 -- [Same shortcut as in newOverloadedLit, but we
 779 --  may have done some unification by now]
 780
 781 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
 782   | Just expr <- shortCutIntLit i ty
 783   = returnM (GenInst [] (noLoc expr))
 784   | otherwise
 785   = ASSERT( from_integer_name `isHsVar` fromIntegerName )       -- A LitInst invariant
 786     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 787     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 788     mkIntegerLit i                              `thenM` \ integer_lit ->
 789     returnM (GenInst [method_inst]
 790                      (mkHsApp (L (instLocSpan loc)
 791                                  (HsVar (instToId method_inst))) integer_lit))
 792
 793 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
 794   | Just expr <- shortCutFracLit f ty
 795   = returnM (GenInst [] (noLoc expr))
 796
 797   | otherwise
 798   = ASSERT( from_rat_name `isHsVar` fromRationalName )  -- A LitInst invariant
 799     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 800     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 801     mkRatLit f                                  `thenM` \ rat_lit ->
 802     returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
 803                                                (HsVar (instToId method_inst))) rat_lit))
 804
 805 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
 806   | Just expr <- shortCutStringLit s ty
 807   = returnM (GenInst [] (noLoc expr))
 808   | otherwise
 809   = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
 810     tcLookupId fromStringName                   `thenM` \ from_string ->
 811     tcInstClassOp loc from_string [ty]          `thenM` \ method_inst ->
 812     mkStrLit s                                  `thenM` \ string_lit ->
 813     returnM (GenInst [method_inst]
 814                      (mkHsApp (L (instLocSpan loc)
 815                                  (HsVar (instToId method_inst))) string_lit))
 816
 817 --------------------- Dictionaries ------------------------
 818 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
 819   = do  { mb_result <- lookupPred pred
 820         ; case mb_result of {
 821             Nothing -> return NoInstance ;
 822             Just (dfun_id, mb_inst_tys) -> do
 823
 824     { use_stage <- getStage
 825     ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 826                       (topIdLvl dfun_id) use_stage
 827
 828         -- It's possible that not all the tyvars are in
 829         -- the substitution, tenv. For example:
 830         --      instance C X a => D X where ...
 831         -- (presumably there's a functional dependency in class C)
 832         -- Hence mb_inst_tys :: Either TyVar TcType
 833
 834     ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
 835           inst_tv (Right ty) = return ty
 836     ; tys <- mappM inst_tv mb_inst_tys
 837     ; let
 838         (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
 839         src_loc    = instLocSpan loc
 840         dfun       = HsVar dfun_id
 841     ; if null theta then
 842         returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
 843       else do
 844     { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
 845     ; let co_fn = dict_app <.> mkWpTyApps tys
 846     ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
 847     }}}}
 848
 849 ---------------
 850 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
 851 -- Look up a class constraint in the instance environment
 852 lookupPred pred@(ClassP clas tys)
 853   = do  { eps     <- getEps
 854         ; tcg_env <- getGblEnv
 855         ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
 856         ; case lookupInstEnv inst_envs clas tys of {
 857             ([(ispec, inst_tys)], [])
 858                 -> do   { let dfun_id = is_dfun ispec
 859                         ; traceTc (text "lookupInst success" <+>
 860                                    vcat [text "dict" <+> ppr pred,
 861                                          text "witness" <+> ppr dfun_id
 862                                          <+> ppr (idType dfun_id) ])
 863                                 -- Record that this dfun is needed
 864                         ; record_dfun_usage dfun_id
 865                         ; return (Just (dfun_id, inst_tys)) } ;
 866
 867             (matches, unifs)
 868                 -> do   { traceTc (text "lookupInst fail" <+>
 869                                    vcat [text "dict" <+> ppr pred,
 870                                          text "matches" <+> ppr matches,
 871                                          text "unifs" <+> ppr unifs])
 872                 -- In the case of overlap (multiple matches) we report
 873                 -- NoInstance here.  That has the effect of making the
 874                 -- context-simplifier return the dict as an irreducible one.
 875                 -- Then it'll be given to addNoInstanceErrs, which will do another
 876                 -- lookupInstEnv to get the detailed info about what went wrong.
 877                         ; return Nothing }
 878         }}
 879
 880 lookupPred ip_pred = return Nothing     -- Implicit parameters
 881
 882 record_dfun_usage dfun_id
 883   = do  { hsc_env <- getTopEnv
 884         ; let  dfun_name = idName dfun_id
 885                dfun_mod  = nameModule dfun_name
 886         ; if isInternalName dfun_name ||    -- Internal name => defined in this module
 887              modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 888           then return () -- internal, or in another package
 889            else do { tcg_env <- getGblEnv
 890                    ; updMutVar (tcg_inst_uses tcg_env)
 891                                (`addOneToNameSet` idName dfun_id) }}
 892
 893
 894 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 895 -- Gets both the external-package inst-env
 896 -- and the home-pkg inst env (includes module being compiled)
 897 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 898                      return (eps_inst_env eps, tcg_inst_env env) }
 899 \end{code}
 900
 901
 902
 903 %************************************************************************
 904 %*                                                                      *
 905                 Re-mappable syntax
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 910 a do-expression.  We have to find (>>) in the current environment, which is
 911 done by the rename. Then we have to check that it has the same type as
 912 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 913 this:
 914
 915   (>>) :: HB m n mn => m a -> n b -> mn b
 916
 917 So the idea is to generate a local binding for (>>), thus:
 918
 919         let then72 :: forall a b. m a -> m b -> m b
 920             then72 = ...something involving the user's (>>)...
 921         in
 922         ...the do-expression...
 923
 924 Now the do-expression can proceed using then72, which has exactly
 925 the expected type.
 926
 927 In fact tcSyntaxName just generates the RHS for then72, because we only
 928 want an actual binding in the do-expression case. For literals, we can
 929 just use the expression inline.
 930
 931 \begin{code}
 932 tcSyntaxName :: InstOrigin
 933              -> TcType                  -- Type to instantiate it at
 934              -> (Name, HsExpr Name)     -- (Standard name, user name)
 935              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 936 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 937 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 938 -- So we do not call it from lookupInst, which is called from tcSimplify
 939
 940 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 941   | std_nm == user_nm
 942   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 943     returnM (std_nm, HsVar id)
 944
 945 tcSyntaxName orig ty (std_nm, user_nm_expr)
 946   = tcLookupId std_nm           `thenM` \ std_id ->
 947     let
 948         -- C.f. newMethodAtLoc
 949         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 950         sigma1          = substTyWith [tv] [ty] tau
 951         -- Actually, the "tau-type" might be a sigma-type in the
 952         -- case of locally-polymorphic methods.
 953     in
 954     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)       $
 955
 956         -- Check that the user-supplied thing has the
 957         -- same type as the standard one.
 958         -- Tiresome jiggling because tcCheckSigma takes a located expression
 959     getSrcSpanM                                 `thenM` \ span ->
 960     tcPolyExpr (L span user_nm_expr) sigma1     `thenM` \ expr ->
 961     returnM (std_nm, unLoc expr)
 962
 963 syntaxNameCtxt name orig ty tidy_env
 964   = getInstLoc orig             `thenM` \ inst_loc ->
 965     let
 966         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 967                                 ptext SLIT("(needed by a syntactic construct)"),
 968                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 969                     nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
 970     in
 971     returnM (tidy_env, msg)
 972 \end{code}
 973
 974 %************************************************************************
 975 %*                                                                      *
 976                 EqInsts
 977 %*                                                                      *
 978 %************************************************************************
 979
 980 \begin{code}
 981 mkGivenCo   :: Coercion -> Either TcTyVar Coercion
 982 mkGivenCo   =  Right
 983
 984 mkWantedCo  :: TcTyVar  -> Either TcTyVar Coercion
 985 mkWantedCo  =  Left
 986
 987 fromGivenCo :: Either TcTyVar Coercion -> Coercion
 988 fromGivenCo (Right co)   = co
 989 fromGivenCo _            = panic "fromGivenCo: not a wanted coercion"
 990
 991 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
 992 fromWantedCo _ (Left covar) = covar
 993 fromWantedCo msg _          = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
 994
 995 eitherEqInst :: Inst                -- given or wanted EqInst
 996              -> (TcTyVar  -> a)     --  result if wanted
 997              -> (Coercion -> a)     --  result if given
 998              -> a
 999 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1000         = case either_co of
1001                 Left  covar -> withWanted covar
1002                 Right co    -> withGiven  co
1003
1004 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
1005 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1006
1007 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
1008 mkEqInst (EqPred ty1 ty2) co
1009         = do { uniq <- newUnique
1010              ; src_span <- getSrcSpanM
1011              ; err_ctxt <- getErrCtxt
1012              ; let loc  = InstLoc EqOrigin src_span err_ctxt
1013                    name = mkName uniq src_span
1014                    inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
1015              ; return inst
1016              }
1017         where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1018
1019 mkWantedEqInst :: PredType -> TcM Inst
1020 mkWantedEqInst pred@(EqPred ty1 ty2)
1021   = do { cotv <- newMetaCoVar ty1 ty2
1022        ; mkEqInst pred (Left cotv)
1023        }
1024
1025 -- type inference:
1026 --      We want to promote the wanted EqInst to a given EqInst
1027 --      in the signature context.
1028 --      This means we have to give the coercion a name
1029 --      and fill it in as its own name.
1030 finalizeEqInst
1031         :: Inst                 -- wanted
1032         -> TcM Inst             -- given
1033 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1034         = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1035              ; writeWantedCoercion wanted (TyVarTy var)
1036              ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1037              ; return given
1038              }
1039
1040 writeWantedCoercion
1041         :: Inst         -- wanted EqInst
1042         -> Coercion     -- coercion to fill the hole with
1043         -> TcM ()
1044 writeWantedCoercion wanted co
1045         = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1046              ; writeMetaTyVar cotv co
1047              }
1048
1049 eqInstType :: Inst -> TcType
1050 eqInstType inst = eitherEqInst inst mkTyVarTy id
1051
1052 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1053 eqInstCoercion = tci_co
1054
1055 eqInstLeftTy, eqInstRightTy :: Inst -> TcType
1056 eqInstLeftTy  = tci_left
1057 eqInstRightTy = tci_right
1058
1059 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1060 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
1061 \end{code}