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