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,
47 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, finalizeEqInst,
48 eqInstType, updateEqInstCoercion,
49 eqInstCoercion, eqInstTys
52 #include "HsVersions.h"
54 import {-# SOURCE #-} TcExpr( tcPolyExpr )
55 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
78 import Var ( Var, TyVar )
101 instName :: Inst -> Name
102 instName (EqInst {tci_name = name}) = name
103 instName inst = Var.varName (instToVar inst)
105 instToId :: Inst -> TcId
106 instToId inst = WARN( not (isId id), ppr inst )
111 instToVar :: Inst -> Var
112 instToVar (LitInst {tci_name = nm, tci_ty = ty})
114 instToVar (Method {tci_id = id})
116 instToVar (Dict {tci_name = nm, tci_pred = pred})
117 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
118 | otherwise = mkLocalId nm (mkPredTy pred)
119 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
120 tci_wanted = wanteds})
121 = mkLocalId nm (mkImplicTy tvs givens wanteds)
122 instToVar i@(EqInst {})
123 = eitherEqInst i id (\(TyVarTy covar) -> covar)
125 instType :: Inst -> Type
126 instType (LitInst {tci_ty = ty}) = ty
127 instType (Method {tci_id = id}) = idType id
128 instType (Dict {tci_pred = pred}) = mkPredTy pred
129 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
131 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
132 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
134 mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
135 mkImplicTy tvs givens wanteds -- The type of an implication constraint
136 = ASSERT( all isAbstractableInst givens )
137 -- pprTrace "mkImplicTy" (ppr givens) $
138 -- See [Equational Constraints in Implication Constraints]
139 let dict_wanteds = filter (not . isEqInst) wanteds
142 mkPhiTy (map dictPred givens) $
143 mkBigCoreTupTy (map instType dict_wanteds)
145 dictPred :: Inst -> TcPredType
146 dictPred (Dict {tci_pred = pred}) = pred
147 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
148 dictPred inst = pprPanic "dictPred" (ppr inst)
150 getDictClassTys :: Inst -> (Class, [Type])
151 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
152 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
154 -- fdPredsOfInst is used to get predicates that contain functional
155 -- dependencies *or* might do so. The "might do" part is because
156 -- a constraint (C a b) might have a superclass with FDs
157 -- Leaving these in is really important for the call to fdPredsOfInsts
158 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
159 -- which is supposed to be conservative
160 fdPredsOfInst :: Inst -> [TcPredType]
161 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
162 fdPredsOfInst (Method {tci_theta = theta}) = theta
163 fdPredsOfInst (ImplicInst {tci_given = gs,
164 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
165 fdPredsOfInst (LitInst {}) = []
166 fdPredsOfInst (EqInst {}) = []
168 fdPredsOfInsts :: [Inst] -> [PredType]
169 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
171 isInheritableInst :: Inst -> Bool
172 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
173 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
174 isInheritableInst _ = True
177 ---------------------------------
178 -- Get the implicit parameters mentioned by these Insts
179 -- NB: the results of these functions are insensitive to zonking
181 ipNamesOfInsts :: [Inst] -> [Name]
182 ipNamesOfInst :: Inst -> [Name]
183 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
185 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
186 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
189 ---------------------------------
190 tyVarsOfInst :: Inst -> TcTyVarSet
191 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
192 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
193 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
194 -- The id might have free type variables; in the case of
195 -- locally-overloaded class methods, for example
196 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
197 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
198 `minusVarSet` mkVarSet tvs
199 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
200 -- Remember the free tyvars of a coercion
201 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
203 tyVarsOfInsts :: [Inst] -> VarSet
204 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
205 tyVarsOfLIE :: Bag Inst -> VarSet
206 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
209 --------------------------
210 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
211 instToDictBind inst rhs
212 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
214 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
215 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
222 isAbstractableInst :: Inst -> Bool
223 isAbstractableInst inst = isDict inst || isEqInst inst
225 isEqInst :: Inst -> Bool
226 isEqInst (EqInst {}) = True
229 isDict :: Inst -> Bool
230 isDict (Dict {}) = True
233 isClassDict :: Inst -> Bool
234 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
235 isClassDict _ = False
237 isTyVarDict :: Inst -> Bool
238 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
239 isTyVarDict _ = False
241 isIPDict :: Inst -> Bool
242 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
245 isImplicInst :: Inst -> Bool
246 isImplicInst (ImplicInst {}) = True
247 isImplicInst _ = False
249 isMethod :: Inst -> Bool
250 isMethod (Method {}) = True
253 isMethodFor :: TcIdSet -> Inst -> Bool
254 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
255 isMethodFor _ _ = False
257 isMethodOrLit :: Inst -> Bool
258 isMethodOrLit (Method {}) = True
259 isMethodOrLit (LitInst {}) = True
260 isMethodOrLit _ = False
264 %************************************************************************
266 \subsection{Building dictionaries}
268 %************************************************************************
270 -- newDictBndrs makes a dictionary at a binding site
271 -- instCall makes a dictionary at an occurrence site
272 -- and throws it into the LIE
276 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
277 newDictBndrsO orig theta = do { loc <- getInstLoc orig
278 ; newDictBndrs loc theta }
280 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
281 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
283 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
285 newDictBndr inst_loc pred@(EqPred ty1 ty2)
286 = do { uniq <- newUnique
287 ; let name = mkPredName uniq inst_loc pred
288 co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
289 ; return (EqInst {tci_name = name,
295 newDictBndr inst_loc pred = newDict inst_loc pred
298 newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
299 newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
301 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
303 newDictOcc inst_loc pred@(EqPred ty1 ty2)
304 = do { uniq <- newUnique
305 ; cotv <- newMetaCoVar ty1 ty2
306 ; let name = mkPredName uniq inst_loc pred
307 ; return (EqInst {tci_name = name,
311 tci_co = Left cotv }) }
313 newDictOcc inst_loc pred = newDict inst_loc pred
316 newDict :: InstLoc -> TcPredType -> TcM Inst
317 -- Always makes a Dict, not an EqInst
318 newDict inst_loc pred
319 = do { uniq <- newUnique
320 ; let name = mkPredName uniq inst_loc pred
321 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
324 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
325 -- Instantiate the constraints of a call
326 -- (instCall o tys theta)
327 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
328 -- (b) Throws these dictionaries into the LIE
329 -- (c) Returns an HsWrapper ([.] tys dicts)
331 instCall orig tys theta
332 = do { loc <- getInstLoc orig
333 ; dict_app <- instCallDicts loc theta
334 ; return (dict_app <.> mkWpTyApps tys) }
337 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
338 -- Similar to instCall, but only emit the constraints in the LIE
339 -- Used exclusively for the 'stupid theta' of a data constructor
340 instStupidTheta orig theta
341 = do { loc <- getInstLoc orig
342 ; _co <- instCallDicts loc theta -- Discard the coercion
346 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
347 -- Instantiates the TcTheta, puts all constraints thereby generated
348 -- into the LIE, and returns a HsWrapper to enclose the call site.
349 -- This is the key place where equality predicates
350 -- are unleashed into the world
351 instCallDicts _ [] = return idHsWrapper
353 -- instCallDicts loc (EqPred ty1 ty2 : preds)
354 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
355 -- -- Later on, when we do associated types,
356 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
357 -- ; (dicts, co_fn) <- instCallDicts loc preds
358 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
359 -- -- We use type application to apply the function to the
360 -- -- coercion; here ty1 *is* the appropriate identity coercion
362 instCallDicts loc (EqPred ty1 ty2 : preds)
363 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
364 ; coi <- boxyUnify ty1 ty2
365 ; let co = fromCoI coi ty1
366 ; co_fn <- instCallDicts loc preds
367 ; return (co_fn <.> WpTyApp co) }
369 instCallDicts loc (pred : preds)
370 = do { dict <- newDict loc pred
372 ; co_fn <- instCallDicts loc preds
373 ; return (co_fn <.> WpApp (instToId dict)) }
376 cloneDict :: Inst -> TcM Inst
377 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
378 ; return (dict {tci_name = setNameUnique nm uniq}) }
379 cloneDict eq@(EqInst {}) = return eq
380 cloneDict other = pprPanic "cloneDict" (ppr other)
382 -- For vanilla implicit parameters, there is only one in scope
383 -- at any time, so we used to use the name of the implicit parameter itself
384 -- But with splittable implicit parameters there may be many in
385 -- scope, so we make up a new namea.
386 newIPDict :: InstOrigin -> IPName Name -> Type
387 -> TcM (IPName Id, Inst)
388 newIPDict orig ip_name ty
389 = do { inst_loc <- getInstLoc orig
390 ; dict <- newDict inst_loc (IParam ip_name ty)
391 ; return (mapIPName (\_ -> instToId dict) ip_name, dict) }
396 mkPredName :: Unique -> InstLoc -> PredType -> Name
397 mkPredName uniq loc pred_ty
398 = mkInternalName uniq occ (instLocSpan loc)
400 occ = case pred_ty of
401 ClassP cls _ -> mkDictOcc (getOccName cls)
402 IParam ip _ -> getOccName (ipNameName ip)
403 EqPred ty _ -> mkEqPredCoOcc baseOcc
405 -- we use the outermost tycon of the lhs, if there is one, to
406 -- improve readability of Core code
407 baseOcc = case splitTyConApp_maybe ty of
408 Nothing -> mkTcOcc "$"
409 Just (tc, _) -> getOccName tc
412 %************************************************************************
414 \subsection{Building methods (calls of overloaded functions)}
416 %************************************************************************
420 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
421 newMethodFromName origin ty name = do
422 id <- tcLookupId name
423 -- Use tcLookupId not tcLookupGlobalId; the method is almost
424 -- always a class op, but with -XNoImplicitPrelude GHC is
425 -- meant to find whatever thing is in scope, and that may
426 -- be an ordinary function.
427 loc <- getInstLoc origin
428 inst <- tcInstClassOp loc id [ty]
430 return (instToId inst)
432 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
433 newMethodWithGivenTy orig id tys = do
434 loc <- getInstLoc orig
435 inst <- newMethod loc id tys
437 return (instToId inst)
439 --------------------------------------------
440 -- tcInstClassOp, and newMethod do *not* drop the
441 -- Inst into the LIE; they just returns the Inst
442 -- This is important because they are used by TcSimplify
445 -- NB: the kind of the type variable to be instantiated
446 -- might be a sub-kind of the type to which it is applied,
447 -- notably when the latter is a type variable of kind ??
448 -- Hence the call to checkKind
449 -- A worry: is this needed anywhere else?
450 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
451 tcInstClassOp inst_loc sel_id tys = do
453 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
454 zipWithM_ checkKind tyvars tys
455 newMethod inst_loc sel_id tys
457 checkKind :: TyVar -> TcType -> TcM ()
458 -- Ensure that the type has a sub-kind of the tyvar
461 -- ty1 <- zonkTcType ty
462 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
466 pprPanic "checkKind: adding kind constraint"
467 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
468 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
470 -- do { tv1 <- tcInstTyVar tv
471 -- ; unifyType ty1 (mkTyVarTy tv1) } }
474 ---------------------------
475 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
476 newMethod inst_loc id tys = do
477 new_uniq <- newUnique
479 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
480 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
481 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
482 tci_theta = theta, tci_loc = inst_loc}
483 loc = instLocSpan inst_loc
489 mkOverLit :: OverLitVal -> TcM HsLit
490 mkOverLit (HsIntegral i)
491 = do { integer_ty <- tcMetaTy integerTyConName
492 ; return (HsInteger i integer_ty) }
494 mkOverLit (HsFractional r)
495 = do { rat_ty <- tcMetaTy rationalTyConName
496 ; return (HsRat r rat_ty) }
498 mkOverLit (HsIsString s) = return (HsString s)
500 isHsVar :: HsExpr Name -> Name -> Bool
501 isHsVar (HsVar f) g = f == g
506 %************************************************************************
510 %************************************************************************
512 Zonking makes sure that the instance types are fully zonked.
515 zonkInst :: Inst -> TcM Inst
516 zonkInst dict@(Dict { tci_pred = pred}) = do
517 new_pred <- zonkTcPredType pred
518 return (dict {tci_pred = new_pred})
520 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
522 -- Essential to zonk the id in case it's a local variable
523 -- Can't use zonkIdOcc because the id might itself be
524 -- an InstId, in which case it won't be in scope
526 new_tys <- zonkTcTypes tys
527 new_theta <- zonkTcThetaType theta
528 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
529 -- No need to zonk the tci_id
531 zonkInst lit@(LitInst {tci_ty = ty}) = do
532 new_ty <- zonkTcType ty
533 return (lit {tci_ty = new_ty})
535 zonkInst implic@(ImplicInst {})
536 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
537 do { givens' <- zonkInsts (tci_given implic)
538 ; wanteds' <- zonkInsts (tci_wanted implic)
539 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
541 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
542 = do { co' <- eitherEqInst eqinst
543 (\covar -> return (mkWantedCo covar))
544 (\co -> liftM mkGivenCo $ zonkTcType co)
545 ; ty1' <- zonkTcType ty1
546 ; ty2' <- zonkTcType ty2
547 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
550 zonkInsts :: [Inst] -> TcRn [Inst]
551 zonkInsts insts = mapM zonkInst insts
555 %************************************************************************
557 \subsection{Printing}
559 %************************************************************************
561 ToDo: improve these pretty-printing things. The ``origin'' is really only
562 relevant in error messages.
565 instance Outputable Inst where
566 ppr inst = pprInst inst
568 pprDictsTheta :: [Inst] -> SDoc
569 -- Print in type-like fashion (Eq a, Show b)
570 -- The Inst can be an implication constraint, but not a Method or LitInst
571 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
573 pprDictsInFull :: [Inst] -> SDoc
574 -- Print in type-like fashion, but with source location
576 = vcat (map go dicts)
578 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
580 pprInsts :: [Inst] -> SDoc
581 -- Debugging: print the evidence :: type
582 pprInsts insts = brackets (interpp'SP insts)
584 pprInst, pprInstInFull :: Inst -> SDoc
585 -- Debugging: print the evidence :: type
586 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
588 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
589 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
590 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
591 <+> braces (ppr (instType inst) <> implicWantedEqs)
595 | isImplicInst inst = text " &" <+>
596 ppr (filter isEqInst (tci_wanted inst))
599 pprInstInFull inst@(EqInst {}) = pprInst inst
600 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
602 tidyInst :: TidyEnv -> Inst -> Inst
603 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
604 eq { tci_left = tidyType env lty
605 , tci_right = tidyType env rty
606 , tci_co = either Left (Right . tidyType env) co
608 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
609 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
610 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
611 tidyInst env implic@(ImplicInst {})
612 = implic { tci_tyvars = tvs'
613 , tci_given = map (tidyInst env') (tci_given implic)
614 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
616 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
618 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
619 -- This function doesn't assume that the tyvars are in scope
620 -- so it works like tidyOpenType, returning a TidyEnv
621 tidyMoreInsts env insts
622 = (env', map (tidyInst env') insts)
624 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
626 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
627 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
629 showLIE :: SDoc -> TcM () -- Debugging
631 = do { lie_var <- getLIEVar ;
632 lie <- readMutVar lie_var ;
633 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
637 %************************************************************************
639 Extending the instance environment
641 %************************************************************************
644 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
645 -- Add new locally-defined instances
646 tcExtendLocalInstEnv dfuns thing_inside
647 = do { traceDFuns dfuns
649 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
650 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
651 tcg_inst_env = inst_env' }
652 ; setGblEnv env' thing_inside }
654 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
655 -- Check that the proposed new instance is OK,
656 -- and then add it to the home inst env
657 addLocalInst home_ie ispec
658 = do { -- Instantiate the dfun type so that we extend the instance
659 -- envt with completely fresh template variables
660 -- This is important because the template variables must
661 -- not overlap with anything in the things being looked up
662 -- (since we do unification).
663 -- We use tcInstSkolType because we don't want to allocate fresh
664 -- *meta* type variables.
665 let dfun = instanceDFunId ispec
666 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
667 ; let (cls, tys') = tcSplitDFunHead tau'
668 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
669 ispec' = setInstanceDFunId ispec dfun'
671 -- Load imported instances, so that we report
672 -- duplicates correctly
674 ; let inst_envs = (eps_inst_env eps, home_ie)
676 -- Check functional dependencies
677 ; case checkFunDeps inst_envs ispec' of
678 Just specs -> funDepErr ispec' specs
681 -- Check for duplicate instance decls
682 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
683 ; dup_ispecs = [ dup_ispec
684 | (dup_ispec, _) <- matches
685 , let (_,_,_,dup_tys) = instanceHead dup_ispec
686 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
687 -- Find memebers of the match list which ispec itself matches.
688 -- If the match is 2-way, it's a duplicate
690 dup_ispec : _ -> dupInstErr ispec' dup_ispec
693 -- OK, now extend the envt
694 ; return (extendInstEnv home_ie ispec') }
696 getOverlapFlag :: TcM OverlapFlag
698 = do { dflags <- getDOpts
699 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
700 incoherent_ok = dopt Opt_IncoherentInstances dflags
701 overlap_flag | incoherent_ok = Incoherent
702 | overlap_ok = OverlapOk
703 | otherwise = NoOverlap
705 ; return overlap_flag }
707 traceDFuns :: [Instance] -> TcRn ()
709 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
711 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
712 -- Print the dfun name itself too
714 funDepErr :: Instance -> [Instance] -> TcRn ()
715 funDepErr ispec ispecs
717 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
718 2 (pprInstances (ispec:ispecs)))
719 dupInstErr :: Instance -> Instance -> TcRn ()
720 dupInstErr ispec dup_ispec
722 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
723 2 (pprInstances [ispec, dup_ispec]))
725 addDictLoc :: Instance -> TcRn a -> TcRn a
726 addDictLoc ispec thing_inside
727 = setSrcSpan (mkSrcSpan loc loc) thing_inside
729 loc = getSrcLoc ispec
733 %************************************************************************
735 \subsection{Looking up Insts}
737 %************************************************************************
740 data LookupInstResult
742 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
744 lookupSimpleInst :: Inst -> TcM LookupInstResult
745 -- This is "simple" in that it returns NoInstance for implication constraints
747 -- It's important that lookupInst does not put any new stuff into
748 -- the LIE. Instead, any Insts needed by the lookup are returned in
749 -- the LookupInstResult, where they can be further processed by tcSimplify
751 lookupSimpleInst (EqInst {}) = return NoInstance
753 --------------------- Implications ------------------------
754 lookupSimpleInst (ImplicInst {}) = return NoInstance
756 --------------------- Methods ------------------------
757 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
758 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
759 ; let co_fn = dict_app <.> mkWpTyApps tys
760 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
762 span = instLocSpan loc
764 --------------------- Literals ------------------------
765 -- Look for short cuts first: if the literal is *definitely* a
766 -- int, integer, float or a double, generate the real thing here.
767 -- This is essential (see nofib/spectral/nucleic).
768 -- [Same shortcut as in newOverloadedLit, but we
769 -- may have done some unification by now]
771 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
772 , ol_rebindable = rebindable }
773 , tci_ty = ty, tci_loc = iloc})
774 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
775 | Just witness <- shortCutLit lit_val ty
776 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
777 ; return (GenInst [] (L loc (HsOverLit lit'))) }
780 = do { hs_lit <- mkOverLit lit_val
781 ; from_thing <- tcLookupId (hsOverLitName lit_val)
782 -- Not rebindable, so hsOverLitName is the right thing
783 ; method_inst <- tcInstClassOp iloc from_thing [ty]
784 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
785 (L loc (HsLit hs_lit))
786 lit' = lit { ol_witness = witness, ol_type = ty }
787 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
789 loc = instLocSpan iloc
791 --------------------- Dictionaries ------------------------
792 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
793 = do { mb_result <- lookupPred pred
794 ; case mb_result of {
795 Nothing -> return NoInstance ;
796 Just (dfun_id, mb_inst_tys) -> do
798 { use_stage <- getStage
799 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
800 (topIdLvl dfun_id) use_stage
802 -- It's possible that not all the tyvars are in
803 -- the substitution, tenv. For example:
804 -- instance C X a => D X where ...
805 -- (presumably there's a functional dependency in class C)
806 -- Hence mb_inst_tys :: Either TyVar TcType
808 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
809 inst_tv (Right ty) = return ty
810 ; tys <- mapM inst_tv mb_inst_tys
812 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
813 src_loc = instLocSpan loc
816 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
818 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
819 ; let co_fn = dict_app <.> mkWpTyApps tys
820 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
824 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
825 -- Look up a class constraint in the instance environment
826 lookupPred pred@(ClassP clas tys)
828 ; tcg_env <- getGblEnv
829 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
830 ; case lookupInstEnv inst_envs clas tys of {
831 ([(ispec, inst_tys)], [])
832 -> do { let dfun_id = is_dfun ispec
833 ; traceTc (text "lookupInst success" <+>
834 vcat [text "dict" <+> ppr pred,
835 text "witness" <+> ppr dfun_id
836 <+> ppr (idType dfun_id) ])
837 -- Record that this dfun is needed
838 ; record_dfun_usage dfun_id
839 ; return (Just (dfun_id, inst_tys)) } ;
842 -> do { traceTc (text "lookupInst fail" <+>
843 vcat [text "dict" <+> ppr pred,
844 text "matches" <+> ppr matches,
845 text "unifs" <+> ppr unifs])
846 -- In the case of overlap (multiple matches) we report
847 -- NoInstance here. That has the effect of making the
848 -- context-simplifier return the dict as an irreducible one.
849 -- Then it'll be given to addNoInstanceErrs, which will do another
850 -- lookupInstEnv to get the detailed info about what went wrong.
854 lookupPred (IParam {}) = return Nothing -- Implicit parameters
855 lookupPred (EqPred {}) = panic "lookupPred EqPred"
857 record_dfun_usage :: Id -> TcRn ()
858 record_dfun_usage dfun_id
859 = do { hsc_env <- getTopEnv
860 ; let dfun_name = idName dfun_id
861 dfun_mod = nameModule dfun_name
862 ; if isInternalName dfun_name || -- Internal name => defined in this module
863 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
864 then return () -- internal, or in another package
865 else do { tcg_env <- getGblEnv
866 ; updMutVar (tcg_inst_uses tcg_env)
867 (`addOneToNameSet` idName dfun_id) }}
870 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
871 -- Gets both the external-package inst-env
872 -- and the home-pkg inst env (includes module being compiled)
873 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
874 return (eps_inst_env eps, tcg_inst_env env) }
879 %************************************************************************
883 %************************************************************************
885 Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
886 a do-expression. We have to find (>>) in the current environment, which is
887 done by the rename. Then we have to check that it has the same type as
888 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
891 (>>) :: HB m n mn => m a -> n b -> mn b
893 So the idea is to generate a local binding for (>>), thus:
895 let then72 :: forall a b. m a -> m b -> m b
896 then72 = ...something involving the user's (>>)...
898 ...the do-expression...
900 Now the do-expression can proceed using then72, which has exactly
903 In fact tcSyntaxName just generates the RHS for then72, because we only
904 want an actual binding in the do-expression case. For literals, we can
905 just use the expression inline.
908 tcSyntaxName :: InstOrigin
909 -> TcType -- Type to instantiate it at
910 -> (Name, HsExpr Name) -- (Standard name, user name)
911 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
912 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
913 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
914 -- So we do not call it from lookupInst, which is called from tcSimplify
916 tcSyntaxName orig ty (std_nm, HsVar user_nm)
918 = do id <- newMethodFromName orig ty std_nm
919 return (std_nm, HsVar id)
921 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
922 std_id <- tcLookupId std_nm
924 -- C.f. newMethodAtLoc
925 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
926 sigma1 = substTyWith [tv] [ty] tau
927 -- Actually, the "tau-type" might be a sigma-type in the
928 -- case of locally-polymorphic methods.
930 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
932 -- Check that the user-supplied thing has the
933 -- same type as the standard one.
934 -- Tiresome jiggling because tcCheckSigma takes a located expression
936 expr <- tcPolyExpr (L span user_nm_expr) sigma1
937 return (std_nm, unLoc expr)
939 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
940 -> TcRn (TidyEnv, SDoc)
941 syntaxNameCtxt name orig ty tidy_env = do
942 inst_loc <- getInstLoc orig
944 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
945 ptext (sLit "(needed by a syntactic construct)"),
946 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
947 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
949 return (tidy_env, msg)
952 %************************************************************************
956 %************************************************************************
958 Operations on EqInstCo.
961 mkGivenCo :: Coercion -> EqInstCo
964 mkWantedCo :: TcTyVar -> EqInstCo
967 isWantedCo :: EqInstCo -> Bool
968 isWantedCo (Left _) = True
971 fromGivenCo :: EqInstCo -> Coercion
972 fromGivenCo (Right co) = co
973 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
975 fromWantedCo :: String -> EqInstCo -> TcTyVar
976 fromWantedCo _ (Left covar) = covar
978 panic ("fromWantedCo: not a wanted coercion: " ++ msg)
980 eqInstCoType :: EqInstCo -> TcType
981 eqInstCoType (Left cotv) = mkTyVarTy cotv
982 eqInstCoType (Right co) = co
985 Coercion transformations on EqInstCo. These transformations work differently
986 depending on whether a EqInstCo is for a wanted or local equality:
988 Local : apply the inverse of the specified coercion
989 Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
990 to be the specified coercion applied to the new coercion hole
993 -- Coercion transformation: co = id
995 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
996 mkIdEqInstCo (Left cotv) t
997 = writeMetaTyVar cotv t
998 mkIdEqInstCo (Right _) _
1001 -- Coercion transformation: co = sym co'
1003 mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
1004 mkSymEqInstCo (Left cotv) (ty1, ty2)
1005 = do { cotv' <- newMetaCoVar ty1 ty2
1006 ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
1007 ; return $ Left cotv'
1009 mkSymEqInstCo (Right co) _
1010 = return $ Right (mkSymCoercion co)
1012 -- Coercion transformation: co = co' |> given_co
1014 mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1015 mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
1016 = do { cotv' <- newMetaCoVar ty1 ty2
1017 ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
1018 ; return $ Left cotv'
1020 mkLeftTransEqInstCo (Right co) given_co _
1021 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1023 -- Coercion transformation: co = given_co |> co'
1025 mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1026 mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
1027 = do { cotv' <- newMetaCoVar ty1 ty2
1028 ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
1029 ; return $ Left cotv'
1031 mkRightTransEqInstCo (Right co) given_co _
1032 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1034 -- Coercion transformation: co = col cor
1036 mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
1037 -> TcM (EqInstCo, EqInstCo)
1038 mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
1039 = do { cotv_l <- newMetaCoVar ty1_l ty2_l
1040 ; cotv_r <- newMetaCoVar ty1_r ty2_r
1041 ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
1042 ; return (Left cotv_l, Left cotv_r)
1044 mkAppEqInstCo (Right co) _ _
1045 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1048 Operations on entire EqInst.
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 mkEqInsts :: [PredType] -> [EqInstCo] -> TcM [Inst]
1062 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1064 mkEqInst :: PredType -> EqInstCo -> TcM Inst
1065 mkEqInst (EqPred ty1 ty2) co
1066 = do { uniq <- newUnique
1067 ; src_span <- getSrcSpanM
1068 ; err_ctxt <- getErrCtxt
1069 ; let loc = InstLoc EqOrigin src_span err_ctxt
1070 name = mkName uniq src_span
1071 inst = EqInst { tci_left = ty1
1080 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1081 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1083 mkWantedEqInst :: PredType -> TcM Inst
1084 mkWantedEqInst pred@(EqPred ty1 ty2)
1085 = do { cotv <- newMetaCoVar ty1 ty2
1086 ; mkEqInst pred (Left cotv)
1088 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
1090 -- Turn a wanted into a local EqInst (needed during type inference for
1093 -- * Give it a name and change the coercion around.
1095 finalizeEqInst :: Inst -- wanted
1096 -> TcM Inst -- given
1097 finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, tci_name = name})
1098 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1100 -- fill the coercion hole
1101 ; let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1102 ; writeMetaTyVar cotv (TyVarTy var)
1104 -- set the new coercion
1105 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1109 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1111 eqInstType :: Inst -> TcType
1112 eqInstType inst = eitherEqInst inst mkTyVarTy id
1114 eqInstCoercion :: Inst -> EqInstCo
1115 eqInstCoercion = tci_co
1117 eqInstTys :: Inst -> (TcType, TcType)
1118 eqInstTys inst = (tci_left inst, tci_right inst)
1120 updateEqInstCoercion :: (EqInstCo -> EqInstCo) -> Inst -> Inst
1121 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}