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 fromWantedCo, fromGivenCo,
44 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
45 finalizeEqInst, writeWantedCoercion,
46 eqInstType, updateEqInstCoercion,
47 eqInstCoercion, eqInstTys
50 #include "HsVersions.h"
52 import {-# SOURCE #-} TcExpr( tcPolyExpr )
53 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
77 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 if isSingleton dict_wanteds then
145 instType (head dict_wanteds)
147 mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
149 dictPred :: Inst -> TcPredType
150 dictPred (Dict {tci_pred = pred}) = pred
151 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
152 dictPred inst = pprPanic "dictPred" (ppr inst)
154 getDictClassTys :: Inst -> (Class, [Type])
155 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
156 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
158 -- fdPredsOfInst is used to get predicates that contain functional
159 -- dependencies *or* might do so. The "might do" part is because
160 -- a constraint (C a b) might have a superclass with FDs
161 -- Leaving these in is really important for the call to fdPredsOfInsts
162 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
163 -- which is supposed to be conservative
164 fdPredsOfInst :: Inst -> [TcPredType]
165 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
166 fdPredsOfInst (Method {tci_theta = theta}) = theta
167 fdPredsOfInst (ImplicInst {tci_given = gs,
168 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
169 fdPredsOfInst (LitInst {}) = []
170 fdPredsOfInst (EqInst {}) = []
172 fdPredsOfInsts :: [Inst] -> [PredType]
173 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
175 isInheritableInst :: Inst -> Bool
176 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
177 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
178 isInheritableInst _ = True
181 ---------------------------------
182 -- Get the implicit parameters mentioned by these Insts
183 -- NB: the results of these functions are insensitive to zonking
185 ipNamesOfInsts :: [Inst] -> [Name]
186 ipNamesOfInst :: Inst -> [Name]
187 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
189 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
190 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
193 ---------------------------------
194 tyVarsOfInst :: Inst -> TcTyVarSet
195 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
196 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
197 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
198 -- The id might have free type variables; in the case of
199 -- locally-overloaded class methods, for example
200 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
201 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
202 `minusVarSet` mkVarSet tvs
203 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
204 -- Remember the free tyvars of a coercion
205 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
207 tyVarsOfInsts :: [Inst] -> VarSet
208 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
209 tyVarsOfLIE :: Bag Inst -> VarSet
210 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
213 --------------------------
214 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
215 instToDictBind inst rhs
216 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
218 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
219 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
226 isAbstractableInst :: Inst -> Bool
227 isAbstractableInst inst = isDict inst || isEqInst inst
229 isEqInst :: Inst -> Bool
230 isEqInst (EqInst {}) = True
233 isDict :: Inst -> Bool
234 isDict (Dict {}) = True
237 isClassDict :: Inst -> Bool
238 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
239 isClassDict _ = False
241 isTyVarDict :: Inst -> Bool
242 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
243 isTyVarDict _ = False
245 isIPDict :: Inst -> Bool
246 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
249 isImplicInst :: Inst -> Bool
250 isImplicInst (ImplicInst {}) = True
251 isImplicInst _ = False
253 isMethod :: Inst -> Bool
254 isMethod (Method {}) = True
257 isMethodFor :: TcIdSet -> Inst -> Bool
258 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
259 isMethodFor _ _ = False
261 isMethodOrLit :: Inst -> Bool
262 isMethodOrLit (Method {}) = True
263 isMethodOrLit (LitInst {}) = True
264 isMethodOrLit _ = False
268 %************************************************************************
270 \subsection{Building dictionaries}
272 %************************************************************************
274 -- newDictBndrs makes a dictionary at a binding site
275 -- instCall makes a dictionary at an occurrence site
276 -- and throws it into the LIE
280 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
281 newDictBndrsO orig theta = do { loc <- getInstLoc orig
282 ; newDictBndrs loc theta }
284 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
285 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
287 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
288 newDictBndr inst_loc pred@(EqPred ty1 ty2)
289 = do { uniq <- newUnique
290 ; let name = mkPredName uniq inst_loc pred
291 ; return (EqInst {tci_name = name,
295 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
297 newDictBndr inst_loc pred
298 = do { uniq <- newUnique
299 ; let name = mkPredName uniq inst_loc pred
300 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
303 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
304 -- Instantiate the constraints of a call
305 -- (instCall o tys theta)
306 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
307 -- (b) Throws these dictionaries into the LIE
308 -- (c) Returns an HsWrapper ([.] tys dicts)
310 instCall orig tys theta
311 = do { loc <- getInstLoc orig
312 ; dict_app <- instCallDicts loc theta
313 ; return (dict_app <.> mkWpTyApps tys) }
316 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
317 -- Similar to instCall, but only emit the constraints in the LIE
318 -- Used exclusively for the 'stupid theta' of a data constructor
319 instStupidTheta orig theta
320 = do { loc <- getInstLoc orig
321 ; _co <- instCallDicts loc theta -- Discard the coercion
325 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
326 -- Instantiates the TcTheta, puts all constraints thereby generated
327 -- into the LIE, and returns a HsWrapper to enclose the call site.
328 -- This is the key place where equality predicates
329 -- are unleashed into the world
330 instCallDicts _ [] = return idHsWrapper
332 -- instCallDicts loc (EqPred ty1 ty2 : preds)
333 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
334 -- -- Later on, when we do associated types,
335 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
336 -- ; (dicts, co_fn) <- instCallDicts loc preds
337 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
338 -- -- We use type application to apply the function to the
339 -- -- coercion; here ty1 *is* the appropriate identity coercion
341 instCallDicts loc (EqPred ty1 ty2 : preds)
342 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
343 ; coi <- boxyUnify ty1 ty2
344 -- ; coi <- unifyType ty1 ty2
345 ; let co = fromCoI coi ty1
346 ; co_fn <- instCallDicts loc preds
347 ; return (co_fn <.> WpTyApp co) }
349 instCallDicts loc (pred : preds)
350 = do { uniq <- newUnique
351 ; let name = mkPredName uniq loc pred
352 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
354 ; co_fn <- instCallDicts loc preds
355 ; return (co_fn <.> WpApp (instToId dict)) }
358 cloneDict :: Inst -> TcM Inst
359 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
360 ; return (dict {tci_name = setNameUnique nm uniq}) }
361 cloneDict eq@(EqInst {}) = return eq
362 cloneDict other = pprPanic "cloneDict" (ppr other)
364 -- For vanilla implicit parameters, there is only one in scope
365 -- at any time, so we used to use the name of the implicit parameter itself
366 -- But with splittable implicit parameters there may be many in
367 -- scope, so we make up a new namea.
368 newIPDict :: InstOrigin -> IPName Name -> Type
369 -> TcM (IPName Id, Inst)
370 newIPDict orig ip_name ty = do
371 inst_loc <- getInstLoc orig
374 pred = IParam ip_name ty
375 name = mkPredName uniq inst_loc pred
376 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
378 return (mapIPName (\_ -> instToId dict) ip_name, dict)
383 mkPredName :: Unique -> InstLoc -> PredType -> Name
384 mkPredName uniq loc pred_ty
385 = mkInternalName uniq occ (instLocSpan loc)
387 occ = case pred_ty of
388 ClassP cls _ -> mkDictOcc (getOccName cls)
389 IParam ip _ -> getOccName (ipNameName ip)
390 EqPred ty _ -> mkEqPredCoOcc baseOcc
392 -- we use the outermost tycon of the lhs, if there is one, to
393 -- improve readability of Core code
394 baseOcc = case splitTyConApp_maybe ty of
395 Nothing -> mkOccName tcName "$"
396 Just (tc, _) -> getOccName tc
399 %************************************************************************
401 \subsection{Building methods (calls of overloaded functions)}
403 %************************************************************************
407 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
408 newMethodFromName origin ty name = do
409 id <- tcLookupId name
410 -- Use tcLookupId not tcLookupGlobalId; the method is almost
411 -- always a class op, but with -fno-implicit-prelude GHC is
412 -- meant to find whatever thing is in scope, and that may
413 -- be an ordinary function.
414 loc <- getInstLoc origin
415 inst <- tcInstClassOp loc id [ty]
417 return (instToId inst)
419 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
420 newMethodWithGivenTy orig id tys = do
421 loc <- getInstLoc orig
422 inst <- newMethod loc id tys
424 return (instToId inst)
426 --------------------------------------------
427 -- tcInstClassOp, and newMethod do *not* drop the
428 -- Inst into the LIE; they just returns the Inst
429 -- This is important because they are used by TcSimplify
432 -- NB: the kind of the type variable to be instantiated
433 -- might be a sub-kind of the type to which it is applied,
434 -- notably when the latter is a type variable of kind ??
435 -- Hence the call to checkKind
436 -- A worry: is this needed anywhere else?
437 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
438 tcInstClassOp inst_loc sel_id tys = do
440 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
441 zipWithM_ checkKind tyvars tys
442 newMethod inst_loc sel_id tys
444 checkKind :: TyVar -> TcType -> TcM ()
445 -- Ensure that the type has a sub-kind of the tyvar
448 -- ty1 <- zonkTcType ty
449 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
453 pprPanic "checkKind: adding kind constraint"
454 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
455 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
457 -- do { tv1 <- tcInstTyVar tv
458 -- ; unifyType ty1 (mkTyVarTy tv1) } }
461 ---------------------------
462 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
463 newMethod inst_loc id tys = do
464 new_uniq <- newUnique
466 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
467 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
468 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
469 tci_theta = theta, tci_loc = inst_loc}
470 loc = instLocSpan inst_loc
476 mkOverLit :: OverLitVal -> TcM HsLit
477 mkOverLit (HsIntegral i)
478 = do { integer_ty <- tcMetaTy integerTyConName
479 ; return (HsInteger i integer_ty) }
481 mkOverLit (HsFractional r)
482 = do { rat_ty <- tcMetaTy rationalTyConName
483 ; return (HsRat r rat_ty) }
485 mkOverLit (HsIsString s) = return (HsString s)
487 isHsVar :: HsExpr Name -> Name -> Bool
488 isHsVar (HsVar f) g = f == g
493 %************************************************************************
497 %************************************************************************
499 Zonking makes sure that the instance types are fully zonked.
502 zonkInst :: Inst -> TcM Inst
503 zonkInst dict@(Dict { tci_pred = pred}) = do
504 new_pred <- zonkTcPredType pred
505 return (dict {tci_pred = new_pred})
507 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
509 -- Essential to zonk the id in case it's a local variable
510 -- Can't use zonkIdOcc because the id might itself be
511 -- an InstId, in which case it won't be in scope
513 new_tys <- zonkTcTypes tys
514 new_theta <- zonkTcThetaType theta
515 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
516 -- No need to zonk the tci_id
518 zonkInst lit@(LitInst {tci_ty = ty}) = do
519 new_ty <- zonkTcType ty
520 return (lit {tci_ty = new_ty})
522 zonkInst implic@(ImplicInst {})
523 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
524 do { givens' <- zonkInsts (tci_given implic)
525 ; wanteds' <- zonkInsts (tci_wanted implic)
526 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
528 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
529 = do { co' <- eitherEqInst eqinst
530 (\covar -> return (mkWantedCo covar))
531 (\co -> liftM mkGivenCo $ zonkTcType co)
532 ; ty1' <- zonkTcType ty1
533 ; ty2' <- zonkTcType ty2
534 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
537 zonkInsts :: [Inst] -> TcRn [Inst]
538 zonkInsts insts = mapM zonkInst insts
542 %************************************************************************
544 \subsection{Printing}
546 %************************************************************************
548 ToDo: improve these pretty-printing things. The ``origin'' is really only
549 relevant in error messages.
552 instance Outputable Inst where
553 ppr inst = pprInst inst
555 pprDictsTheta :: [Inst] -> SDoc
556 -- Print in type-like fashion (Eq a, Show b)
557 -- The Inst can be an implication constraint, but not a Method or LitInst
558 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
560 pprDictsInFull :: [Inst] -> SDoc
561 -- Print in type-like fashion, but with source location
563 = vcat (map go dicts)
565 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
567 pprInsts :: [Inst] -> SDoc
568 -- Debugging: print the evidence :: type
569 pprInsts insts = brackets (interpp'SP insts)
571 pprInst, pprInstInFull :: Inst -> SDoc
572 -- Debugging: print the evidence :: type
573 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
575 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
576 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
577 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
578 <+> braces (ppr (instType inst) <> implicWantedEqs)
582 | isImplicInst inst = text " &" <+>
583 ppr (filter isEqInst (tci_wanted inst))
586 pprInstInFull inst@(EqInst {}) = pprInst inst
587 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
589 tidyInst :: TidyEnv -> Inst -> Inst
590 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
591 eq { tci_left = tidyType env lty
592 , tci_right = tidyType env rty
593 , tci_co = either Left (Right . tidyType env) co
595 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
596 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
597 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
598 tidyInst env implic@(ImplicInst {})
599 = implic { tci_tyvars = tvs'
600 , tci_given = map (tidyInst env') (tci_given implic)
601 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
603 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
605 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
606 -- This function doesn't assume that the tyvars are in scope
607 -- so it works like tidyOpenType, returning a TidyEnv
608 tidyMoreInsts env insts
609 = (env', map (tidyInst env') insts)
611 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
613 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
614 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
616 showLIE :: SDoc -> TcM () -- Debugging
618 = do { lie_var <- getLIEVar ;
619 lie <- readMutVar lie_var ;
620 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
624 %************************************************************************
626 Extending the instance environment
628 %************************************************************************
631 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
632 -- Add new locally-defined instances
633 tcExtendLocalInstEnv dfuns thing_inside
634 = do { traceDFuns dfuns
636 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
637 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
638 tcg_inst_env = inst_env' }
639 ; setGblEnv env' thing_inside }
641 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
642 -- Check that the proposed new instance is OK,
643 -- and then add it to the home inst env
644 addLocalInst home_ie ispec
645 = do { -- Instantiate the dfun type so that we extend the instance
646 -- envt with completely fresh template variables
647 -- This is important because the template variables must
648 -- not overlap with anything in the things being looked up
649 -- (since we do unification).
650 -- We use tcInstSkolType because we don't want to allocate fresh
651 -- *meta* type variables.
652 let dfun = instanceDFunId ispec
653 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
654 ; let (cls, tys') = tcSplitDFunHead tau'
655 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
656 ispec' = setInstanceDFunId ispec dfun'
658 -- Load imported instances, so that we report
659 -- duplicates correctly
661 ; let inst_envs = (eps_inst_env eps, home_ie)
663 -- Check functional dependencies
664 ; case checkFunDeps inst_envs ispec' of
665 Just specs -> funDepErr ispec' specs
668 -- Check for duplicate instance decls
669 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
670 ; dup_ispecs = [ dup_ispec
671 | (dup_ispec, _) <- matches
672 , let (_,_,_,dup_tys) = instanceHead dup_ispec
673 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
674 -- Find memebers of the match list which ispec itself matches.
675 -- If the match is 2-way, it's a duplicate
677 dup_ispec : _ -> dupInstErr ispec' dup_ispec
680 -- OK, now extend the envt
681 ; return (extendInstEnv home_ie ispec') }
683 getOverlapFlag :: TcM OverlapFlag
685 = do { dflags <- getDOpts
686 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
687 incoherent_ok = dopt Opt_IncoherentInstances dflags
688 overlap_flag | incoherent_ok = Incoherent
689 | overlap_ok = OverlapOk
690 | otherwise = NoOverlap
692 ; return overlap_flag }
694 traceDFuns :: [Instance] -> TcRn ()
696 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
698 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
699 -- Print the dfun name itself too
701 funDepErr :: Instance -> [Instance] -> TcRn ()
702 funDepErr ispec ispecs
704 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
705 2 (pprInstances (ispec:ispecs)))
706 dupInstErr :: Instance -> Instance -> TcRn ()
707 dupInstErr ispec dup_ispec
709 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
710 2 (pprInstances [ispec, dup_ispec]))
712 addDictLoc :: Instance -> TcRn a -> TcRn a
713 addDictLoc ispec thing_inside
714 = setSrcSpan (mkSrcSpan loc loc) thing_inside
716 loc = getSrcLoc ispec
720 %************************************************************************
722 \subsection{Looking up Insts}
724 %************************************************************************
727 data LookupInstResult
729 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
731 lookupSimpleInst :: Inst -> TcM LookupInstResult
732 -- This is "simple" in that it returns NoInstance for implication constraints
734 -- It's important that lookupInst does not put any new stuff into
735 -- the LIE. Instead, any Insts needed by the lookup are returned in
736 -- the LookupInstResult, where they can be further processed by tcSimplify
738 lookupSimpleInst (EqInst {}) = return NoInstance
740 --------------------- Implications ------------------------
741 lookupSimpleInst (ImplicInst {}) = return NoInstance
743 --------------------- Methods ------------------------
744 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
745 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
746 ; let co_fn = dict_app <.> mkWpTyApps tys
747 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
749 span = instLocSpan loc
751 --------------------- Literals ------------------------
752 -- Look for short cuts first: if the literal is *definitely* a
753 -- int, integer, float or a double, generate the real thing here.
754 -- This is essential (see nofib/spectral/nucleic).
755 -- [Same shortcut as in newOverloadedLit, but we
756 -- may have done some unification by now]
758 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
759 , ol_rebindable = rebindable }
760 , tci_ty = ty, tci_loc = iloc})
761 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
762 | Just witness <- shortCutLit lit_val ty
763 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
764 ; return (GenInst [] (L loc (HsOverLit lit'))) }
767 = do { hs_lit <- mkOverLit lit_val
768 ; from_thing <- tcLookupId (hsOverLitName lit_val)
769 -- Not rebindable, so hsOverLitName is the right thing
770 ; method_inst <- tcInstClassOp iloc from_thing [ty]
771 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
772 (L loc (HsLit hs_lit))
773 lit' = lit { ol_witness = witness, ol_type = ty }
774 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
776 loc = instLocSpan iloc
778 --------------------- Dictionaries ------------------------
779 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
780 = do { mb_result <- lookupPred pred
781 ; case mb_result of {
782 Nothing -> return NoInstance ;
783 Just (dfun_id, mb_inst_tys) -> do
785 { use_stage <- getStage
786 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
787 (topIdLvl dfun_id) use_stage
789 -- It's possible that not all the tyvars are in
790 -- the substitution, tenv. For example:
791 -- instance C X a => D X where ...
792 -- (presumably there's a functional dependency in class C)
793 -- Hence mb_inst_tys :: Either TyVar TcType
795 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
796 inst_tv (Right ty) = return ty
797 ; tys <- mapM inst_tv mb_inst_tys
799 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
800 src_loc = instLocSpan loc
803 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
805 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
806 ; let co_fn = dict_app <.> mkWpTyApps tys
807 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
811 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
812 -- Look up a class constraint in the instance environment
813 lookupPred pred@(ClassP clas tys)
815 ; tcg_env <- getGblEnv
816 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
817 ; case lookupInstEnv inst_envs clas tys of {
818 ([(ispec, inst_tys)], [])
819 -> do { let dfun_id = is_dfun ispec
820 ; traceTc (text "lookupInst success" <+>
821 vcat [text "dict" <+> ppr pred,
822 text "witness" <+> ppr dfun_id
823 <+> ppr (idType dfun_id) ])
824 -- Record that this dfun is needed
825 ; record_dfun_usage dfun_id
826 ; return (Just (dfun_id, inst_tys)) } ;
829 -> do { traceTc (text "lookupInst fail" <+>
830 vcat [text "dict" <+> ppr pred,
831 text "matches" <+> ppr matches,
832 text "unifs" <+> ppr unifs])
833 -- In the case of overlap (multiple matches) we report
834 -- NoInstance here. That has the effect of making the
835 -- context-simplifier return the dict as an irreducible one.
836 -- Then it'll be given to addNoInstanceErrs, which will do another
837 -- lookupInstEnv to get the detailed info about what went wrong.
841 lookupPred (IParam {}) = return Nothing -- Implicit parameters
842 lookupPred (EqPred {}) = panic "lookupPred EqPred"
844 record_dfun_usage :: Id -> TcRn ()
845 record_dfun_usage dfun_id
846 = do { hsc_env <- getTopEnv
847 ; let dfun_name = idName dfun_id
848 dfun_mod = nameModule dfun_name
849 ; if isInternalName dfun_name || -- Internal name => defined in this module
850 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
851 then return () -- internal, or in another package
852 else do { tcg_env <- getGblEnv
853 ; updMutVar (tcg_inst_uses tcg_env)
854 (`addOneToNameSet` idName dfun_id) }}
857 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
858 -- Gets both the external-package inst-env
859 -- and the home-pkg inst env (includes module being compiled)
860 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
861 return (eps_inst_env eps, tcg_inst_env env) }
866 %************************************************************************
870 %************************************************************************
872 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
873 a do-expression. We have to find (>>) in the current environment, which is
874 done by the rename. Then we have to check that it has the same type as
875 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
878 (>>) :: HB m n mn => m a -> n b -> mn b
880 So the idea is to generate a local binding for (>>), thus:
882 let then72 :: forall a b. m a -> m b -> m b
883 then72 = ...something involving the user's (>>)...
885 ...the do-expression...
887 Now the do-expression can proceed using then72, which has exactly
890 In fact tcSyntaxName just generates the RHS for then72, because we only
891 want an actual binding in the do-expression case. For literals, we can
892 just use the expression inline.
895 tcSyntaxName :: InstOrigin
896 -> TcType -- Type to instantiate it at
897 -> (Name, HsExpr Name) -- (Standard name, user name)
898 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
899 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
900 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
901 -- So we do not call it from lookupInst, which is called from tcSimplify
903 tcSyntaxName orig ty (std_nm, HsVar user_nm)
905 = do id <- newMethodFromName orig ty std_nm
906 return (std_nm, HsVar id)
908 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
909 std_id <- tcLookupId std_nm
911 -- C.f. newMethodAtLoc
912 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
913 sigma1 = substTyWith [tv] [ty] tau
914 -- Actually, the "tau-type" might be a sigma-type in the
915 -- case of locally-polymorphic methods.
917 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
919 -- Check that the user-supplied thing has the
920 -- same type as the standard one.
921 -- Tiresome jiggling because tcCheckSigma takes a located expression
923 expr <- tcPolyExpr (L span user_nm_expr) sigma1
924 return (std_nm, unLoc expr)
926 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
927 -> TcRn (TidyEnv, SDoc)
928 syntaxNameCtxt name orig ty tidy_env = do
929 inst_loc <- getInstLoc orig
931 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
932 ptext (sLit "(needed by a syntactic construct)"),
933 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
934 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
936 return (tidy_env, msg)
939 %************************************************************************
943 %************************************************************************
946 mkGivenCo :: Coercion -> Either TcTyVar Coercion
949 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
952 fromGivenCo :: Either TcTyVar Coercion -> Coercion
953 fromGivenCo (Right co) = co
954 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
956 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
957 fromWantedCo _ (Left covar) = covar
958 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
960 eitherEqInst :: Inst -- given or wanted EqInst
961 -> (TcTyVar -> a) -- result if wanted
962 -> (Coercion -> a) -- result if given
964 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
966 Left covar -> withWanted covar
967 Right co -> withGiven co
968 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
970 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
971 mkEqInsts preds cos = zipWithM mkEqInst preds cos
973 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
974 mkEqInst (EqPred ty1 ty2) co
975 = do { uniq <- newUnique
976 ; src_span <- getSrcSpanM
977 ; err_ctxt <- getErrCtxt
978 ; let loc = InstLoc EqOrigin src_span err_ctxt
979 name = mkName uniq src_span
980 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
983 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
984 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
986 mkWantedEqInst :: PredType -> TcM Inst
987 mkWantedEqInst pred@(EqPred ty1 ty2)
988 = do { cotv <- newMetaCoVar ty1 ty2
989 ; mkEqInst pred (Left cotv)
991 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
994 -- We want to promote the wanted EqInst to a given EqInst
995 -- in the signature context.
996 -- This means we have to give the coercion a name
997 -- and fill it in as its own name.
1000 -> TcM Inst -- given
1001 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1002 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1003 ; writeWantedCoercion wanted (TyVarTy var)
1004 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1007 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1010 :: Inst -- wanted EqInst
1011 -> Coercion -- coercion to fill the hole with
1013 writeWantedCoercion wanted co
1014 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1015 ; writeMetaTyVar cotv co
1018 eqInstType :: Inst -> TcType
1019 eqInstType inst = eitherEqInst inst mkTyVarTy id
1021 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1022 eqInstCoercion = tci_co
1024 eqInstTys :: Inst -> (TcType, TcType)
1025 eqInstTys inst = (tci_left inst, tci_right inst)
1027 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1028 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}