compiler/typecheck/Inst.lhs

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