2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The @Inst@ type: dictionaries or method instances
12 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
13 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
15 tidyInsts, tidyMoreInsts,
17 newDictBndr, newDictBndrs, newDictBndrsO,
18 newDictOccs, newDictOcc,
19 instCall, instStupidTheta,
21 newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
23 tcSyntaxName, isHsVar,
25 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
26 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
27 getDictClassTys, dictPred,
29 lookupSimpleInst, LookupInstResult(..),
30 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
32 isAbstractableInst, isEqInst,
33 isDict, isClassDict, isMethod, isImplicInst,
34 isIPDict, isInheritableInst, isMethodOrLit,
35 isTyVarDict, isMethodFor,
38 instToId, instToVar, instType, instName, instToDictBind,
41 InstOrigin(..), InstLoc, pprInstLoc,
43 mkWantedCo, mkGivenCo,
44 isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType,
45 mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo,
46 mkRightTransEqInstCo, mkAppEqInstCo,
48 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, finalizeEqInst,
49 eqInstType, updateEqInstCoercion,
50 eqInstCoercion, eqInstTys
53 #include "HsVersions.h"
55 import {-# SOURCE #-} TcExpr( tcPolyExpr )
56 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
79 import Var ( Var, TyVar )
102 instName :: Inst -> Name
103 instName (EqInst {tci_name = name}) = name
104 instName inst = Var.varName (instToVar inst)
106 instToId :: Inst -> TcId
107 instToId inst = WARN( not (isId id), ppr inst )
112 instToVar :: Inst -> Var
113 instToVar (LitInst {tci_name = nm, tci_ty = ty})
115 instToVar (Method {tci_id = id})
117 instToVar (Dict {tci_name = nm, tci_pred = pred})
118 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
119 | otherwise = mkLocalId nm (mkPredTy pred)
120 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
121 tci_wanted = wanteds})
122 = mkLocalId nm (mkImplicTy tvs givens wanteds)
123 instToVar i@(EqInst {})
124 = eitherEqInst i id (\(TyVarTy covar) -> covar)
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 = nameModule dfun_name
863 ; if isInternalName dfun_name || -- Internal name => defined in this module
864 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
865 then return () -- internal, or in another package
866 else do { tcg_env <- getGblEnv
867 ; updMutVar (tcg_inst_uses tcg_env)
868 (`addOneToNameSet` idName dfun_id) }}
871 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
872 -- Gets both the external-package inst-env
873 -- and the home-pkg inst env (includes module being compiled)
874 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
875 return (eps_inst_env eps, tcg_inst_env env) }
880 %************************************************************************
884 %************************************************************************
886 Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
887 a do-expression. We have to find (>>) in the current environment, which is
888 done by the rename. Then we have to check that it has the same type as
889 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
892 (>>) :: HB m n mn => m a -> n b -> mn b
894 So the idea is to generate a local binding for (>>), thus:
896 let then72 :: forall a b. m a -> m b -> m b
897 then72 = ...something involving the user's (>>)...
899 ...the do-expression...
901 Now the do-expression can proceed using then72, which has exactly
904 In fact tcSyntaxName just generates the RHS for then72, because we only
905 want an actual binding in the do-expression case. For literals, we can
906 just use the expression inline.
909 tcSyntaxName :: InstOrigin
910 -> TcType -- Type to instantiate it at
911 -> (Name, HsExpr Name) -- (Standard name, user name)
912 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
913 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
914 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
915 -- So we do not call it from lookupInst, which is called from tcSimplify
917 tcSyntaxName orig ty (std_nm, HsVar user_nm)
919 = do id <- newMethodFromName orig ty std_nm
920 return (std_nm, HsVar id)
922 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
923 std_id <- tcLookupId std_nm
925 -- C.f. newMethodAtLoc
926 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
927 sigma1 = substTyWith [tv] [ty] tau
928 -- Actually, the "tau-type" might be a sigma-type in the
929 -- case of locally-polymorphic methods.
931 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
933 -- Check that the user-supplied thing has the
934 -- same type as the standard one.
935 -- Tiresome jiggling because tcCheckSigma takes a located expression
937 expr <- tcPolyExpr (L span user_nm_expr) sigma1
938 return (std_nm, unLoc expr)
940 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
941 -> TcRn (TidyEnv, SDoc)
942 syntaxNameCtxt name orig ty tidy_env = do
943 inst_loc <- getInstLoc orig
945 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
946 ptext (sLit "(needed by a syntactic construct)"),
947 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
948 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
950 return (tidy_env, msg)
953 %************************************************************************
957 %************************************************************************
959 Operations on EqInstCo.
962 mkGivenCo :: Coercion -> EqInstCo
965 mkWantedCo :: TcTyVar -> EqInstCo
968 isWantedCo :: EqInstCo -> Bool
969 isWantedCo (Left _) = True
972 fromGivenCo :: EqInstCo -> Coercion
973 fromGivenCo (Right co) = co
974 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
976 fromWantedCo :: String -> EqInstCo -> TcTyVar
977 fromWantedCo _ (Left covar) = covar
979 panic ("fromWantedCo: not a wanted coercion: " ++ msg)
981 eqInstCoType :: EqInstCo -> TcType
982 eqInstCoType (Left cotv) = mkTyVarTy cotv
983 eqInstCoType (Right co) = co
986 Coercion transformations on EqInstCo. These transformations work differently
987 depending on whether a EqInstCo is for a wanted or local equality:
989 Local : apply the inverse of the specified coercion
990 Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
991 to be the specified coercion applied to the new coercion hole
994 -- Coercion transformation: co = id
996 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
997 mkIdEqInstCo (Left cotv) t
998 = writeMetaTyVar cotv t
999 mkIdEqInstCo (Right _) _
1002 -- Coercion transformation: co = sym co'
1004 mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
1005 mkSymEqInstCo (Left cotv) (ty1, ty2)
1006 = do { cotv' <- newMetaCoVar ty1 ty2
1007 ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
1008 ; return $ Left cotv'
1010 mkSymEqInstCo (Right co) _
1011 = return $ Right (mkSymCoercion co)
1013 -- Coercion transformation: co = co' |> given_co
1015 mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1016 mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
1017 = do { cotv' <- newMetaCoVar ty1 ty2
1018 ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
1019 ; return $ Left cotv'
1021 mkLeftTransEqInstCo (Right co) given_co _
1022 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1024 -- Coercion transformation: co = given_co |> co'
1026 mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1027 mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
1028 = do { cotv' <- newMetaCoVar ty1 ty2
1029 ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
1030 ; return $ Left cotv'
1032 mkRightTransEqInstCo (Right co) given_co _
1033 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1035 -- Coercion transformation: co = col cor
1037 mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
1038 -> TcM (EqInstCo, EqInstCo)
1039 mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
1040 = do { cotv_l <- newMetaCoVar ty1_l ty2_l
1041 ; cotv_r <- newMetaCoVar ty1_r ty2_r
1042 ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
1043 ; return (Left cotv_l, Left cotv_r)
1045 mkAppEqInstCo (Right co) _ _
1046 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1049 Operations on entire EqInst.
1052 -- For debugging, make sure the cotv of a wanted is not filled.
1054 isValidWantedEqInst :: Inst -> TcM Bool
1055 isValidWantedEqInst (EqInst {tci_co = Left cotv})
1056 = liftM not $ isFilledMetaTyVar cotv
1057 isValidWantedEqInst _ = return True
1059 eitherEqInst :: Inst -- given or wanted EqInst
1060 -> (TcTyVar -> a) -- result if wanted
1061 -> (Coercion -> a) -- result if given
1063 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1065 Left covar -> withWanted covar
1066 Right co -> withGiven co
1067 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
1069 mkEqInsts :: [PredType] -> [EqInstCo] -> TcM [Inst]
1070 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1072 mkEqInst :: PredType -> EqInstCo -> TcM Inst
1073 mkEqInst (EqPred ty1 ty2) co
1074 = do { uniq <- newUnique
1075 ; src_span <- getSrcSpanM
1076 ; err_ctxt <- getErrCtxt
1077 ; let loc = InstLoc EqOrigin src_span err_ctxt
1078 name = mkName uniq src_span
1079 inst = EqInst { tci_left = ty1
1088 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1089 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1091 mkWantedEqInst :: PredType -> TcM Inst
1092 mkWantedEqInst pred@(EqPred ty1 ty2)
1093 = do { cotv <- newMetaCoVar ty1 ty2
1094 ; mkEqInst pred (Left cotv)
1096 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
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, tci_name = name})
1106 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1108 -- fill the coercion hole
1109 ; let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
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)
1128 updateEqInstCoercion :: (EqInstCo -> EqInstCo) -> Inst -> Inst
1129 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}