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, isWantedCo, eqInstCoType, mkIdEqInstCo,
44 mkSymEqInstCo, mkLeftTransEqInstCo, mkRightTransEqInstCo, mkAppEqInstCo,
45 wantedEqInstIsUnsolved, eitherEqInst, mkEqInst, mkWantedEqInst,
46 wantedToLocalEqInst, finalizeEqInst, eqInstType, eqInstCoercion,
50 #include "HsVersions.h"
52 import {-# SOURCE #-} TcExpr( tcPolyExpr )
53 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
76 import Var ( Var, TyVar )
99 instName :: Inst -> Name
100 instName (EqInst {tci_name = name}) = name
101 instName inst = Var.varName (instToVar inst)
103 instToId :: Inst -> TcId
104 instToId inst = WARN( not (isId id), ppr inst )
109 instToVar :: Inst -> Var
110 instToVar (LitInst {tci_name = nm, tci_ty = ty})
112 instToVar (Method {tci_id = 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
123 assertCoVar (TyVarTy cotv) = cotv
124 assertCoVar coty = pprPanic "Inst.instToVar" (ppr coty)
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)
132 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
133 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
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
143 mkPhiTy (map dictPred givens) $
144 mkBigCoreTupTy (map instType dict_wanteds)
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)
151 getDictClassTys :: Inst -> (Class, [Type])
152 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
153 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
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 {}) = []
169 fdPredsOfInsts :: [Inst] -> [PredType]
170 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
172 isInheritableInst :: Inst -> Bool
173 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
174 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
175 isInheritableInst _ = True
178 ---------------------------------
179 -- Get the implicit parameters mentioned by these Insts
180 -- NB: the results of these functions are insensitive to zonking
182 ipNamesOfInsts :: [Inst] -> [Name]
183 ipNamesOfInst :: Inst -> [Name]
184 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
186 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
187 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
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
204 tyVarsOfInsts :: [Inst] -> VarSet
205 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
206 tyVarsOfLIE :: Bag Inst -> VarSet
207 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
210 --------------------------
211 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
212 instToDictBind inst rhs
213 = unitBag (L (instSpan inst) (VarBind { var_id = instToId inst
215 , var_inline = False }))
217 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
218 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
225 isAbstractableInst :: Inst -> Bool
226 isAbstractableInst inst = isDict inst || isEqInst inst
228 isEqInst :: Inst -> Bool
229 isEqInst (EqInst {}) = True
232 isDict :: Inst -> Bool
233 isDict (Dict {}) = True
236 isClassDict :: Inst -> Bool
237 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
238 isClassDict _ = False
240 isTyVarDict :: Inst -> Bool
241 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
242 isTyVarDict _ = False
244 isIPDict :: Inst -> Bool
245 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
248 isImplicInst :: Inst -> Bool
249 isImplicInst (ImplicInst {}) = True
250 isImplicInst _ = False
252 isMethod :: Inst -> Bool
253 isMethod (Method {}) = True
256 isMethodFor :: TcIdSet -> Inst -> Bool
257 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
258 isMethodFor _ _ = False
260 isMethodOrLit :: Inst -> Bool
261 isMethodOrLit (Method {}) = True
262 isMethodOrLit (LitInst {}) = True
263 isMethodOrLit _ = False
267 %************************************************************************
269 \subsection{Building dictionaries}
271 %************************************************************************
273 -- newDictBndrs makes a dictionary at a binding site
274 -- instCall makes a dictionary at an occurrence site
275 -- and throws it into the LIE
279 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
280 newDictBndrsO orig theta = do { loc <- getInstLoc orig
281 ; newDictBndrs loc theta }
283 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
284 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
286 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
288 newDictBndr inst_loc pred@(EqPred ty1 ty2)
289 = do { uniq <- newUnique
290 ; let name = mkPredName uniq inst_loc pred
291 co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
292 ; return (EqInst {tci_name = name,
298 newDictBndr inst_loc pred = newDict inst_loc pred
301 newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
302 newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
304 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
306 newDictOcc inst_loc pred@(EqPred ty1 ty2)
307 = do { uniq <- newUnique
308 ; cotv <- newMetaCoVar ty1 ty2
309 ; let name = mkPredName uniq inst_loc pred
310 ; return (EqInst {tci_name = name,
314 tci_co = Left cotv }) }
316 newDictOcc inst_loc pred = newDict inst_loc pred
319 newDict :: InstLoc -> TcPredType -> TcM Inst
320 -- Always makes a Dict, not an EqInst
321 newDict inst_loc pred
322 = do { uniq <- newUnique
323 ; let name = mkPredName uniq inst_loc pred
324 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
327 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
328 -- Instantiate the constraints of a call
329 -- (instCall o tys theta)
330 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
331 -- (b) Throws these dictionaries into the LIE
332 -- (c) Returns an HsWrapper ([.] tys dicts)
334 instCall orig tys theta
335 = do { loc <- getInstLoc orig
336 ; dict_app <- instCallDicts loc theta
337 ; return (dict_app <.> mkWpTyApps tys) }
340 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
341 -- Similar to instCall, but only emit the constraints in the LIE
342 -- Used exclusively for the 'stupid theta' of a data constructor
343 instStupidTheta orig theta
344 = do { loc <- getInstLoc orig
345 ; _co <- instCallDicts loc theta -- Discard the coercion
349 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
350 -- Instantiates the TcTheta, puts all constraints thereby generated
351 -- into the LIE, and returns a HsWrapper to enclose the call site.
352 -- This is the key place where equality predicates
353 -- are unleashed into the world
354 instCallDicts _ [] = return idHsWrapper
356 -- instCallDicts loc (EqPred ty1 ty2 : preds)
357 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
358 -- -- Later on, when we do associated types,
359 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
360 -- ; (dicts, co_fn) <- instCallDicts loc preds
361 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
362 -- -- We use type application to apply the function to the
363 -- -- coercion; here ty1 *is* the appropriate identity coercion
365 instCallDicts loc (EqPred ty1 ty2 : preds)
366 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
367 ; coi <- boxyUnify ty1 ty2
368 ; let co = fromCoI coi ty1
369 ; co_fn <- instCallDicts loc preds
370 ; return (co_fn <.> WpTyApp co) }
372 instCallDicts loc (pred : preds)
373 = do { dict <- newDict loc pred
375 ; co_fn <- instCallDicts loc preds
376 ; return (co_fn <.> WpApp (instToId dict)) }
379 cloneDict :: Inst -> TcM Inst
380 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
381 ; return (dict {tci_name = setNameUnique nm uniq}) }
382 cloneDict eq@(EqInst {}) = return eq
383 cloneDict other = pprPanic "cloneDict" (ppr other)
385 -- For vanilla implicit parameters, there is only one in scope
386 -- at any time, so we used to use the name of the implicit parameter itself
387 -- But with splittable implicit parameters there may be many in
388 -- scope, so we make up a new namea.
389 newIPDict :: InstOrigin -> IPName Name -> Type
390 -> TcM (IPName Id, Inst)
391 newIPDict orig ip_name ty
392 = do { inst_loc <- getInstLoc orig
393 ; dict <- newDict inst_loc (IParam ip_name ty)
394 ; return (mapIPName (\_ -> instToId dict) ip_name, dict) }
399 mkPredName :: Unique -> InstLoc -> PredType -> Name
400 mkPredName uniq loc pred_ty
401 = mkInternalName uniq occ (instLocSpan loc)
403 occ = case pred_ty of
404 ClassP cls _ -> mkDictOcc (getOccName cls)
405 IParam ip _ -> getOccName (ipNameName ip)
406 EqPred ty _ -> mkEqPredCoOcc baseOcc
408 -- we use the outermost tycon of the lhs, if there is one, to
409 -- improve readability of Core code
410 baseOcc = case splitTyConApp_maybe ty of
411 Nothing -> mkTcOcc "$"
412 Just (tc, _) -> getOccName tc
415 %************************************************************************
417 \subsection{Building methods (calls of overloaded functions)}
419 %************************************************************************
423 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
424 newMethodFromName origin ty name = do
425 id <- tcLookupId name
426 -- Use tcLookupId not tcLookupGlobalId; the method is almost
427 -- always a class op, but with -XNoImplicitPrelude GHC is
428 -- meant to find whatever thing is in scope, and that may
429 -- be an ordinary function.
430 loc <- getInstLoc origin
431 inst <- tcInstClassOp loc id [ty]
433 return (instToId inst)
435 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
436 newMethodWithGivenTy orig id tys = do
437 loc <- getInstLoc orig
438 inst <- newMethod loc id tys
440 return (instToId inst)
442 --------------------------------------------
443 -- tcInstClassOp, and newMethod do *not* drop the
444 -- Inst into the LIE; they just returns the Inst
445 -- This is important because they are used by TcSimplify
448 -- NB: the kind of the type variable to be instantiated
449 -- might be a sub-kind of the type to which it is applied,
450 -- notably when the latter is a type variable of kind ??
451 -- Hence the call to checkKind
452 -- A worry: is this needed anywhere else?
453 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
454 tcInstClassOp inst_loc sel_id tys = do
456 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
457 zipWithM_ checkKind tyvars tys
458 newMethod inst_loc sel_id tys
460 checkKind :: TyVar -> TcType -> TcM ()
461 -- Ensure that the type has a sub-kind of the tyvar
464 -- ty1 <- zonkTcType ty
465 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
469 pprPanic "checkKind: adding kind constraint"
470 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
471 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
473 -- do { tv1 <- tcInstTyVar tv
474 -- ; unifyType ty1 (mkTyVarTy tv1) } }
477 ---------------------------
478 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
479 newMethod inst_loc id tys = do
480 new_uniq <- newUnique
482 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
483 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
484 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
485 tci_theta = theta, tci_loc = inst_loc}
486 loc = instLocSpan inst_loc
492 mkOverLit :: OverLitVal -> TcM HsLit
493 mkOverLit (HsIntegral i)
494 = do { integer_ty <- tcMetaTy integerTyConName
495 ; return (HsInteger i integer_ty) }
497 mkOverLit (HsFractional r)
498 = do { rat_ty <- tcMetaTy rationalTyConName
499 ; return (HsRat r rat_ty) }
501 mkOverLit (HsIsString s) = return (HsString s)
503 isHsVar :: HsExpr Name -> Name -> Bool
504 isHsVar (HsVar f) g = f == g
509 %************************************************************************
513 %************************************************************************
515 Zonking makes sure that the instance types are fully zonked.
518 zonkInst :: Inst -> TcM Inst
519 zonkInst dict@(Dict {tci_pred = pred}) = do
520 new_pred <- zonkTcPredType pred
521 return (dict {tci_pred = new_pred})
523 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
525 -- Essential to zonk the id in case it's a local variable
526 -- Can't use zonkIdOcc because the id might itself be
527 -- an InstId, in which case it won't be in scope
529 new_tys <- zonkTcTypes tys
530 new_theta <- zonkTcThetaType theta
531 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
532 -- No need to zonk the tci_id
534 zonkInst lit@(LitInst {tci_ty = ty}) = do
535 new_ty <- zonkTcType ty
536 return (lit {tci_ty = new_ty})
538 zonkInst implic@(ImplicInst {})
539 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
540 do { givens' <- zonkInsts (tci_given implic)
541 ; wanteds' <- zonkInsts (tci_wanted implic)
542 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
544 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
545 = do { co' <- eitherEqInst eqinst
546 (\covar -> return (mkWantedCo covar))
547 (\co -> liftM mkGivenCo $ zonkTcType co)
548 ; ty1' <- zonkTcType ty1
549 ; ty2' <- zonkTcType ty2
550 ; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' })
553 zonkInsts :: [Inst] -> TcRn [Inst]
554 zonkInsts insts = mapM zonkInst insts
558 %************************************************************************
560 \subsection{Printing}
562 %************************************************************************
564 ToDo: improve these pretty-printing things. The ``origin'' is really only
565 relevant in error messages.
568 instance Outputable Inst where
569 ppr inst = pprInst inst
571 pprDictsTheta :: [Inst] -> SDoc
572 -- Print in type-like fashion (Eq a, Show b)
573 -- The Inst can be an implication constraint, but not a Method or LitInst
574 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
576 pprDictsInFull :: [Inst] -> SDoc
577 -- Print in type-like fashion, but with source location
579 = vcat (map go dicts)
581 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
583 pprInsts :: [Inst] -> SDoc
584 -- Debugging: print the evidence :: type
585 pprInsts insts = brackets (interpp'SP insts)
587 pprInst, pprInstInFull :: Inst -> SDoc
588 -- Debugging: print the evidence :: type
589 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
591 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
592 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
593 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
594 <+> braces (ppr (instType inst) <> implicWantedEqs)
598 | isImplicInst inst = text " &" <+>
599 ppr (filter isEqInst (tci_wanted inst))
602 pprInstInFull inst@(EqInst {}) = pprInst inst
603 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
605 tidyInst :: TidyEnv -> Inst -> Inst
606 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
607 eq { tci_left = tidyType env lty
608 , tci_right = tidyType env rty
609 , tci_co = either Left (Right . tidyType env) co
611 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
612 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
613 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
614 tidyInst env implic@(ImplicInst {})
615 = implic { tci_tyvars = tvs'
616 , tci_given = map (tidyInst env') (tci_given implic)
617 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
619 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
621 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
622 -- This function doesn't assume that the tyvars are in scope
623 -- so it works like tidyOpenType, returning a TidyEnv
624 tidyMoreInsts env insts
625 = (env', map (tidyInst env') insts)
627 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
629 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
630 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
632 showLIE :: SDoc -> TcM () -- Debugging
634 = do { lie_var <- getLIEVar ;
635 lie <- readMutVar lie_var ;
636 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
640 %************************************************************************
642 Extending the instance environment
644 %************************************************************************
647 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
648 -- Add new locally-defined instances
649 tcExtendLocalInstEnv dfuns thing_inside
650 = do { traceDFuns dfuns
652 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
653 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
654 tcg_inst_env = inst_env' }
655 ; setGblEnv env' thing_inside }
657 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
658 -- Check that the proposed new instance is OK,
659 -- and then add it to the home inst env
660 addLocalInst home_ie ispec
661 = do { -- Instantiate the dfun type so that we extend the instance
662 -- envt with completely fresh template variables
663 -- This is important because the template variables must
664 -- not overlap with anything in the things being looked up
665 -- (since we do unification).
666 -- We use tcInstSkolType because we don't want to allocate fresh
667 -- *meta* type variables.
668 let dfun = instanceDFunId ispec
669 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
670 ; let (cls, tys') = tcSplitDFunHead tau'
671 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
672 ispec' = setInstanceDFunId ispec dfun'
674 -- Load imported instances, so that we report
675 -- duplicates correctly
677 ; let inst_envs = (eps_inst_env eps, home_ie)
679 -- Check functional dependencies
680 ; case checkFunDeps inst_envs ispec' of
681 Just specs -> funDepErr ispec' specs
684 -- Check for duplicate instance decls
685 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
686 ; dup_ispecs = [ dup_ispec
687 | (dup_ispec, _) <- matches
688 , let (_,_,_,dup_tys) = instanceHead dup_ispec
689 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
690 -- Find memebers of the match list which ispec itself matches.
691 -- If the match is 2-way, it's a duplicate
693 dup_ispec : _ -> dupInstErr ispec' dup_ispec
696 -- OK, now extend the envt
697 ; return (extendInstEnv home_ie ispec') }
699 getOverlapFlag :: TcM OverlapFlag
701 = do { dflags <- getDOpts
702 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
703 incoherent_ok = dopt Opt_IncoherentInstances dflags
704 overlap_flag | incoherent_ok = Incoherent
705 | overlap_ok = OverlapOk
706 | otherwise = NoOverlap
708 ; return overlap_flag }
710 traceDFuns :: [Instance] -> TcRn ()
712 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
714 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
715 -- Print the dfun name itself too
717 funDepErr :: Instance -> [Instance] -> TcRn ()
718 funDepErr ispec ispecs
720 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
721 2 (pprInstances (ispec:ispecs)))
722 dupInstErr :: Instance -> Instance -> TcRn ()
723 dupInstErr ispec dup_ispec
725 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
726 2 (pprInstances [ispec, dup_ispec]))
728 addDictLoc :: Instance -> TcRn a -> TcRn a
729 addDictLoc ispec thing_inside
730 = setSrcSpan (mkSrcSpan loc loc) thing_inside
732 loc = getSrcLoc ispec
736 %************************************************************************
738 \subsection{Looking up Insts}
740 %************************************************************************
743 data LookupInstResult
745 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
747 lookupSimpleInst :: Inst -> TcM LookupInstResult
748 -- This is "simple" in that it returns NoInstance for implication constraints
750 -- It's important that lookupInst does not put any new stuff into
751 -- the LIE. Instead, any Insts needed by the lookup are returned in
752 -- the LookupInstResult, where they can be further processed by tcSimplify
754 lookupSimpleInst (EqInst {}) = return NoInstance
756 --------------------- Implications ------------------------
757 lookupSimpleInst (ImplicInst {}) = return NoInstance
759 --------------------- Methods ------------------------
760 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
761 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
762 ; let co_fn = dict_app <.> mkWpTyApps tys
763 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
765 span = instLocSpan loc
767 --------------------- Literals ------------------------
768 -- Look for short cuts first: if the literal is *definitely* a
769 -- int, integer, float or a double, generate the real thing here.
770 -- This is essential (see nofib/spectral/nucleic).
771 -- [Same shortcut as in newOverloadedLit, but we
772 -- may have done some unification by now]
774 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
775 , ol_rebindable = rebindable }
776 , tci_ty = ty, tci_loc = iloc})
777 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
778 | Just witness <- shortCutLit lit_val ty
779 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
780 ; return (GenInst [] (L loc (HsOverLit lit'))) }
783 = do { hs_lit <- mkOverLit lit_val
784 ; from_thing <- tcLookupId (hsOverLitName lit_val)
785 -- Not rebindable, so hsOverLitName is the right thing
786 ; method_inst <- tcInstClassOp iloc from_thing [ty]
787 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
788 (L loc (HsLit hs_lit))
789 lit' = lit { ol_witness = witness, ol_type = ty }
790 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
792 loc = instLocSpan iloc
794 --------------------- Dictionaries ------------------------
795 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
796 = do { mb_result <- lookupPred pred
797 ; case mb_result of {
798 Nothing -> return NoInstance ;
799 Just (dfun_id, mb_inst_tys) -> do
801 { use_stage <- getStage
802 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
803 (topIdLvl dfun_id) use_stage
805 -- It's possible that not all the tyvars are in
806 -- the substitution, tenv. For example:
807 -- instance C X a => D X where ...
808 -- (presumably there's a functional dependency in class C)
809 -- Hence mb_inst_tys :: Either TyVar TcType
811 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
812 inst_tv (Right ty) = return ty
813 ; tys <- mapM inst_tv mb_inst_tys
815 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
816 src_loc = instLocSpan loc
819 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
821 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
822 ; let co_fn = dict_app <.> mkWpTyApps tys
823 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
827 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
828 -- Look up a class constraint in the instance environment
829 lookupPred pred@(ClassP clas tys)
831 ; tcg_env <- getGblEnv
832 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
833 ; case lookupInstEnv inst_envs clas tys of {
834 ([(ispec, inst_tys)], [])
835 -> do { let dfun_id = is_dfun ispec
836 ; traceTc (text "lookupInst success" <+>
837 vcat [text "dict" <+> ppr pred,
838 text "witness" <+> ppr dfun_id
839 <+> ppr (idType dfun_id) ])
840 -- Record that this dfun is needed
841 ; record_dfun_usage dfun_id
842 ; return (Just (dfun_id, inst_tys)) } ;
845 -> do { traceTc (text "lookupInst fail" <+>
846 vcat [text "dict" <+> ppr pred,
847 text "matches" <+> ppr matches,
848 text "unifs" <+> ppr unifs])
849 -- In the case of overlap (multiple matches) we report
850 -- NoInstance here. That has the effect of making the
851 -- context-simplifier return the dict as an irreducible one.
852 -- Then it'll be given to addNoInstanceErrs, which will do another
853 -- lookupInstEnv to get the detailed info about what went wrong.
857 lookupPred (IParam {}) = return Nothing -- Implicit parameters
858 lookupPred (EqPred {}) = panic "lookupPred EqPred"
860 record_dfun_usage :: Id -> TcRn ()
861 record_dfun_usage dfun_id
862 = do { hsc_env <- getTopEnv
863 ; let dfun_name = idName dfun_id
864 dfun_mod = ASSERT( isExternalName dfun_name )
866 ; if isInternalName dfun_name || -- Internal name => defined in this module
867 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
868 then return () -- internal, or in another package
869 else do { tcg_env <- getGblEnv
870 ; updMutVar (tcg_inst_uses tcg_env)
871 (`addOneToNameSet` idName dfun_id) }}
874 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
875 -- Gets both the external-package inst-env
876 -- and the home-pkg inst env (includes module being compiled)
877 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
878 return (eps_inst_env eps, tcg_inst_env env) }
883 %************************************************************************
887 %************************************************************************
889 Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
890 a do-expression. We have to find (>>) in the current environment, which is
891 done by the rename. Then we have to check that it has the same type as
892 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
895 (>>) :: HB m n mn => m a -> n b -> mn b
897 So the idea is to generate a local binding for (>>), thus:
899 let then72 :: forall a b. m a -> m b -> m b
900 then72 = ...something involving the user's (>>)...
902 ...the do-expression...
904 Now the do-expression can proceed using then72, which has exactly
907 In fact tcSyntaxName just generates the RHS for then72, because we only
908 want an actual binding in the do-expression case. For literals, we can
909 just use the expression inline.
912 tcSyntaxName :: InstOrigin
913 -> TcType -- Type to instantiate it at
914 -> (Name, HsExpr Name) -- (Standard name, user name)
915 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
916 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
917 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
918 -- So we do not call it from lookupInst, which is called from tcSimplify
920 tcSyntaxName orig ty (std_nm, HsVar user_nm)
922 = do id <- newMethodFromName orig ty std_nm
923 return (std_nm, HsVar id)
925 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
926 std_id <- tcLookupId std_nm
928 -- C.f. newMethodAtLoc
929 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
930 sigma1 = substTyWith [tv] [ty] tau
931 -- Actually, the "tau-type" might be a sigma-type in the
932 -- case of locally-polymorphic methods.
934 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
936 -- Check that the user-supplied thing has the
937 -- same type as the standard one.
938 -- Tiresome jiggling because tcCheckSigma takes a located expression
940 expr <- tcPolyExpr (L span user_nm_expr) sigma1
941 return (std_nm, unLoc expr)
943 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
944 -> TcRn (TidyEnv, SDoc)
945 syntaxNameCtxt name orig ty tidy_env = do
946 inst_loc <- getInstLoc orig
948 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
949 ptext (sLit "(needed by a syntactic construct)"),
950 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
951 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
953 return (tidy_env, msg)
956 %************************************************************************
960 %************************************************************************
962 Operations on EqInstCo.
965 mkGivenCo :: Coercion -> EqInstCo
968 mkWantedCo :: TcTyVar -> EqInstCo
971 isWantedCo :: EqInstCo -> Bool
972 isWantedCo (Left _) = True
975 eqInstCoType :: EqInstCo -> TcType
976 eqInstCoType (Left cotv) = mkTyVarTy cotv
977 eqInstCoType (Right co) = co
980 Coercion transformations on EqInstCo. These transformations work differently
981 depending on whether a EqInstCo is for a wanted or local equality:
983 Local : apply the inverse of the specified coercion
984 Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
985 to be the specified coercion applied to the new coercion hole
988 -- Coercion transformation: co = id
990 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
991 mkIdEqInstCo (Left cotv) t
992 = writeMetaTyVar cotv t
993 mkIdEqInstCo (Right _) _
996 -- Coercion transformation: co = sym co'
998 mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
999 mkSymEqInstCo (Left cotv) (ty1, ty2)
1000 = do { cotv' <- newMetaCoVar ty1 ty2
1001 ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
1002 ; return $ Left cotv'
1004 mkSymEqInstCo (Right co) _
1005 = return $ Right (mkSymCoercion co)
1007 -- Coercion transformation: co = co' |> given_co
1009 mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1010 mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
1011 = do { cotv' <- newMetaCoVar ty1 ty2
1012 ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
1013 ; return $ Left cotv'
1015 mkLeftTransEqInstCo (Right co) given_co _
1016 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1018 -- Coercion transformation: co = given_co |> co'
1020 mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1021 mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
1022 = do { cotv' <- newMetaCoVar ty1 ty2
1023 ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
1024 ; return $ Left cotv'
1026 mkRightTransEqInstCo (Right co) given_co _
1027 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1029 -- Coercion transformation: co = col cor
1031 mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
1032 -> TcM (EqInstCo, EqInstCo)
1033 mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
1034 = do { cotv_l <- newMetaCoVar ty1_l ty2_l
1035 ; cotv_r <- newMetaCoVar ty1_r ty2_r
1036 ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
1037 ; return (Left cotv_l, Left cotv_r)
1039 mkAppEqInstCo (Right co) _ _
1040 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1043 Operations on entire EqInst.
1046 -- |A wanted equality is unsolved as long as its cotv is unfilled.
1048 wantedEqInstIsUnsolved :: Inst -> TcM Bool
1049 wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
1050 = liftM not $ isFilledMetaTyVar cotv
1051 wantedEqInstIsUnsolved _ = return True
1053 eitherEqInst :: Inst -- given or wanted EqInst
1054 -> (TcTyVar -> a) -- result if wanted
1055 -> (Coercion -> a) -- result if given
1057 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1059 Left covar -> withWanted covar
1060 Right co -> withGiven co
1061 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
1063 mkEqInst :: PredType -> EqInstCo -> TcM Inst
1064 mkEqInst (EqPred ty1 ty2) co
1065 = do { uniq <- newUnique
1066 ; src_span <- getSrcSpanM
1067 ; err_ctxt <- getErrCtxt
1068 ; let loc = InstLoc EqOrigin src_span err_ctxt
1069 name = mkName uniq src_span
1070 inst = EqInst { tci_left = ty1
1079 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1080 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1082 mkWantedEqInst :: PredType -> TcM Inst
1083 mkWantedEqInst pred@(EqPred ty1 ty2)
1084 = do { cotv <- newMetaCoVar ty1 ty2
1085 ; mkEqInst pred (Left cotv)
1087 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
1089 -- Turn a wanted equality into a local that propagates the uninstantiated
1090 -- coercion variable as witness. We need this to propagate wanted irreds into
1091 -- attempts to solve implication constraints.
1093 wantedToLocalEqInst :: Inst -> Inst
1094 wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
1095 = eq {tci_co = Right (mkTyVarTy cotv)}
1096 wantedToLocalEqInst eq = eq
1098 -- Turn a wanted into a local EqInst (needed during type inference for
1101 -- * Give it a name and change the coercion around.
1103 finalizeEqInst :: Inst -- wanted
1104 -> TcM Inst -- given
1105 finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2,
1106 tci_name = name, tci_co = Left cotv})
1107 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1109 -- fill the coercion hole
1110 ; writeMetaTyVar cotv (TyVarTy var)
1112 -- set the new coercion
1113 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1117 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1119 eqInstType :: Inst -> TcType
1120 eqInstType inst = eitherEqInst inst mkTyVarTy id
1122 eqInstCoercion :: Inst -> EqInstCo
1123 eqInstCoercion = tci_co
1125 eqInstTys :: Inst -> (TcType, TcType)
1126 eqInstTys inst = (tci_left inst, tci_right inst)