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 growInstsTyVars, 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 --------------------------------
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 {}) = []
171 fdPredsOfInsts :: [Inst] -> [PredType]
172 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
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
181 ---------------------------------
182 -- Get the implicit parameters mentioned by these Insts
183 -- NB: the results of these functions are insensitive to zonking
185 ipNamesOfInsts :: [Inst] -> [Name]
186 ipNamesOfInst :: Inst -> [Name]
187 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
189 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
190 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
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
207 tyVarsOfInsts :: [Inst] -> VarSet
208 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
209 tyVarsOfLIE :: Bag Inst -> VarSet
210 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
213 --------------------------
214 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
215 instToDictBind inst rhs
216 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
218 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
219 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
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
227 E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
228 Then grow precs tvs = {a,b,c}
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]
234 See also Note [Ambiguity] in TcSimplify
237 growInstsTyVars :: [Inst] -> TyVarSet -> TyVarSet
238 growInstsTyVars insts tvs
240 | otherwise = fixVarSet mk_next tvs
242 mk_next tvs = foldr grow_inst_tvs tvs insts
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
255 %************************************************************************
259 %************************************************************************
263 isAbstractableInst :: Inst -> Bool
264 isAbstractableInst inst = isDict inst || isEqInst inst
266 isEqInst :: Inst -> Bool
267 isEqInst (EqInst {}) = True
270 isDict :: Inst -> Bool
271 isDict (Dict {}) = True
274 isClassDict :: Inst -> Bool
275 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
276 isClassDict _ = False
278 isTyVarDict :: Inst -> Bool
279 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
280 isTyVarDict _ = False
282 isIPDict :: Inst -> Bool
283 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
286 isImplicInst :: Inst -> Bool
287 isImplicInst (ImplicInst {}) = True
288 isImplicInst _ = False
290 isMethod :: Inst -> Bool
291 isMethod (Method {}) = True
294 isMethodFor :: TcIdSet -> Inst -> Bool
295 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
296 isMethodFor _ _ = False
298 isMethodOrLit :: Inst -> Bool
299 isMethodOrLit (Method {}) = True
300 isMethodOrLit (LitInst {}) = True
301 isMethodOrLit _ = False
305 %************************************************************************
307 \subsection{Building dictionaries}
309 %************************************************************************
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
317 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
318 newDictBndrsO orig theta = do { loc <- getInstLoc orig
319 ; newDictBndrs loc theta }
321 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
322 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
324 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
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,
336 newDictBndr inst_loc pred = newDict inst_loc pred
339 newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
340 newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
342 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
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,
352 tci_co = Left cotv }) }
354 newDictOcc inst_loc pred = newDict inst_loc pred
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}) }
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)
372 instCall orig tys theta
373 = do { loc <- getInstLoc orig
374 ; dict_app <- instCallDicts loc theta
375 ; return (dict_app <.> mkWpTyApps tys) }
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
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
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
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) }
410 instCallDicts loc (pred : preds)
411 = do { dict <- newDict loc pred
413 ; co_fn <- instCallDicts loc preds
414 ; return (co_fn <.> WpApp (instToId dict)) }
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)
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) }
437 mkPredName :: Unique -> InstLoc -> PredType -> Name
438 mkPredName uniq loc pred_ty
439 = mkInternalName uniq occ (instLocSpan loc)
441 occ = case pred_ty of
442 ClassP cls _ -> mkDictOcc (getOccName cls)
443 IParam ip _ -> getOccName (ipNameName ip)
444 EqPred ty _ -> mkEqPredCoOcc baseOcc
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
453 %************************************************************************
455 \subsection{Building methods (calls of overloaded functions)}
457 %************************************************************************
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]
471 return (instToId inst)
473 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
474 newMethodWithGivenTy orig id tys = do
475 loc <- getInstLoc orig
476 inst <- newMethod loc id tys
478 return (instToId inst)
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
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
494 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
495 zipWithM_ checkKind tyvars tys
496 newMethod inst_loc sel_id tys
498 checkKind :: TyVar -> TcType -> TcM ()
499 -- Ensure that the type has a sub-kind of the tyvar
502 -- ty1 <- zonkTcType ty
503 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
507 pprPanic "checkKind: adding kind constraint"
508 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
509 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
511 -- do { tv1 <- tcInstTyVar tv
512 -- ; unifyType ty1 (mkTyVarTy tv1) } }
515 ---------------------------
516 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
517 newMethod inst_loc id tys = do
518 new_uniq <- newUnique
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
530 mkOverLit :: OverLitVal -> TcM HsLit
531 mkOverLit (HsIntegral i)
532 = do { integer_ty <- tcMetaTy integerTyConName
533 ; return (HsInteger i integer_ty) }
535 mkOverLit (HsFractional r)
536 = do { rat_ty <- tcMetaTy rationalTyConName
537 ; return (HsRat r rat_ty) }
539 mkOverLit (HsIsString s) = return (HsString s)
541 isHsVar :: HsExpr Name -> Name -> Bool
542 isHsVar (HsVar f) g = f == g
547 %************************************************************************
551 %************************************************************************
553 Zonking makes sure that the instance types are fully zonked.
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})
561 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
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
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
572 zonkInst lit@(LitInst {tci_ty = ty}) = do
573 new_ty <- zonkTcType ty
574 return (lit {tci_ty = new_ty})
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'}) }
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' })
591 zonkInsts :: [Inst] -> TcRn [Inst]
592 zonkInsts insts = mapM zonkInst insts
596 %************************************************************************
598 \subsection{Printing}
600 %************************************************************************
602 ToDo: improve these pretty-printing things. The ``origin'' is really only
603 relevant in error messages.
606 instance Outputable Inst where
607 ppr inst = pprInst inst
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)))
614 pprDictsInFull :: [Inst] -> SDoc
615 -- Print in type-like fashion, but with source location
617 = vcat (map go dicts)
619 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
621 pprInsts :: [Inst] -> SDoc
622 -- Debugging: print the evidence :: type
623 pprInsts insts = brackets (interpp'SP insts)
625 pprInst, pprInstInFull :: Inst -> SDoc
626 -- Debugging: print the evidence :: type
627 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
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)
636 | isImplicInst inst = text " &" <+>
637 ppr (filter isEqInst (tci_wanted inst))
640 pprInstInFull inst@(EqInst {}) = pprInst inst
641 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
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
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) }
657 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
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)
665 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
667 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
668 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
670 showLIE :: SDoc -> TcM () -- Debugging
672 = do { lie_var <- getLIEVar ;
673 lie <- readMutVar lie_var ;
674 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
678 %************************************************************************
680 Extending the instance environment
682 %************************************************************************
685 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
686 -- Add new locally-defined instances
687 tcExtendLocalInstEnv dfuns thing_inside
688 = do { traceDFuns dfuns
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 }
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'
712 -- Load imported instances, so that we report
713 -- duplicates correctly
715 ; let inst_envs = (eps_inst_env eps, home_ie)
717 -- Check functional dependencies
718 ; case checkFunDeps inst_envs ispec' of
719 Just specs -> funDepErr ispec' specs
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
731 dup_ispec : _ -> dupInstErr ispec' dup_ispec
734 -- OK, now extend the envt
735 ; return (extendInstEnv home_ie ispec') }
737 getOverlapFlag :: TcM OverlapFlag
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
746 ; return overlap_flag }
748 traceDFuns :: [Instance] -> TcRn ()
750 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
752 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
753 -- Print the dfun name itself too
755 funDepErr :: Instance -> [Instance] -> TcRn ()
756 funDepErr ispec ispecs
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
763 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
764 2 (pprInstances [ispec, dup_ispec]))
766 addDictLoc :: Instance -> TcRn a -> TcRn a
767 addDictLoc ispec thing_inside
768 = setSrcSpan (mkSrcSpan loc loc) thing_inside
770 loc = getSrcLoc ispec
774 %************************************************************************
776 \subsection{Looking up Insts}
778 %************************************************************************
781 data LookupInstResult
783 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
785 lookupSimpleInst :: Inst -> TcM LookupInstResult
786 -- This is "simple" in that it returns NoInstance for implication constraints
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
792 lookupSimpleInst (EqInst {}) = return NoInstance
794 --------------------- Implications ------------------------
795 lookupSimpleInst (ImplicInst {}) = return NoInstance
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))) }
803 span = instLocSpan loc
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]
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'))) }
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'))) }
830 loc = instLocSpan iloc
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
839 { use_stage <- getStage
840 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
841 (topIdLvl dfun_id) use_stage
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
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
853 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
854 src_loc = instLocSpan loc
857 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
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))
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)
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)) } ;
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.
895 lookupPred (IParam {}) = return Nothing -- Implicit parameters
896 lookupPred (EqPred {}) = panic "lookupPred EqPred"
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 )
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) }}
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) }
921 %************************************************************************
925 %************************************************************************
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
933 (>>) :: HB m n mn => m a -> n b -> mn b
935 So the idea is to generate a local binding for (>>), thus:
937 let then72 :: forall a b. m a -> m b -> m b
938 then72 = ...something involving the user's (>>)...
940 ...the do-expression...
942 Now the do-expression can proceed using then72, which has exactly
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.
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
958 tcSyntaxName orig ty (std_nm, HsVar user_nm)
960 = do id <- newMethodFromName orig ty std_nm
961 return (std_nm, HsVar id)
963 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
964 std_id <- tcLookupId std_nm
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.
972 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
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
978 expr <- tcPolyExpr (L span user_nm_expr) sigma1
979 return (std_nm, unLoc expr)
981 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
982 -> TcRn (TidyEnv, SDoc)
983 syntaxNameCtxt name orig ty tidy_env = do
984 inst_loc <- getInstLoc orig
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)]
991 return (tidy_env, msg)
994 %************************************************************************
998 %************************************************************************
1000 Operations on EqInstCo.
1003 mkGivenCo :: Coercion -> EqInstCo
1006 mkWantedCo :: TcTyVar -> EqInstCo
1009 isWantedCo :: EqInstCo -> Bool
1010 isWantedCo (Left _) = True
1011 isWantedCo _ = False
1013 eqInstCoType :: EqInstCo -> TcType
1014 eqInstCoType (Left cotv) = mkTyVarTy cotv
1015 eqInstCoType (Right co) = co
1018 Coercion transformations on EqInstCo. These transformations work differently
1019 depending on whether a EqInstCo is for a wanted or local equality:
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
1026 -- Coercion transformation: co = id
1028 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
1029 mkIdEqInstCo (Left cotv) t
1030 = writeMetaTyVar cotv t
1031 mkIdEqInstCo (Right _) _
1034 -- Coercion transformation: co = sym co'
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'
1042 mkSymEqInstCo (Right co) _
1043 = return $ Right (mkSymCoercion co)
1045 -- Coercion transformation: co = co' |> given_co
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'
1053 mkLeftTransEqInstCo (Right co) given_co _
1054 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1056 -- Coercion transformation: co = given_co |> co'
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'
1064 mkRightTransEqInstCo (Right co) given_co _
1065 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1067 -- Coercion transformation: co = col cor
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)
1077 mkAppEqInstCo (Right co) _ _
1078 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1081 Operations on entire EqInst.
1084 -- |A wanted equality is unsolved as long as its cotv is unfilled.
1086 wantedEqInstIsUnsolved :: Inst -> TcM Bool
1087 wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
1088 = liftM not $ isFilledMetaTyVar cotv
1089 wantedEqInstIsUnsolved _ = return True
1091 eitherEqInst :: Inst -- given or wanted EqInst
1092 -> (TcTyVar -> a) -- result if wanted
1093 -> (Coercion -> a) -- result if given
1095 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1097 Left covar -> withWanted covar
1098 Right co -> withGiven co
1099 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
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
1117 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1118 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1120 mkWantedEqInst :: PredType -> TcM Inst
1121 mkWantedEqInst pred@(EqPred ty1 ty2)
1122 = do { cotv <- newMetaCoVar ty1 ty2
1123 ; mkEqInst pred (Left cotv)
1125 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
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.
1131 wantedToLocalEqInst :: Inst -> Inst
1132 wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
1133 = eq {tci_co = Right (mkTyVarTy cotv)}
1134 wantedToLocalEqInst eq = eq
1136 -- Turn a wanted into a local EqInst (needed during type inference for
1139 -- * Give it a name and change the coercion around.
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)
1147 -- fill the coercion hole
1148 ; writeMetaTyVar cotv (TyVarTy var)
1150 -- set the new coercion
1151 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1155 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1157 eqInstType :: Inst -> TcType
1158 eqInstType inst = eitherEqInst inst mkTyVarTy id
1160 eqInstCoercion :: Inst -> EqInstCo
1161 eqInstCoercion = tci_co
1163 eqInstTys :: Inst -> (TcType, TcType)
1164 eqInstTys inst = (tci_left inst, tci_right inst)