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 instCall, instStupidTheta,
20 newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
22 tcSyntaxName, isHsVar,
24 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
25 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
26 getDictClassTys, dictPred,
28 lookupSimpleInst, LookupInstResult(..),
29 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
31 isAbstractableInst, isEqInst,
32 isDict, isClassDict, isMethod, isImplicInst,
33 isIPDict, isInheritableInst, isMethodOrLit,
34 isTyVarDict, isMethodFor,
37 instToId, instToVar, instType, instName, instToDictBind,
40 InstOrigin(..), InstLoc, pprInstLoc,
42 mkWantedCo, mkGivenCo,
43 isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType,
44 mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo,
45 mkRightTransEqInstCo, mkAppEqInstCo,
46 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, finalizeEqInst,
47 eqInstType, updateEqInstCoercion,
48 eqInstCoercion, eqInstTys
51 #include "HsVersions.h"
53 import {-# SOURCE #-} TcExpr( tcPolyExpr )
54 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
77 import Var ( Var, TyVar )
100 instName :: Inst -> Name
101 instName (EqInst {tci_name = name}) = name
102 instName inst = Var.varName (instToVar inst)
104 instToId :: Inst -> TcId
105 instToId inst = WARN( not (isId id), ppr inst )
110 instToVar :: Inst -> Var
111 instToVar (LitInst {tci_name = nm, tci_ty = ty})
113 instToVar (Method {tci_id = id})
115 instToVar (Dict {tci_name = nm, tci_pred = pred})
116 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
117 | otherwise = mkLocalId nm (mkPredTy pred)
118 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
119 tci_wanted = wanteds})
120 = mkLocalId nm (mkImplicTy tvs givens wanteds)
121 instToVar i@(EqInst {})
122 = eitherEqInst i id (\(TyVarTy covar) -> covar)
124 instType :: Inst -> Type
125 instType (LitInst {tci_ty = ty}) = ty
126 instType (Method {tci_id = id}) = idType id
127 instType (Dict {tci_pred = pred}) = mkPredTy pred
128 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
130 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
131 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
133 mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
134 mkImplicTy tvs givens wanteds -- The type of an implication constraint
135 = ASSERT( all isAbstractableInst givens )
136 -- pprTrace "mkImplicTy" (ppr givens) $
137 -- See [Equational Constraints in Implication Constraints]
138 let dict_wanteds = filter (not . isEqInst) wanteds
141 mkPhiTy (map dictPred givens) $
142 mkBigCoreTupTy (map instType dict_wanteds)
144 dictPred :: Inst -> TcPredType
145 dictPred (Dict {tci_pred = pred}) = pred
146 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
147 dictPred inst = pprPanic "dictPred" (ppr inst)
149 getDictClassTys :: Inst -> (Class, [Type])
150 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
151 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
153 -- fdPredsOfInst is used to get predicates that contain functional
154 -- dependencies *or* might do so. The "might do" part is because
155 -- a constraint (C a b) might have a superclass with FDs
156 -- Leaving these in is really important for the call to fdPredsOfInsts
157 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
158 -- which is supposed to be conservative
159 fdPredsOfInst :: Inst -> [TcPredType]
160 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
161 fdPredsOfInst (Method {tci_theta = theta}) = theta
162 fdPredsOfInst (ImplicInst {tci_given = gs,
163 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
164 fdPredsOfInst (LitInst {}) = []
165 fdPredsOfInst (EqInst {}) = []
167 fdPredsOfInsts :: [Inst] -> [PredType]
168 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
170 isInheritableInst :: Inst -> Bool
171 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
172 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
173 isInheritableInst _ = True
176 ---------------------------------
177 -- Get the implicit parameters mentioned by these Insts
178 -- NB: the results of these functions are insensitive to zonking
180 ipNamesOfInsts :: [Inst] -> [Name]
181 ipNamesOfInst :: Inst -> [Name]
182 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
184 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
185 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
188 ---------------------------------
189 tyVarsOfInst :: Inst -> TcTyVarSet
190 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
191 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
192 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
193 -- The id might have free type variables; in the case of
194 -- locally-overloaded class methods, for example
195 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
196 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
197 `minusVarSet` mkVarSet tvs
198 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
199 -- Remember the free tyvars of a coercion
200 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
202 tyVarsOfInsts :: [Inst] -> VarSet
203 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
204 tyVarsOfLIE :: Bag Inst -> VarSet
205 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
208 --------------------------
209 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
210 instToDictBind inst rhs
211 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
213 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
214 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
221 isAbstractableInst :: Inst -> Bool
222 isAbstractableInst inst = isDict inst || isEqInst inst
224 isEqInst :: Inst -> Bool
225 isEqInst (EqInst {}) = True
228 isDict :: Inst -> Bool
229 isDict (Dict {}) = True
232 isClassDict :: Inst -> Bool
233 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
234 isClassDict _ = False
236 isTyVarDict :: Inst -> Bool
237 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
238 isTyVarDict _ = False
240 isIPDict :: Inst -> Bool
241 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
244 isImplicInst :: Inst -> Bool
245 isImplicInst (ImplicInst {}) = True
246 isImplicInst _ = False
248 isMethod :: Inst -> Bool
249 isMethod (Method {}) = True
252 isMethodFor :: TcIdSet -> Inst -> Bool
253 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
254 isMethodFor _ _ = False
256 isMethodOrLit :: Inst -> Bool
257 isMethodOrLit (Method {}) = True
258 isMethodOrLit (LitInst {}) = True
259 isMethodOrLit _ = False
263 %************************************************************************
265 \subsection{Building dictionaries}
267 %************************************************************************
269 -- newDictBndrs makes a dictionary at a binding site
270 -- instCall makes a dictionary at an occurrence site
271 -- and throws it into the LIE
275 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
276 newDictBndrsO orig theta = do { loc <- getInstLoc orig
277 ; newDictBndrs loc theta }
279 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
280 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
282 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
283 newDictBndr inst_loc pred@(EqPred ty1 ty2)
284 = do { uniq <- newUnique
285 ; let name = mkPredName uniq inst_loc pred
286 ; return (EqInst {tci_name = name,
290 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
292 newDictBndr inst_loc pred
293 = do { uniq <- newUnique
294 ; let name = mkPredName uniq inst_loc pred
295 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
298 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
299 -- Instantiate the constraints of a call
300 -- (instCall o tys theta)
301 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
302 -- (b) Throws these dictionaries into the LIE
303 -- (c) Returns an HsWrapper ([.] tys dicts)
305 instCall orig tys theta
306 = do { loc <- getInstLoc orig
307 ; dict_app <- instCallDicts loc theta
308 ; return (dict_app <.> mkWpTyApps tys) }
311 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
312 -- Similar to instCall, but only emit the constraints in the LIE
313 -- Used exclusively for the 'stupid theta' of a data constructor
314 instStupidTheta orig theta
315 = do { loc <- getInstLoc orig
316 ; _co <- instCallDicts loc theta -- Discard the coercion
320 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
321 -- Instantiates the TcTheta, puts all constraints thereby generated
322 -- into the LIE, and returns a HsWrapper to enclose the call site.
323 -- This is the key place where equality predicates
324 -- are unleashed into the world
325 instCallDicts _ [] = return idHsWrapper
327 -- instCallDicts loc (EqPred ty1 ty2 : preds)
328 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
329 -- -- Later on, when we do associated types,
330 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
331 -- ; (dicts, co_fn) <- instCallDicts loc preds
332 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
333 -- -- We use type application to apply the function to the
334 -- -- coercion; here ty1 *is* the appropriate identity coercion
336 instCallDicts loc (EqPred ty1 ty2 : preds)
337 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
338 ; coi <- boxyUnify ty1 ty2
339 -- ; coi <- unifyType ty1 ty2
340 ; let co = fromCoI coi ty1
341 ; co_fn <- instCallDicts loc preds
342 ; return (co_fn <.> WpTyApp co) }
344 instCallDicts loc (pred : preds)
345 = do { uniq <- newUnique
346 ; let name = mkPredName uniq loc pred
347 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
349 ; co_fn <- instCallDicts loc preds
350 ; return (co_fn <.> WpApp (instToId dict)) }
353 cloneDict :: Inst -> TcM Inst
354 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
355 ; return (dict {tci_name = setNameUnique nm uniq}) }
356 cloneDict eq@(EqInst {}) = return eq
357 cloneDict other = pprPanic "cloneDict" (ppr other)
359 -- For vanilla implicit parameters, there is only one in scope
360 -- at any time, so we used to use the name of the implicit parameter itself
361 -- But with splittable implicit parameters there may be many in
362 -- scope, so we make up a new namea.
363 newIPDict :: InstOrigin -> IPName Name -> Type
364 -> TcM (IPName Id, Inst)
365 newIPDict orig ip_name ty = do
366 inst_loc <- getInstLoc orig
369 pred = IParam ip_name ty
370 name = mkPredName uniq inst_loc pred
371 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
373 return (mapIPName (\_ -> instToId dict) ip_name, dict)
378 mkPredName :: Unique -> InstLoc -> PredType -> Name
379 mkPredName uniq loc pred_ty
380 = mkInternalName uniq occ (instLocSpan loc)
382 occ = case pred_ty of
383 ClassP cls _ -> mkDictOcc (getOccName cls)
384 IParam ip _ -> getOccName (ipNameName ip)
385 EqPred ty _ -> mkEqPredCoOcc baseOcc
387 -- we use the outermost tycon of the lhs, if there is one, to
388 -- improve readability of Core code
389 baseOcc = case splitTyConApp_maybe ty of
390 Nothing -> mkTcOcc "$"
391 Just (tc, _) -> getOccName tc
394 %************************************************************************
396 \subsection{Building methods (calls of overloaded functions)}
398 %************************************************************************
402 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
403 newMethodFromName origin ty name = do
404 id <- tcLookupId name
405 -- Use tcLookupId not tcLookupGlobalId; the method is almost
406 -- always a class op, but with -XNoImplicitPrelude GHC is
407 -- meant to find whatever thing is in scope, and that may
408 -- be an ordinary function.
409 loc <- getInstLoc origin
410 inst <- tcInstClassOp loc id [ty]
412 return (instToId inst)
414 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
415 newMethodWithGivenTy orig id tys = do
416 loc <- getInstLoc orig
417 inst <- newMethod loc id tys
419 return (instToId inst)
421 --------------------------------------------
422 -- tcInstClassOp, and newMethod do *not* drop the
423 -- Inst into the LIE; they just returns the Inst
424 -- This is important because they are used by TcSimplify
427 -- NB: the kind of the type variable to be instantiated
428 -- might be a sub-kind of the type to which it is applied,
429 -- notably when the latter is a type variable of kind ??
430 -- Hence the call to checkKind
431 -- A worry: is this needed anywhere else?
432 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
433 tcInstClassOp inst_loc sel_id tys = do
435 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
436 zipWithM_ checkKind tyvars tys
437 newMethod inst_loc sel_id tys
439 checkKind :: TyVar -> TcType -> TcM ()
440 -- Ensure that the type has a sub-kind of the tyvar
443 -- ty1 <- zonkTcType ty
444 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
448 pprPanic "checkKind: adding kind constraint"
449 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
450 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
452 -- do { tv1 <- tcInstTyVar tv
453 -- ; unifyType ty1 (mkTyVarTy tv1) } }
456 ---------------------------
457 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
458 newMethod inst_loc id tys = do
459 new_uniq <- newUnique
461 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
462 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
463 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
464 tci_theta = theta, tci_loc = inst_loc}
465 loc = instLocSpan inst_loc
471 mkOverLit :: OverLitVal -> TcM HsLit
472 mkOverLit (HsIntegral i)
473 = do { integer_ty <- tcMetaTy integerTyConName
474 ; return (HsInteger i integer_ty) }
476 mkOverLit (HsFractional r)
477 = do { rat_ty <- tcMetaTy rationalTyConName
478 ; return (HsRat r rat_ty) }
480 mkOverLit (HsIsString s) = return (HsString s)
482 isHsVar :: HsExpr Name -> Name -> Bool
483 isHsVar (HsVar f) g = f == g
488 %************************************************************************
492 %************************************************************************
494 Zonking makes sure that the instance types are fully zonked.
497 zonkInst :: Inst -> TcM Inst
498 zonkInst dict@(Dict { tci_pred = pred}) = do
499 new_pred <- zonkTcPredType pred
500 return (dict {tci_pred = new_pred})
502 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
504 -- Essential to zonk the id in case it's a local variable
505 -- Can't use zonkIdOcc because the id might itself be
506 -- an InstId, in which case it won't be in scope
508 new_tys <- zonkTcTypes tys
509 new_theta <- zonkTcThetaType theta
510 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
511 -- No need to zonk the tci_id
513 zonkInst lit@(LitInst {tci_ty = ty}) = do
514 new_ty <- zonkTcType ty
515 return (lit {tci_ty = new_ty})
517 zonkInst implic@(ImplicInst {})
518 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
519 do { givens' <- zonkInsts (tci_given implic)
520 ; wanteds' <- zonkInsts (tci_wanted implic)
521 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
523 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
524 = do { co' <- eitherEqInst eqinst
525 (\covar -> return (mkWantedCo covar))
526 (\co -> liftM mkGivenCo $ zonkTcType co)
527 ; ty1' <- zonkTcType ty1
528 ; ty2' <- zonkTcType ty2
529 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
532 zonkInsts :: [Inst] -> TcRn [Inst]
533 zonkInsts insts = mapM zonkInst insts
537 %************************************************************************
539 \subsection{Printing}
541 %************************************************************************
543 ToDo: improve these pretty-printing things. The ``origin'' is really only
544 relevant in error messages.
547 instance Outputable Inst where
548 ppr inst = pprInst inst
550 pprDictsTheta :: [Inst] -> SDoc
551 -- Print in type-like fashion (Eq a, Show b)
552 -- The Inst can be an implication constraint, but not a Method or LitInst
553 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
555 pprDictsInFull :: [Inst] -> SDoc
556 -- Print in type-like fashion, but with source location
558 = vcat (map go dicts)
560 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
562 pprInsts :: [Inst] -> SDoc
563 -- Debugging: print the evidence :: type
564 pprInsts insts = brackets (interpp'SP insts)
566 pprInst, pprInstInFull :: Inst -> SDoc
567 -- Debugging: print the evidence :: type
568 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
570 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
571 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
572 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
573 <+> braces (ppr (instType inst) <> implicWantedEqs)
577 | isImplicInst inst = text " &" <+>
578 ppr (filter isEqInst (tci_wanted inst))
581 pprInstInFull inst@(EqInst {}) = pprInst inst
582 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
584 tidyInst :: TidyEnv -> Inst -> Inst
585 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
586 eq { tci_left = tidyType env lty
587 , tci_right = tidyType env rty
588 , tci_co = either Left (Right . tidyType env) co
590 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
591 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
592 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
593 tidyInst env implic@(ImplicInst {})
594 = implic { tci_tyvars = tvs'
595 , tci_given = map (tidyInst env') (tci_given implic)
596 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
598 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
600 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
601 -- This function doesn't assume that the tyvars are in scope
602 -- so it works like tidyOpenType, returning a TidyEnv
603 tidyMoreInsts env insts
604 = (env', map (tidyInst env') insts)
606 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
608 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
609 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
611 showLIE :: SDoc -> TcM () -- Debugging
613 = do { lie_var <- getLIEVar ;
614 lie <- readMutVar lie_var ;
615 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
619 %************************************************************************
621 Extending the instance environment
623 %************************************************************************
626 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
627 -- Add new locally-defined instances
628 tcExtendLocalInstEnv dfuns thing_inside
629 = do { traceDFuns dfuns
631 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
632 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
633 tcg_inst_env = inst_env' }
634 ; setGblEnv env' thing_inside }
636 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
637 -- Check that the proposed new instance is OK,
638 -- and then add it to the home inst env
639 addLocalInst home_ie ispec
640 = do { -- Instantiate the dfun type so that we extend the instance
641 -- envt with completely fresh template variables
642 -- This is important because the template variables must
643 -- not overlap with anything in the things being looked up
644 -- (since we do unification).
645 -- We use tcInstSkolType because we don't want to allocate fresh
646 -- *meta* type variables.
647 let dfun = instanceDFunId ispec
648 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
649 ; let (cls, tys') = tcSplitDFunHead tau'
650 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
651 ispec' = setInstanceDFunId ispec dfun'
653 -- Load imported instances, so that we report
654 -- duplicates correctly
656 ; let inst_envs = (eps_inst_env eps, home_ie)
658 -- Check functional dependencies
659 ; case checkFunDeps inst_envs ispec' of
660 Just specs -> funDepErr ispec' specs
663 -- Check for duplicate instance decls
664 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
665 ; dup_ispecs = [ dup_ispec
666 | (dup_ispec, _) <- matches
667 , let (_,_,_,dup_tys) = instanceHead dup_ispec
668 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
669 -- Find memebers of the match list which ispec itself matches.
670 -- If the match is 2-way, it's a duplicate
672 dup_ispec : _ -> dupInstErr ispec' dup_ispec
675 -- OK, now extend the envt
676 ; return (extendInstEnv home_ie ispec') }
678 getOverlapFlag :: TcM OverlapFlag
680 = do { dflags <- getDOpts
681 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
682 incoherent_ok = dopt Opt_IncoherentInstances dflags
683 overlap_flag | incoherent_ok = Incoherent
684 | overlap_ok = OverlapOk
685 | otherwise = NoOverlap
687 ; return overlap_flag }
689 traceDFuns :: [Instance] -> TcRn ()
691 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
693 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
694 -- Print the dfun name itself too
696 funDepErr :: Instance -> [Instance] -> TcRn ()
697 funDepErr ispec ispecs
699 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
700 2 (pprInstances (ispec:ispecs)))
701 dupInstErr :: Instance -> Instance -> TcRn ()
702 dupInstErr ispec dup_ispec
704 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
705 2 (pprInstances [ispec, dup_ispec]))
707 addDictLoc :: Instance -> TcRn a -> TcRn a
708 addDictLoc ispec thing_inside
709 = setSrcSpan (mkSrcSpan loc loc) thing_inside
711 loc = getSrcLoc ispec
715 %************************************************************************
717 \subsection{Looking up Insts}
719 %************************************************************************
722 data LookupInstResult
724 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
726 lookupSimpleInst :: Inst -> TcM LookupInstResult
727 -- This is "simple" in that it returns NoInstance for implication constraints
729 -- It's important that lookupInst does not put any new stuff into
730 -- the LIE. Instead, any Insts needed by the lookup are returned in
731 -- the LookupInstResult, where they can be further processed by tcSimplify
733 lookupSimpleInst (EqInst {}) = return NoInstance
735 --------------------- Implications ------------------------
736 lookupSimpleInst (ImplicInst {}) = return NoInstance
738 --------------------- Methods ------------------------
739 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
740 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
741 ; let co_fn = dict_app <.> mkWpTyApps tys
742 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
744 span = instLocSpan loc
746 --------------------- Literals ------------------------
747 -- Look for short cuts first: if the literal is *definitely* a
748 -- int, integer, float or a double, generate the real thing here.
749 -- This is essential (see nofib/spectral/nucleic).
750 -- [Same shortcut as in newOverloadedLit, but we
751 -- may have done some unification by now]
753 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
754 , ol_rebindable = rebindable }
755 , tci_ty = ty, tci_loc = iloc})
756 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
757 | Just witness <- shortCutLit lit_val ty
758 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
759 ; return (GenInst [] (L loc (HsOverLit lit'))) }
762 = do { hs_lit <- mkOverLit lit_val
763 ; from_thing <- tcLookupId (hsOverLitName lit_val)
764 -- Not rebindable, so hsOverLitName is the right thing
765 ; method_inst <- tcInstClassOp iloc from_thing [ty]
766 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
767 (L loc (HsLit hs_lit))
768 lit' = lit { ol_witness = witness, ol_type = ty }
769 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
771 loc = instLocSpan iloc
773 --------------------- Dictionaries ------------------------
774 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
775 = do { mb_result <- lookupPred pred
776 ; case mb_result of {
777 Nothing -> return NoInstance ;
778 Just (dfun_id, mb_inst_tys) -> do
780 { use_stage <- getStage
781 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
782 (topIdLvl dfun_id) use_stage
784 -- It's possible that not all the tyvars are in
785 -- the substitution, tenv. For example:
786 -- instance C X a => D X where ...
787 -- (presumably there's a functional dependency in class C)
788 -- Hence mb_inst_tys :: Either TyVar TcType
790 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
791 inst_tv (Right ty) = return ty
792 ; tys <- mapM inst_tv mb_inst_tys
794 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
795 src_loc = instLocSpan loc
798 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
800 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
801 ; let co_fn = dict_app <.> mkWpTyApps tys
802 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
806 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
807 -- Look up a class constraint in the instance environment
808 lookupPred pred@(ClassP clas tys)
810 ; tcg_env <- getGblEnv
811 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
812 ; case lookupInstEnv inst_envs clas tys of {
813 ([(ispec, inst_tys)], [])
814 -> do { let dfun_id = is_dfun ispec
815 ; traceTc (text "lookupInst success" <+>
816 vcat [text "dict" <+> ppr pred,
817 text "witness" <+> ppr dfun_id
818 <+> ppr (idType dfun_id) ])
819 -- Record that this dfun is needed
820 ; record_dfun_usage dfun_id
821 ; return (Just (dfun_id, inst_tys)) } ;
824 -> do { traceTc (text "lookupInst fail" <+>
825 vcat [text "dict" <+> ppr pred,
826 text "matches" <+> ppr matches,
827 text "unifs" <+> ppr unifs])
828 -- In the case of overlap (multiple matches) we report
829 -- NoInstance here. That has the effect of making the
830 -- context-simplifier return the dict as an irreducible one.
831 -- Then it'll be given to addNoInstanceErrs, which will do another
832 -- lookupInstEnv to get the detailed info about what went wrong.
836 lookupPred (IParam {}) = return Nothing -- Implicit parameters
837 lookupPred (EqPred {}) = panic "lookupPred EqPred"
839 record_dfun_usage :: Id -> TcRn ()
840 record_dfun_usage dfun_id
841 = do { hsc_env <- getTopEnv
842 ; let dfun_name = idName dfun_id
843 dfun_mod = nameModule dfun_name
844 ; if isInternalName dfun_name || -- Internal name => defined in this module
845 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
846 then return () -- internal, or in another package
847 else do { tcg_env <- getGblEnv
848 ; updMutVar (tcg_inst_uses tcg_env)
849 (`addOneToNameSet` idName dfun_id) }}
852 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
853 -- Gets both the external-package inst-env
854 -- and the home-pkg inst env (includes module being compiled)
855 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
856 return (eps_inst_env eps, tcg_inst_env env) }
861 %************************************************************************
865 %************************************************************************
867 Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
868 a do-expression. We have to find (>>) in the current environment, which is
869 done by the rename. Then we have to check that it has the same type as
870 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
873 (>>) :: HB m n mn => m a -> n b -> mn b
875 So the idea is to generate a local binding for (>>), thus:
877 let then72 :: forall a b. m a -> m b -> m b
878 then72 = ...something involving the user's (>>)...
880 ...the do-expression...
882 Now the do-expression can proceed using then72, which has exactly
885 In fact tcSyntaxName just generates the RHS for then72, because we only
886 want an actual binding in the do-expression case. For literals, we can
887 just use the expression inline.
890 tcSyntaxName :: InstOrigin
891 -> TcType -- Type to instantiate it at
892 -> (Name, HsExpr Name) -- (Standard name, user name)
893 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
894 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
895 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
896 -- So we do not call it from lookupInst, which is called from tcSimplify
898 tcSyntaxName orig ty (std_nm, HsVar user_nm)
900 = do id <- newMethodFromName orig ty std_nm
901 return (std_nm, HsVar id)
903 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
904 std_id <- tcLookupId std_nm
906 -- C.f. newMethodAtLoc
907 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
908 sigma1 = substTyWith [tv] [ty] tau
909 -- Actually, the "tau-type" might be a sigma-type in the
910 -- case of locally-polymorphic methods.
912 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
914 -- Check that the user-supplied thing has the
915 -- same type as the standard one.
916 -- Tiresome jiggling because tcCheckSigma takes a located expression
918 expr <- tcPolyExpr (L span user_nm_expr) sigma1
919 return (std_nm, unLoc expr)
921 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
922 -> TcRn (TidyEnv, SDoc)
923 syntaxNameCtxt name orig ty tidy_env = do
924 inst_loc <- getInstLoc orig
926 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
927 ptext (sLit "(needed by a syntactic construct)"),
928 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
929 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
931 return (tidy_env, msg)
934 %************************************************************************
938 %************************************************************************
940 Operations on EqInstCo.
943 mkGivenCo :: Coercion -> EqInstCo
946 mkWantedCo :: TcTyVar -> EqInstCo
949 isWantedCo :: EqInstCo -> Bool
950 isWantedCo (Left _) = True
953 fromGivenCo :: EqInstCo -> Coercion
954 fromGivenCo (Right co) = co
955 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
957 fromWantedCo :: String -> EqInstCo -> TcTyVar
958 fromWantedCo _ (Left covar) = covar
960 panic ("fromWantedCo: not a wanted coercion: " ++ msg)
962 eqInstCoType :: EqInstCo -> TcType
963 eqInstCoType (Left cotv) = mkTyVarTy cotv
964 eqInstCoType (Right co) = co
967 Coercion transformations on EqInstCo. These transformations work differently
968 depending on whether a EqInstCo is for a wanted or local equality:
970 Local : apply the inverse of the specified coercion
971 Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
972 to be the specified coercion applied to the new coercion hole
975 -- Coercion transformation: co = id
977 mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
978 mkIdEqInstCo (Left cotv) t
979 = writeMetaTyVar cotv t
980 mkIdEqInstCo (Right _) _
983 -- Coercion transformation: co = sym co'
985 mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
986 mkSymEqInstCo (Left cotv) (ty1, ty2)
987 = do { cotv' <- newMetaCoVar ty1 ty2
988 ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
989 ; return $ Left cotv'
991 mkSymEqInstCo (Right co) _
992 = return $ Right (mkSymCoercion co)
994 -- Coercion transformation: co = co' |> given_co
996 mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
997 mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
998 = do { cotv' <- newMetaCoVar ty1 ty2
999 ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
1000 ; return $ Left cotv'
1002 mkLeftTransEqInstCo (Right co) given_co _
1003 = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
1005 -- Coercion transformation: co = given_co |> co'
1007 mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
1008 mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
1009 = do { cotv' <- newMetaCoVar ty1 ty2
1010 ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
1011 ; return $ Left cotv'
1013 mkRightTransEqInstCo (Right co) given_co _
1014 = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
1016 -- Coercion transformation: co = col cor
1018 mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
1019 -> TcM (EqInstCo, EqInstCo)
1020 mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
1021 = do { cotv_l <- newMetaCoVar ty1_l ty2_l
1022 ; cotv_r <- newMetaCoVar ty1_r ty2_r
1023 ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
1024 ; return (Left cotv_l, Left cotv_r)
1026 mkAppEqInstCo (Right co) _ _
1027 = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
1030 Operations on entire EqInst.
1033 eitherEqInst :: Inst -- given or wanted EqInst
1034 -> (TcTyVar -> a) -- result if wanted
1035 -> (Coercion -> a) -- result if given
1037 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1039 Left covar -> withWanted covar
1040 Right co -> withGiven co
1041 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
1043 mkEqInsts :: [PredType] -> [EqInstCo] -> TcM [Inst]
1044 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1046 mkEqInst :: PredType -> EqInstCo -> TcM Inst
1047 mkEqInst (EqPred ty1 ty2) co
1048 = do { uniq <- newUnique
1049 ; src_span <- getSrcSpanM
1050 ; err_ctxt <- getErrCtxt
1051 ; let loc = InstLoc EqOrigin src_span err_ctxt
1052 name = mkName uniq src_span
1053 inst = EqInst { tci_left = ty1
1062 mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1063 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
1065 mkWantedEqInst :: PredType -> TcM Inst
1066 mkWantedEqInst pred@(EqPred ty1 ty2)
1067 = do { cotv <- newMetaCoVar ty1 ty2
1068 ; mkEqInst pred (Left cotv)
1070 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
1072 -- Turn a wanted into a local EqInst (needed during type inference for
1075 -- * Give it a name and change the coercion around.
1077 finalizeEqInst :: Inst -- wanted
1078 -> TcM Inst -- given
1079 finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, tci_name = name})
1080 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1082 -- fill the coercion hole
1083 ; let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1084 ; writeMetaTyVar cotv (TyVarTy var)
1086 -- set the new coercion
1087 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1091 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1093 eqInstType :: Inst -> TcType
1094 eqInstType inst = eitherEqInst inst mkTyVarTy id
1096 eqInstCoercion :: Inst -> EqInstCo
1097 eqInstCoercion = tci_co
1099 eqInstTys :: Inst -> (TcType, TcType)
1100 eqInstTys inst = (tci_left inst, tci_right inst)
1102 updateEqInstCoercion :: (EqInstCo -> EqInstCo) -> Inst -> Inst
1103 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}