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 (instToId inst) rhs))
215 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
216 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
223 isAbstractableInst :: Inst -> Bool
224 isAbstractableInst inst = isDict inst || isEqInst inst
226 isEqInst :: Inst -> Bool
227 isEqInst (EqInst {}) = True
230 isDict :: Inst -> Bool
231 isDict (Dict {}) = True
234 isClassDict :: Inst -> Bool
235 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
236 isClassDict _ = False
238 isTyVarDict :: Inst -> Bool
239 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
240 isTyVarDict _ = False
242 isIPDict :: Inst -> Bool
243 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
246 isImplicInst :: Inst -> Bool
247 isImplicInst (ImplicInst {}) = True
248 isImplicInst _ = False
250 isMethod :: Inst -> Bool
251 isMethod (Method {}) = True
254 isMethodFor :: TcIdSet -> Inst -> Bool
255 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
256 isMethodFor _ _ = False
258 isMethodOrLit :: Inst -> Bool
259 isMethodOrLit (Method {}) = True
260 isMethodOrLit (LitInst {}) = True
261 isMethodOrLit _ = False
265 %************************************************************************
267 \subsection{Building dictionaries}
269 %************************************************************************
271 -- newDictBndrs makes a dictionary at a binding site
272 -- instCall makes a dictionary at an occurrence site
273 -- and throws it into the LIE
277 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
278 newDictBndrsO orig theta = do { loc <- getInstLoc orig
279 ; newDictBndrs loc theta }
281 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
282 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
284 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
286 newDictBndr inst_loc pred@(EqPred ty1 ty2)
287 = do { uniq <- newUnique
288 ; let name = mkPredName uniq inst_loc pred
289 co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
290 ; return (EqInst {tci_name = name,
296 newDictBndr inst_loc pred = newDict inst_loc pred
299 newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
300 newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
302 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
304 newDictOcc inst_loc pred@(EqPred ty1 ty2)
305 = do { uniq <- newUnique
306 ; cotv <- newMetaCoVar ty1 ty2
307 ; let name = mkPredName uniq inst_loc pred
308 ; return (EqInst {tci_name = name,
312 tci_co = Left cotv }) }
314 newDictOcc inst_loc pred = newDict inst_loc pred
317 newDict :: InstLoc -> TcPredType -> TcM Inst
318 -- Always makes a Dict, not an EqInst
319 newDict inst_loc pred
320 = do { uniq <- newUnique
321 ; let name = mkPredName uniq inst_loc pred
322 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
325 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
326 -- Instantiate the constraints of a call
327 -- (instCall o tys theta)
328 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
329 -- (b) Throws these dictionaries into the LIE
330 -- (c) Returns an HsWrapper ([.] tys dicts)
332 instCall orig tys theta
333 = do { loc <- getInstLoc orig
334 ; dict_app <- instCallDicts loc theta
335 ; return (dict_app <.> mkWpTyApps tys) }
338 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
339 -- Similar to instCall, but only emit the constraints in the LIE
340 -- Used exclusively for the 'stupid theta' of a data constructor
341 instStupidTheta orig theta
342 = do { loc <- getInstLoc orig
343 ; _co <- instCallDicts loc theta -- Discard the coercion
347 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
348 -- Instantiates the TcTheta, puts all constraints thereby generated
349 -- into the LIE, and returns a HsWrapper to enclose the call site.
350 -- This is the key place where equality predicates
351 -- are unleashed into the world
352 instCallDicts _ [] = return idHsWrapper
354 -- instCallDicts loc (EqPred ty1 ty2 : preds)
355 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
356 -- -- Later on, when we do associated types,
357 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
358 -- ; (dicts, co_fn) <- instCallDicts loc preds
359 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
360 -- -- We use type application to apply the function to the
361 -- -- coercion; here ty1 *is* the appropriate identity coercion
363 instCallDicts loc (EqPred ty1 ty2 : preds)
364 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
365 ; coi <- boxyUnify ty1 ty2
366 ; let co = fromCoI coi ty1
367 ; co_fn <- instCallDicts loc preds
368 ; return (co_fn <.> WpTyApp co) }
370 instCallDicts loc (pred : preds)
371 = do { dict <- newDict loc pred
373 ; co_fn <- instCallDicts loc preds
374 ; return (co_fn <.> WpApp (instToId dict)) }
377 cloneDict :: Inst -> TcM Inst
378 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
379 ; return (dict {tci_name = setNameUnique nm uniq}) }
380 cloneDict eq@(EqInst {}) = return eq
381 cloneDict other = pprPanic "cloneDict" (ppr other)
383 -- For vanilla implicit parameters, there is only one in scope
384 -- at any time, so we used to use the name of the implicit parameter itself
385 -- But with splittable implicit parameters there may be many in
386 -- scope, so we make up a new namea.
387 newIPDict :: InstOrigin -> IPName Name -> Type
388 -> TcM (IPName Id, Inst)
389 newIPDict orig ip_name ty
390 = do { inst_loc <- getInstLoc orig
391 ; dict <- newDict inst_loc (IParam ip_name ty)
392 ; return (mapIPName (\_ -> instToId dict) ip_name, dict) }
397 mkPredName :: Unique -> InstLoc -> PredType -> Name
398 mkPredName uniq loc pred_ty
399 = mkInternalName uniq occ (instLocSpan loc)
401 occ = case pred_ty of
402 ClassP cls _ -> mkDictOcc (getOccName cls)
403 IParam ip _ -> getOccName (ipNameName ip)
404 EqPred ty _ -> mkEqPredCoOcc baseOcc
406 -- we use the outermost tycon of the lhs, if there is one, to
407 -- improve readability of Core code
408 baseOcc = case splitTyConApp_maybe ty of
409 Nothing -> mkTcOcc "$"
410 Just (tc, _) -> getOccName tc
413 %************************************************************************
415 \subsection{Building methods (calls of overloaded functions)}
417 %************************************************************************
421 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
422 newMethodFromName origin ty name = do
423 id <- tcLookupId name
424 -- Use tcLookupId not tcLookupGlobalId; the method is almost
425 -- always a class op, but with -XNoImplicitPrelude GHC is
426 -- meant to find whatever thing is in scope, and that may
427 -- be an ordinary function.
428 loc <- getInstLoc origin
429 inst <- tcInstClassOp loc id [ty]
431 return (instToId inst)
433 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
434 newMethodWithGivenTy orig id tys = do
435 loc <- getInstLoc orig
436 inst <- newMethod loc id tys
438 return (instToId inst)
440 --------------------------------------------
441 -- tcInstClassOp, and newMethod do *not* drop the
442 -- Inst into the LIE; they just returns the Inst
443 -- This is important because they are used by TcSimplify
446 -- NB: the kind of the type variable to be instantiated
447 -- might be a sub-kind of the type to which it is applied,
448 -- notably when the latter is a type variable of kind ??
449 -- Hence the call to checkKind
450 -- A worry: is this needed anywhere else?
451 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
452 tcInstClassOp inst_loc sel_id tys = do
454 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
455 zipWithM_ checkKind tyvars tys
456 newMethod inst_loc sel_id tys
458 checkKind :: TyVar -> TcType -> TcM ()
459 -- Ensure that the type has a sub-kind of the tyvar
462 -- ty1 <- zonkTcType ty
463 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
467 pprPanic "checkKind: adding kind constraint"
468 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
469 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
471 -- do { tv1 <- tcInstTyVar tv
472 -- ; unifyType ty1 (mkTyVarTy tv1) } }
475 ---------------------------
476 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
477 newMethod inst_loc id tys = do
478 new_uniq <- newUnique
480 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
481 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
482 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
483 tci_theta = theta, tci_loc = inst_loc}
484 loc = instLocSpan inst_loc
490 mkOverLit :: OverLitVal -> TcM HsLit
491 mkOverLit (HsIntegral i)
492 = do { integer_ty <- tcMetaTy integerTyConName
493 ; return (HsInteger i integer_ty) }
495 mkOverLit (HsFractional r)
496 = do { rat_ty <- tcMetaTy rationalTyConName
497 ; return (HsRat r rat_ty) }
499 mkOverLit (HsIsString s) = return (HsString s)
501 isHsVar :: HsExpr Name -> Name -> Bool
502 isHsVar (HsVar f) g = f == g
507 %************************************************************************
511 %************************************************************************
513 Zonking makes sure that the instance types are fully zonked.
516 zonkInst :: Inst -> TcM Inst
517 zonkInst dict@(Dict {tci_pred = pred}) = do
518 new_pred <- zonkTcPredType pred
519 return (dict {tci_pred = new_pred})
521 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
523 -- Essential to zonk the id in case it's a local variable
524 -- Can't use zonkIdOcc because the id might itself be
525 -- an InstId, in which case it won't be in scope
527 new_tys <- zonkTcTypes tys
528 new_theta <- zonkTcThetaType theta
529 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
530 -- No need to zonk the tci_id
532 zonkInst lit@(LitInst {tci_ty = ty}) = do
533 new_ty <- zonkTcType ty
534 return (lit {tci_ty = new_ty})
536 zonkInst implic@(ImplicInst {})
537 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
538 do { givens' <- zonkInsts (tci_given implic)
539 ; wanteds' <- zonkInsts (tci_wanted implic)
540 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
542 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
543 = do { co' <- eitherEqInst eqinst
544 (\covar -> return (mkWantedCo covar))
545 (\co -> liftM mkGivenCo $ zonkTcType co)
546 ; ty1' <- zonkTcType ty1
547 ; ty2' <- zonkTcType ty2
548 ; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' })
551 zonkInsts :: [Inst] -> TcRn [Inst]
552 zonkInsts insts = mapM zonkInst insts
556 %************************************************************************
558 \subsection{Printing}
560 %************************************************************************
562 ToDo: improve these pretty-printing things. The ``origin'' is really only
563 relevant in error messages.
566 instance Outputable Inst where
567 ppr inst = pprInst inst
569 pprDictsTheta :: [Inst] -> SDoc
570 -- Print in type-like fashion (Eq a, Show b)
571 -- The Inst can be an implication constraint, but not a Method or LitInst
572 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
574 pprDictsInFull :: [Inst] -> SDoc
575 -- Print in type-like fashion, but with source location
577 = vcat (map go dicts)
579 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
581 pprInsts :: [Inst] -> SDoc
582 -- Debugging: print the evidence :: type
583 pprInsts insts = brackets (interpp'SP insts)
585 pprInst, pprInstInFull :: Inst -> SDoc
586 -- Debugging: print the evidence :: type
587 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
589 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
590 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
591 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
592 <+> braces (ppr (instType inst) <> implicWantedEqs)
596 | isImplicInst inst = text " &" <+>
597 ppr (filter isEqInst (tci_wanted inst))
600 pprInstInFull inst@(EqInst {}) = pprInst inst
601 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
603 tidyInst :: TidyEnv -> Inst -> Inst
604 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
605 eq { tci_left = tidyType env lty
606 , tci_right = tidyType env rty
607 , tci_co = either Left (Right . tidyType env) co
609 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
610 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
611 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
612 tidyInst env implic@(ImplicInst {})
613 = implic { tci_tyvars = tvs'
614 , tci_given = map (tidyInst env') (tci_given implic)
615 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
617 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
619 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
620 -- This function doesn't assume that the tyvars are in scope
621 -- so it works like tidyOpenType, returning a TidyEnv
622 tidyMoreInsts env insts
623 = (env', map (tidyInst env') insts)
625 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
627 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
628 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
630 showLIE :: SDoc -> TcM () -- Debugging
632 = do { lie_var <- getLIEVar ;
633 lie <- readMutVar lie_var ;
634 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
638 %************************************************************************
640 Extending the instance environment
642 %************************************************************************
645 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
646 -- Add new locally-defined instances
647 tcExtendLocalInstEnv dfuns thing_inside
648 = do { traceDFuns dfuns
650 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
651 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
652 tcg_inst_env = inst_env' }
653 ; setGblEnv env' thing_inside }
655 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
656 -- Check that the proposed new instance is OK,
657 -- and then add it to the home inst env
658 addLocalInst home_ie ispec
659 = do { -- Instantiate the dfun type so that we extend the instance
660 -- envt with completely fresh template variables
661 -- This is important because the template variables must
662 -- not overlap with anything in the things being looked up
663 -- (since we do unification).
664 -- We use tcInstSkolType because we don't want to allocate fresh
665 -- *meta* type variables.
666 let dfun = instanceDFunId ispec
667 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
668 ; let (cls, tys') = tcSplitDFunHead tau'
669 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
670 ispec' = setInstanceDFunId ispec dfun'
672 -- Load imported instances, so that we report
673 -- duplicates correctly
675 ; let inst_envs = (eps_inst_env eps, home_ie)
677 -- Check functional dependencies
678 ; case checkFunDeps inst_envs ispec' of
679 Just specs -> funDepErr ispec' specs
682 -- Check for duplicate instance decls
683 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
684 ; dup_ispecs = [ dup_ispec
685 | (dup_ispec, _) <- matches
686 , let (_,_,_,dup_tys) = instanceHead dup_ispec
687 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
688 -- Find memebers of the match list which ispec itself matches.
689 -- If the match is 2-way, it's a duplicate
691 dup_ispec : _ -> dupInstErr ispec' dup_ispec
694 -- OK, now extend the envt
695 ; return (extendInstEnv home_ie ispec') }
697 getOverlapFlag :: TcM OverlapFlag
699 = do { dflags <- getDOpts
700 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
701 incoherent_ok = dopt Opt_IncoherentInstances dflags
702 overlap_flag | incoherent_ok = Incoherent
703 | overlap_ok = OverlapOk
704 | otherwise = NoOverlap
706 ; return overlap_flag }
708 traceDFuns :: [Instance] -> TcRn ()
710 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
712 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
713 -- Print the dfun name itself too
715 funDepErr :: Instance -> [Instance] -> TcRn ()
716 funDepErr ispec ispecs
718 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
719 2 (pprInstances (ispec:ispecs)))
720 dupInstErr :: Instance -> Instance -> TcRn ()
721 dupInstErr ispec dup_ispec
723 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
724 2 (pprInstances [ispec, dup_ispec]))
726 addDictLoc :: Instance -> TcRn a -> TcRn a
727 addDictLoc ispec thing_inside
728 = setSrcSpan (mkSrcSpan loc loc) thing_inside
730 loc = getSrcLoc ispec
734 %************************************************************************
736 \subsection{Looking up Insts}
738 %************************************************************************
741 data LookupInstResult
743 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
745 lookupSimpleInst :: Inst -> TcM LookupInstResult
746 -- This is "simple" in that it returns NoInstance for implication constraints
748 -- It's important that lookupInst does not put any new stuff into
749 -- the LIE. Instead, any Insts needed by the lookup are returned in
750 -- the LookupInstResult, where they can be further processed by tcSimplify
752 lookupSimpleInst (EqInst {}) = return NoInstance
754 --------------------- Implications ------------------------
755 lookupSimpleInst (ImplicInst {}) = return NoInstance
757 --------------------- Methods ------------------------
758 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
759 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
760 ; let co_fn = dict_app <.> mkWpTyApps tys
761 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
763 span = instLocSpan loc
765 --------------------- Literals ------------------------
766 -- Look for short cuts first: if the literal is *definitely* a
767 -- int, integer, float or a double, generate the real thing here.
768 -- This is essential (see nofib/spectral/nucleic).
769 -- [Same shortcut as in newOverloadedLit, but we
770 -- may have done some unification by now]
772 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
773 , ol_rebindable = rebindable }
774 , tci_ty = ty, tci_loc = iloc})
775 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
776 | Just witness <- shortCutLit lit_val ty
777 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
778 ; return (GenInst [] (L loc (HsOverLit lit'))) }
781 = do { hs_lit <- mkOverLit lit_val
782 ; from_thing <- tcLookupId (hsOverLitName lit_val)
783 -- Not rebindable, so hsOverLitName is the right thing
784 ; method_inst <- tcInstClassOp iloc from_thing [ty]
785 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
786 (L loc (HsLit hs_lit))
787 lit' = lit { ol_witness = witness, ol_type = ty }
788 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
790 loc = instLocSpan iloc
792 --------------------- Dictionaries ------------------------
793 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
794 = do { mb_result <- lookupPred pred
795 ; case mb_result of {
796 Nothing -> return NoInstance ;
797 Just (dfun_id, mb_inst_tys) -> do
799 { use_stage <- getStage
800 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
801 (topIdLvl dfun_id) use_stage
803 -- It's possible that not all the tyvars are in
804 -- the substitution, tenv. For example:
805 -- instance C X a => D X where ...
806 -- (presumably there's a functional dependency in class C)
807 -- Hence mb_inst_tys :: Either TyVar TcType
809 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
810 inst_tv (Right ty) = return ty
811 ; tys <- mapM inst_tv mb_inst_tys
813 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
814 src_loc = instLocSpan loc
817 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
819 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
820 ; let co_fn = dict_app <.> mkWpTyApps tys
821 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
825 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
826 -- Look up a class constraint in the instance environment
827 lookupPred pred@(ClassP clas tys)
829 ; tcg_env <- getGblEnv
830 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
831 ; case lookupInstEnv inst_envs clas tys of {
832 ([(ispec, inst_tys)], [])
833 -> do { let dfun_id = is_dfun ispec
834 ; traceTc (text "lookupInst success" <+>
835 vcat [text "dict" <+> ppr pred,
836 text "witness" <+> ppr dfun_id
837 <+> ppr (idType dfun_id) ])
838 -- Record that this dfun is needed
839 ; record_dfun_usage dfun_id
840 ; return (Just (dfun_id, inst_tys)) } ;
843 -> do { traceTc (text "lookupInst fail" <+>
844 vcat [text "dict" <+> ppr pred,
845 text "matches" <+> ppr matches,
846 text "unifs" <+> ppr unifs])
847 -- In the case of overlap (multiple matches) we report
848 -- NoInstance here. That has the effect of making the
849 -- context-simplifier return the dict as an irreducible one.
850 -- Then it'll be given to addNoInstanceErrs, which will do another
851 -- lookupInstEnv to get the detailed info about what went wrong.
855 lookupPred (IParam {}) = return Nothing -- Implicit parameters
856 lookupPred (EqPred {}) = panic "lookupPred EqPred"
858 record_dfun_usage :: Id -> TcRn ()
859 record_dfun_usage dfun_id
860 = do { hsc_env <- getTopEnv
861 ; let dfun_name = idName dfun_id
862 dfun_mod = ASSERT( isExternalName dfun_name )
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 eqInstCoType :: EqInstCo -> TcType
974 eqInstCoType (Left cotv) = mkTyVarTy cotv
975 eqInstCoType (Right co) = co
978 Coercion transformations on EqInstCo. These transformations work differently
979 depending on whether a EqInstCo is for a wanted or local equality:
981 Local : apply the inverse of the specified coercion
982 Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
983 to be the specified coercion applied to the new coercion hole
986 -- Coercion transformation: co = id
988 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
989 mkIdEqInstCo (Left cotv) t
990 = writeMetaTyVar cotv t
991 mkIdEqInstCo (Right _) _
994 -- Coercion transformation: co = sym co'
996 mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
997 mkSymEqInstCo (Left cotv) (ty1, ty2)
998 = do { cotv' <- newMetaCoVar ty1 ty2
999 ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
1000 ; return $ Left cotv'
1002 mkSymEqInstCo (Right co) _
1003 = return $ Right (mkSymCoercion co)
1005 -- Coercion transformation: co = co' |> given_co
1007 mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1008 mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
1009 = do { cotv' <- newMetaCoVar ty1 ty2
1010 ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
1011 ; return $ Left cotv'
1013 mkLeftTransEqInstCo (Right co) given_co _
1014 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1016 -- Coercion transformation: co = given_co |> co'
1018 mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1019 mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
1020 = do { cotv' <- newMetaCoVar ty1 ty2
1021 ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
1022 ; return $ Left cotv'
1024 mkRightTransEqInstCo (Right co) given_co _
1025 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1027 -- Coercion transformation: co = col cor
1029 mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
1030 -> TcM (EqInstCo, EqInstCo)
1031 mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
1032 = do { cotv_l <- newMetaCoVar ty1_l ty2_l
1033 ; cotv_r <- newMetaCoVar ty1_r ty2_r
1034 ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
1035 ; return (Left cotv_l, Left cotv_r)
1037 mkAppEqInstCo (Right co) _ _
1038 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1041 Operations on entire EqInst.
1044 -- |A wanted equality is unsolved as long as its cotv is unfilled.
1046 wantedEqInstIsUnsolved :: Inst -> TcM Bool
1047 wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
1048 = liftM not $ isFilledMetaTyVar cotv
1049 wantedEqInstIsUnsolved _ = return True
1051 eitherEqInst :: Inst -- given or wanted EqInst
1052 -> (TcTyVar -> a) -- result if wanted
1053 -> (Coercion -> a) -- result if given
1055 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1057 Left covar -> withWanted covar
1058 Right co -> withGiven co
1059 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
1061 mkEqInst :: PredType -> EqInstCo -> TcM Inst
1062 mkEqInst (EqPred ty1 ty2) co
1063 = do { uniq <- newUnique
1064 ; src_span <- getSrcSpanM
1065 ; err_ctxt <- getErrCtxt
1066 ; let loc = InstLoc EqOrigin src_span err_ctxt
1067 name = mkName uniq src_span
1068 inst = EqInst { tci_left = ty1
1077 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1078 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1080 mkWantedEqInst :: PredType -> TcM Inst
1081 mkWantedEqInst pred@(EqPred ty1 ty2)
1082 = do { cotv <- newMetaCoVar ty1 ty2
1083 ; mkEqInst pred (Left cotv)
1085 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
1087 -- Turn a wanted equality into a local that propagates the uninstantiated
1088 -- coercion variable as witness. We need this to propagate wanted irreds into
1089 -- attempts to solve implication constraints.
1091 wantedToLocalEqInst :: Inst -> Inst
1092 wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
1093 = eq {tci_co = Right (mkTyVarTy cotv)}
1094 wantedToLocalEqInst eq = eq
1096 -- Turn a wanted into a local EqInst (needed during type inference for
1099 -- * Give it a name and change the coercion around.
1101 finalizeEqInst :: Inst -- wanted
1102 -> TcM Inst -- given
1103 finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2,
1104 tci_name = name, tci_co = Left cotv})
1105 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1107 -- fill the coercion hole
1108 ; writeMetaTyVar cotv (TyVarTy var)
1110 -- set the new coercion
1111 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1115 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1117 eqInstType :: Inst -> TcType
1118 eqInstType inst = eitherEqInst inst mkTyVarTy id
1120 eqInstCoercion :: Inst -> EqInstCo
1121 eqInstCoercion = tci_co
1123 eqInstTys :: Inst -> (TcType, TcType)
1124 eqInstTys inst = (tci_left inst, tci_right inst)