compiler/typecheck/Inst.lhs

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