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