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