2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The @Inst@ type: dictionaries or method instances
12 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
13 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
15 tidyInsts, tidyMoreInsts,
17 newDictBndr, newDictBndrs, newDictBndrsO,
18 newDictOccs, newDictOcc,
19 instCall, instStupidTheta,
21 newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
23 tcSyntaxName, isHsVar,
25 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
26 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
27 getDictClassTys, dictPred,
29 lookupSimpleInst, LookupInstResult(..),
30 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
32 isAbstractableInst, isEqInst,
33 isDict, isClassDict, isMethod, isImplicInst,
34 isIPDict, isInheritableInst, isMethodOrLit,
35 isTyVarDict, isMethodFor,
38 instToId, instToVar, instType, instName, instToDictBind,
41 InstOrigin(..), InstLoc, pprInstLoc,
43 mkWantedCo, mkGivenCo,
44 isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType,
45 mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo,
46 mkRightTransEqInstCo, mkAppEqInstCo,
48 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
49 wantedToLocalEqInst, finalizeEqInst,
50 eqInstType, updateEqInstCoercion,
51 eqInstCoercion, eqInstTys
54 #include "HsVersions.h"
56 import {-# SOURCE #-} TcExpr( tcPolyExpr )
57 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
80 import Var ( Var, TyVar )
103 instName :: Inst -> Name
104 instName (EqInst {tci_name = name}) = name
105 instName inst = Var.varName (instToVar inst)
107 instToId :: Inst -> TcId
108 instToId inst = WARN( not (isId id), ppr inst )
113 instToVar :: Inst -> Var
114 instToVar (LitInst {tci_name = nm, tci_ty = ty})
116 instToVar (Method {tci_id = id})
118 instToVar (Dict {tci_name = nm, tci_pred = pred})
119 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
120 | otherwise = mkLocalId nm (mkPredTy pred)
121 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
122 tci_wanted = wanteds})
123 = mkLocalId nm (mkImplicTy tvs givens wanteds)
124 instToVar i@(EqInst {})
125 = eitherEqInst i id (\(TyVarTy covar) -> covar)
127 instType :: Inst -> Type
128 instType (LitInst {tci_ty = ty}) = ty
129 instType (Method {tci_id = id}) = idType id
130 instType (Dict {tci_pred = pred}) = mkPredTy pred
131 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
133 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
134 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
136 mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
137 mkImplicTy tvs givens wanteds -- The type of an implication constraint
138 = ASSERT( all isAbstractableInst givens )
139 -- pprTrace "mkImplicTy" (ppr givens) $
140 -- See [Equational Constraints in Implication Constraints]
141 let dict_wanteds = filter (not . isEqInst) wanteds
144 mkPhiTy (map dictPred givens) $
145 mkBigCoreTupTy (map instType dict_wanteds)
147 dictPred :: Inst -> TcPredType
148 dictPred (Dict {tci_pred = pred}) = pred
149 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
150 dictPred inst = pprPanic "dictPred" (ppr inst)
152 getDictClassTys :: Inst -> (Class, [Type])
153 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
154 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
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_given = gs,
166 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
167 fdPredsOfInst (LitInst {}) = []
168 fdPredsOfInst (EqInst {}) = []
170 fdPredsOfInsts :: [Inst] -> [PredType]
171 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
173 isInheritableInst :: Inst -> Bool
174 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
175 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
176 isInheritableInst _ = True
179 ---------------------------------
180 -- Get the implicit parameters mentioned by these Insts
181 -- NB: the results of these functions are insensitive to zonking
183 ipNamesOfInsts :: [Inst] -> [Name]
184 ipNamesOfInst :: Inst -> [Name]
185 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
187 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
188 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
191 ---------------------------------
192 tyVarsOfInst :: Inst -> TcTyVarSet
193 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
194 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
195 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
196 -- The id might have free type variables; in the case of
197 -- locally-overloaded class methods, for example
198 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
199 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
200 `minusVarSet` mkVarSet tvs
201 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
202 -- Remember the free tyvars of a coercion
203 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
205 tyVarsOfInsts :: [Inst] -> VarSet
206 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
207 tyVarsOfLIE :: Bag Inst -> VarSet
208 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
211 --------------------------
212 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
213 instToDictBind inst rhs
214 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
216 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
217 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
224 isAbstractableInst :: Inst -> Bool
225 isAbstractableInst inst = isDict inst || isEqInst inst
227 isEqInst :: Inst -> Bool
228 isEqInst (EqInst {}) = True
231 isDict :: Inst -> Bool
232 isDict (Dict {}) = True
235 isClassDict :: Inst -> Bool
236 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
237 isClassDict _ = False
239 isTyVarDict :: Inst -> Bool
240 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
241 isTyVarDict _ = False
243 isIPDict :: Inst -> Bool
244 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
247 isImplicInst :: Inst -> Bool
248 isImplicInst (ImplicInst {}) = True
249 isImplicInst _ = False
251 isMethod :: Inst -> Bool
252 isMethod (Method {}) = True
255 isMethodFor :: TcIdSet -> Inst -> Bool
256 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
257 isMethodFor _ _ = False
259 isMethodOrLit :: Inst -> Bool
260 isMethodOrLit (Method {}) = True
261 isMethodOrLit (LitInst {}) = True
262 isMethodOrLit _ = False
266 %************************************************************************
268 \subsection{Building dictionaries}
270 %************************************************************************
272 -- newDictBndrs makes a dictionary at a binding site
273 -- instCall makes a dictionary at an occurrence site
274 -- and throws it into the LIE
278 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
279 newDictBndrsO orig theta = do { loc <- getInstLoc orig
280 ; newDictBndrs loc theta }
282 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
283 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
285 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
287 newDictBndr inst_loc pred@(EqPred ty1 ty2)
288 = do { uniq <- newUnique
289 ; let name = mkPredName uniq inst_loc pred
290 co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
291 ; return (EqInst {tci_name = name,
297 newDictBndr inst_loc pred = newDict inst_loc pred
300 newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
301 newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
303 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
305 newDictOcc inst_loc pred@(EqPred ty1 ty2)
306 = do { uniq <- newUnique
307 ; cotv <- newMetaCoVar ty1 ty2
308 ; let name = mkPredName uniq inst_loc pred
309 ; return (EqInst {tci_name = name,
313 tci_co = Left cotv }) }
315 newDictOcc inst_loc pred = newDict inst_loc pred
318 newDict :: InstLoc -> TcPredType -> TcM Inst
319 -- Always makes a Dict, not an EqInst
320 newDict inst_loc pred
321 = do { uniq <- newUnique
322 ; let name = mkPredName uniq inst_loc pred
323 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
326 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
327 -- Instantiate the constraints of a call
328 -- (instCall o tys theta)
329 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
330 -- (b) Throws these dictionaries into the LIE
331 -- (c) Returns an HsWrapper ([.] tys dicts)
333 instCall orig tys theta
334 = do { loc <- getInstLoc orig
335 ; dict_app <- instCallDicts loc theta
336 ; return (dict_app <.> mkWpTyApps tys) }
339 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
340 -- Similar to instCall, but only emit the constraints in the LIE
341 -- Used exclusively for the 'stupid theta' of a data constructor
342 instStupidTheta orig theta
343 = do { loc <- getInstLoc orig
344 ; _co <- instCallDicts loc theta -- Discard the coercion
348 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
349 -- Instantiates the TcTheta, puts all constraints thereby generated
350 -- into the LIE, and returns a HsWrapper to enclose the call site.
351 -- This is the key place where equality predicates
352 -- are unleashed into the world
353 instCallDicts _ [] = return idHsWrapper
355 -- instCallDicts loc (EqPred ty1 ty2 : preds)
356 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
357 -- -- Later on, when we do associated types,
358 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
359 -- ; (dicts, co_fn) <- instCallDicts loc preds
360 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
361 -- -- We use type application to apply the function to the
362 -- -- coercion; here ty1 *is* the appropriate identity coercion
364 instCallDicts loc (EqPred ty1 ty2 : preds)
365 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
366 ; coi <- boxyUnify ty1 ty2
367 ; let co = fromCoI coi ty1
368 ; co_fn <- instCallDicts loc preds
369 ; return (co_fn <.> WpTyApp co) }
371 instCallDicts loc (pred : preds)
372 = do { dict <- newDict loc pred
374 ; co_fn <- instCallDicts loc preds
375 ; return (co_fn <.> WpApp (instToId dict)) }
378 cloneDict :: Inst -> TcM Inst
379 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
380 ; return (dict {tci_name = setNameUnique nm uniq}) }
381 cloneDict eq@(EqInst {}) = return eq
382 cloneDict other = pprPanic "cloneDict" (ppr other)
384 -- For vanilla implicit parameters, there is only one in scope
385 -- at any time, so we used to use the name of the implicit parameter itself
386 -- But with splittable implicit parameters there may be many in
387 -- scope, so we make up a new namea.
388 newIPDict :: InstOrigin -> IPName Name -> Type
389 -> TcM (IPName Id, Inst)
390 newIPDict orig ip_name ty
391 = do { inst_loc <- getInstLoc orig
392 ; dict <- newDict inst_loc (IParam ip_name ty)
393 ; return (mapIPName (\_ -> instToId dict) ip_name, dict) }
398 mkPredName :: Unique -> InstLoc -> PredType -> Name
399 mkPredName uniq loc pred_ty
400 = mkInternalName uniq occ (instLocSpan loc)
402 occ = case pred_ty of
403 ClassP cls _ -> mkDictOcc (getOccName cls)
404 IParam ip _ -> getOccName (ipNameName ip)
405 EqPred ty _ -> mkEqPredCoOcc baseOcc
407 -- we use the outermost tycon of the lhs, if there is one, to
408 -- improve readability of Core code
409 baseOcc = case splitTyConApp_maybe ty of
410 Nothing -> mkTcOcc "$"
411 Just (tc, _) -> getOccName tc
414 %************************************************************************
416 \subsection{Building methods (calls of overloaded functions)}
418 %************************************************************************
422 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
423 newMethodFromName origin ty name = do
424 id <- tcLookupId name
425 -- Use tcLookupId not tcLookupGlobalId; the method is almost
426 -- always a class op, but with -XNoImplicitPrelude GHC is
427 -- meant to find whatever thing is in scope, and that may
428 -- be an ordinary function.
429 loc <- getInstLoc origin
430 inst <- tcInstClassOp loc id [ty]
432 return (instToId inst)
434 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
435 newMethodWithGivenTy orig id tys = do
436 loc <- getInstLoc orig
437 inst <- newMethod loc id tys
439 return (instToId inst)
441 --------------------------------------------
442 -- tcInstClassOp, and newMethod do *not* drop the
443 -- Inst into the LIE; they just returns the Inst
444 -- This is important because they are used by TcSimplify
447 -- NB: the kind of the type variable to be instantiated
448 -- might be a sub-kind of the type to which it is applied,
449 -- notably when the latter is a type variable of kind ??
450 -- Hence the call to checkKind
451 -- A worry: is this needed anywhere else?
452 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
453 tcInstClassOp inst_loc sel_id tys = do
455 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
456 zipWithM_ checkKind tyvars tys
457 newMethod inst_loc sel_id tys
459 checkKind :: TyVar -> TcType -> TcM ()
460 -- Ensure that the type has a sub-kind of the tyvar
463 -- ty1 <- zonkTcType ty
464 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
468 pprPanic "checkKind: adding kind constraint"
469 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
470 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
472 -- do { tv1 <- tcInstTyVar tv
473 -- ; unifyType ty1 (mkTyVarTy tv1) } }
476 ---------------------------
477 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
478 newMethod inst_loc id tys = do
479 new_uniq <- newUnique
481 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
482 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
483 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
484 tci_theta = theta, tci_loc = inst_loc}
485 loc = instLocSpan inst_loc
491 mkOverLit :: OverLitVal -> TcM HsLit
492 mkOverLit (HsIntegral i)
493 = do { integer_ty <- tcMetaTy integerTyConName
494 ; return (HsInteger i integer_ty) }
496 mkOverLit (HsFractional r)
497 = do { rat_ty <- tcMetaTy rationalTyConName
498 ; return (HsRat r rat_ty) }
500 mkOverLit (HsIsString s) = return (HsString s)
502 isHsVar :: HsExpr Name -> Name -> Bool
503 isHsVar (HsVar f) g = f == g
508 %************************************************************************
512 %************************************************************************
514 Zonking makes sure that the instance types are fully zonked.
517 zonkInst :: Inst -> TcM Inst
518 zonkInst dict@(Dict {tci_pred = pred}) = do
519 new_pred <- zonkTcPredType pred
520 return (dict {tci_pred = new_pred})
522 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
524 -- Essential to zonk the id in case it's a local variable
525 -- Can't use zonkIdOcc because the id might itself be
526 -- an InstId, in which case it won't be in scope
528 new_tys <- zonkTcTypes tys
529 new_theta <- zonkTcThetaType theta
530 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
531 -- No need to zonk the tci_id
533 zonkInst lit@(LitInst {tci_ty = ty}) = do
534 new_ty <- zonkTcType ty
535 return (lit {tci_ty = new_ty})
537 zonkInst implic@(ImplicInst {})
538 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
539 do { givens' <- zonkInsts (tci_given implic)
540 ; wanteds' <- zonkInsts (tci_wanted implic)
541 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
543 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
544 = do { co' <- eitherEqInst eqinst
545 (\covar -> return (mkWantedCo covar))
546 (\co -> liftM mkGivenCo $ zonkTcType co)
547 ; ty1' <- zonkTcType ty1
548 ; ty2' <- zonkTcType ty2
549 ; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' })
552 zonkInsts :: [Inst] -> TcRn [Inst]
553 zonkInsts insts = mapM zonkInst insts
557 %************************************************************************
559 \subsection{Printing}
561 %************************************************************************
563 ToDo: improve these pretty-printing things. The ``origin'' is really only
564 relevant in error messages.
567 instance Outputable Inst where
568 ppr inst = pprInst inst
570 pprDictsTheta :: [Inst] -> SDoc
571 -- Print in type-like fashion (Eq a, Show b)
572 -- The Inst can be an implication constraint, but not a Method or LitInst
573 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
575 pprDictsInFull :: [Inst] -> SDoc
576 -- Print in type-like fashion, but with source location
578 = vcat (map go dicts)
580 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
582 pprInsts :: [Inst] -> SDoc
583 -- Debugging: print the evidence :: type
584 pprInsts insts = brackets (interpp'SP insts)
586 pprInst, pprInstInFull :: Inst -> SDoc
587 -- Debugging: print the evidence :: type
588 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
590 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
591 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
592 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
593 <+> braces (ppr (instType inst) <> implicWantedEqs)
597 | isImplicInst inst = text " &" <+>
598 ppr (filter isEqInst (tci_wanted inst))
601 pprInstInFull inst@(EqInst {}) = pprInst inst
602 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
604 tidyInst :: TidyEnv -> Inst -> Inst
605 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
606 eq { tci_left = tidyType env lty
607 , tci_right = tidyType env rty
608 , tci_co = either Left (Right . tidyType env) co
610 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
611 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
612 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
613 tidyInst env implic@(ImplicInst {})
614 = implic { tci_tyvars = tvs'
615 , tci_given = map (tidyInst env') (tci_given implic)
616 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
618 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
620 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
621 -- This function doesn't assume that the tyvars are in scope
622 -- so it works like tidyOpenType, returning a TidyEnv
623 tidyMoreInsts env insts
624 = (env', map (tidyInst env') insts)
626 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
628 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
629 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
631 showLIE :: SDoc -> TcM () -- Debugging
633 = do { lie_var <- getLIEVar ;
634 lie <- readMutVar lie_var ;
635 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
639 %************************************************************************
641 Extending the instance environment
643 %************************************************************************
646 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
647 -- Add new locally-defined instances
648 tcExtendLocalInstEnv dfuns thing_inside
649 = do { traceDFuns dfuns
651 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
652 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
653 tcg_inst_env = inst_env' }
654 ; setGblEnv env' thing_inside }
656 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
657 -- Check that the proposed new instance is OK,
658 -- and then add it to the home inst env
659 addLocalInst home_ie ispec
660 = do { -- Instantiate the dfun type so that we extend the instance
661 -- envt with completely fresh template variables
662 -- This is important because the template variables must
663 -- not overlap with anything in the things being looked up
664 -- (since we do unification).
665 -- We use tcInstSkolType because we don't want to allocate fresh
666 -- *meta* type variables.
667 let dfun = instanceDFunId ispec
668 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
669 ; let (cls, tys') = tcSplitDFunHead tau'
670 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
671 ispec' = setInstanceDFunId ispec dfun'
673 -- Load imported instances, so that we report
674 -- duplicates correctly
676 ; let inst_envs = (eps_inst_env eps, home_ie)
678 -- Check functional dependencies
679 ; case checkFunDeps inst_envs ispec' of
680 Just specs -> funDepErr ispec' specs
683 -- Check for duplicate instance decls
684 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
685 ; dup_ispecs = [ dup_ispec
686 | (dup_ispec, _) <- matches
687 , let (_,_,_,dup_tys) = instanceHead dup_ispec
688 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
689 -- Find memebers of the match list which ispec itself matches.
690 -- If the match is 2-way, it's a duplicate
692 dup_ispec : _ -> dupInstErr ispec' dup_ispec
695 -- OK, now extend the envt
696 ; return (extendInstEnv home_ie ispec') }
698 getOverlapFlag :: TcM OverlapFlag
700 = do { dflags <- getDOpts
701 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
702 incoherent_ok = dopt Opt_IncoherentInstances dflags
703 overlap_flag | incoherent_ok = Incoherent
704 | overlap_ok = OverlapOk
705 | otherwise = NoOverlap
707 ; return overlap_flag }
709 traceDFuns :: [Instance] -> TcRn ()
711 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
713 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
714 -- Print the dfun name itself too
716 funDepErr :: Instance -> [Instance] -> TcRn ()
717 funDepErr ispec ispecs
719 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
720 2 (pprInstances (ispec:ispecs)))
721 dupInstErr :: Instance -> Instance -> TcRn ()
722 dupInstErr ispec dup_ispec
724 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
725 2 (pprInstances [ispec, dup_ispec]))
727 addDictLoc :: Instance -> TcRn a -> TcRn a
728 addDictLoc ispec thing_inside
729 = setSrcSpan (mkSrcSpan loc loc) thing_inside
731 loc = getSrcLoc ispec
735 %************************************************************************
737 \subsection{Looking up Insts}
739 %************************************************************************
742 data LookupInstResult
744 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
746 lookupSimpleInst :: Inst -> TcM LookupInstResult
747 -- This is "simple" in that it returns NoInstance for implication constraints
749 -- It's important that lookupInst does not put any new stuff into
750 -- the LIE. Instead, any Insts needed by the lookup are returned in
751 -- the LookupInstResult, where they can be further processed by tcSimplify
753 lookupSimpleInst (EqInst {}) = return NoInstance
755 --------------------- Implications ------------------------
756 lookupSimpleInst (ImplicInst {}) = return NoInstance
758 --------------------- Methods ------------------------
759 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
760 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
761 ; let co_fn = dict_app <.> mkWpTyApps tys
762 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
764 span = instLocSpan loc
766 --------------------- Literals ------------------------
767 -- Look for short cuts first: if the literal is *definitely* a
768 -- int, integer, float or a double, generate the real thing here.
769 -- This is essential (see nofib/spectral/nucleic).
770 -- [Same shortcut as in newOverloadedLit, but we
771 -- may have done some unification by now]
773 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
774 , ol_rebindable = rebindable }
775 , tci_ty = ty, tci_loc = iloc})
776 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
777 | Just witness <- shortCutLit lit_val ty
778 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
779 ; return (GenInst [] (L loc (HsOverLit lit'))) }
782 = do { hs_lit <- mkOverLit lit_val
783 ; from_thing <- tcLookupId (hsOverLitName lit_val)
784 -- Not rebindable, so hsOverLitName is the right thing
785 ; method_inst <- tcInstClassOp iloc from_thing [ty]
786 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
787 (L loc (HsLit hs_lit))
788 lit' = lit { ol_witness = witness, ol_type = ty }
789 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
791 loc = instLocSpan iloc
793 --------------------- Dictionaries ------------------------
794 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
795 = do { mb_result <- lookupPred pred
796 ; case mb_result of {
797 Nothing -> return NoInstance ;
798 Just (dfun_id, mb_inst_tys) -> do
800 { use_stage <- getStage
801 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
802 (topIdLvl dfun_id) use_stage
804 -- It's possible that not all the tyvars are in
805 -- the substitution, tenv. For example:
806 -- instance C X a => D X where ...
807 -- (presumably there's a functional dependency in class C)
808 -- Hence mb_inst_tys :: Either TyVar TcType
810 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
811 inst_tv (Right ty) = return ty
812 ; tys <- mapM inst_tv mb_inst_tys
814 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
815 src_loc = instLocSpan loc
818 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
820 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
821 ; let co_fn = dict_app <.> mkWpTyApps tys
822 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
826 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
827 -- Look up a class constraint in the instance environment
828 lookupPred pred@(ClassP clas tys)
830 ; tcg_env <- getGblEnv
831 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
832 ; case lookupInstEnv inst_envs clas tys of {
833 ([(ispec, inst_tys)], [])
834 -> do { let dfun_id = is_dfun ispec
835 ; traceTc (text "lookupInst success" <+>
836 vcat [text "dict" <+> ppr pred,
837 text "witness" <+> ppr dfun_id
838 <+> ppr (idType dfun_id) ])
839 -- Record that this dfun is needed
840 ; record_dfun_usage dfun_id
841 ; return (Just (dfun_id, inst_tys)) } ;
844 -> do { traceTc (text "lookupInst fail" <+>
845 vcat [text "dict" <+> ppr pred,
846 text "matches" <+> ppr matches,
847 text "unifs" <+> ppr unifs])
848 -- In the case of overlap (multiple matches) we report
849 -- NoInstance here. That has the effect of making the
850 -- context-simplifier return the dict as an irreducible one.
851 -- Then it'll be given to addNoInstanceErrs, which will do another
852 -- lookupInstEnv to get the detailed info about what went wrong.
856 lookupPred (IParam {}) = return Nothing -- Implicit parameters
857 lookupPred (EqPred {}) = panic "lookupPred EqPred"
859 record_dfun_usage :: Id -> TcRn ()
860 record_dfun_usage dfun_id
861 = do { hsc_env <- getTopEnv
862 ; let dfun_name = idName dfun_id
863 dfun_mod = 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) }}
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) }
881 %************************************************************************
885 %************************************************************************
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
893 (>>) :: HB m n mn => m a -> n b -> mn b
895 So the idea is to generate a local binding for (>>), thus:
897 let then72 :: forall a b. m a -> m b -> m b
898 then72 = ...something involving the user's (>>)...
900 ...the do-expression...
902 Now the do-expression can proceed using then72, which has exactly
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.
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
918 tcSyntaxName orig ty (std_nm, HsVar user_nm)
920 = do id <- newMethodFromName orig ty std_nm
921 return (std_nm, HsVar id)
923 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
924 std_id <- tcLookupId std_nm
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.
932 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
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
938 expr <- tcPolyExpr (L span user_nm_expr) sigma1
939 return (std_nm, unLoc expr)
941 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
942 -> TcRn (TidyEnv, SDoc)
943 syntaxNameCtxt name orig ty tidy_env = do
944 inst_loc <- getInstLoc orig
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)]
951 return (tidy_env, msg)
954 %************************************************************************
958 %************************************************************************
960 Operations on EqInstCo.
963 mkGivenCo :: Coercion -> EqInstCo
966 mkWantedCo :: TcTyVar -> EqInstCo
969 isWantedCo :: EqInstCo -> Bool
970 isWantedCo (Left _) = True
973 fromGivenCo :: EqInstCo -> Coercion
974 fromGivenCo (Right co) = co
975 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
977 fromWantedCo :: String -> EqInstCo -> TcTyVar
978 fromWantedCo _ (Left covar) = covar
980 panic ("fromWantedCo: not a wanted coercion: " ++ msg)
982 eqInstCoType :: EqInstCo -> TcType
983 eqInstCoType (Left cotv) = mkTyVarTy cotv
984 eqInstCoType (Right co) = co
987 Coercion transformations on EqInstCo. These transformations work differently
988 depending on whether a EqInstCo is for a wanted or local equality:
990 Local : apply the inverse of the specified coercion
991 Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
992 to be the specified coercion applied to the new coercion hole
995 -- Coercion transformation: co = id
997 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
998 mkIdEqInstCo (Left cotv) t
999 = writeMetaTyVar cotv t
1000 mkIdEqInstCo (Right _) _
1003 -- Coercion transformation: co = sym co'
1005 mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
1006 mkSymEqInstCo (Left cotv) (ty1, ty2)
1007 = do { cotv' <- newMetaCoVar ty1 ty2
1008 ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
1009 ; return $ Left cotv'
1011 mkSymEqInstCo (Right co) _
1012 = return $ Right (mkSymCoercion co)
1014 -- Coercion transformation: co = co' |> given_co
1016 mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1017 mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
1018 = do { cotv' <- newMetaCoVar ty1 ty2
1019 ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
1020 ; return $ Left cotv'
1022 mkLeftTransEqInstCo (Right co) given_co _
1023 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1025 -- Coercion transformation: co = given_co |> co'
1027 mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1028 mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
1029 = do { cotv' <- newMetaCoVar ty1 ty2
1030 ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
1031 ; return $ Left cotv'
1033 mkRightTransEqInstCo (Right co) given_co _
1034 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1036 -- Coercion transformation: co = col cor
1038 mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
1039 -> TcM (EqInstCo, EqInstCo)
1040 mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
1041 = do { cotv_l <- newMetaCoVar ty1_l ty2_l
1042 ; cotv_r <- newMetaCoVar ty1_r ty2_r
1043 ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
1044 ; return (Left cotv_l, Left cotv_r)
1046 mkAppEqInstCo (Right co) _ _
1047 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1050 Operations on entire EqInst.
1053 -- For debugging, make sure the cotv of a wanted is not filled.
1055 isValidWantedEqInst :: Inst -> TcM Bool
1056 isValidWantedEqInst (EqInst {tci_co = Left cotv})
1057 = liftM not $ isFilledMetaTyVar cotv
1058 isValidWantedEqInst _ = return True
1060 eitherEqInst :: Inst -- given or wanted EqInst
1061 -> (TcTyVar -> a) -- result if wanted
1062 -> (Coercion -> a) -- result if given
1064 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1066 Left covar -> withWanted covar
1067 Right co -> withGiven co
1068 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
1070 mkEqInsts :: [PredType] -> [EqInstCo] -> TcM [Inst]
1071 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1073 mkEqInst :: PredType -> EqInstCo -> TcM Inst
1074 mkEqInst (EqPred ty1 ty2) co
1075 = do { uniq <- newUnique
1076 ; src_span <- getSrcSpanM
1077 ; err_ctxt <- getErrCtxt
1078 ; let loc = InstLoc EqOrigin src_span err_ctxt
1079 name = mkName uniq src_span
1080 inst = EqInst { tci_left = ty1
1089 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1090 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1092 mkWantedEqInst :: PredType -> TcM Inst
1093 mkWantedEqInst pred@(EqPred ty1 ty2)
1094 = do { cotv <- newMetaCoVar ty1 ty2
1095 ; mkEqInst pred (Left cotv)
1097 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
1099 -- Turn a wanted equality into a local that propagates the uninstantiated
1100 -- coercion variable as witness. We need this to propagate wanted irreds into
1101 -- attempts to solve implication constraints.
1103 wantedToLocalEqInst :: Inst -> Inst
1104 wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
1105 = eq {tci_co = Right (mkTyVarTy cotv)}
1106 wantedToLocalEqInst eq = eq
1108 -- Turn a wanted into a local EqInst (needed during type inference for
1111 -- * Give it a name and change the coercion around.
1113 finalizeEqInst :: Inst -- wanted
1114 -> TcM Inst -- given
1115 finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, tci_name = name})
1116 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1118 -- fill the coercion hole
1119 ; let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1120 ; writeMetaTyVar cotv (TyVarTy var)
1122 -- set the new coercion
1123 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1127 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1129 eqInstType :: Inst -> TcType
1130 eqInstType inst = eitherEqInst inst mkTyVarTy id
1132 eqInstCoercion :: Inst -> EqInstCo
1133 eqInstCoercion = tci_co
1135 eqInstTys :: Inst -> (TcType, TcType)
1136 eqInstTys inst = (tci_left inst, tci_right inst)
1138 updateEqInstCoercion :: (EqInstCo -> EqInstCo) -> Inst -> Inst
1139 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}