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