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 -} )
75 import Var ( Var, TyVar )
98 instName :: Inst -> Name
99 instName (EqInst {tci_name = name}) = name
100 instName inst = Var.varName (instToVar inst)
102 instToId :: Inst -> TcId
103 instToId inst = WARN( not (isId id), ppr inst )
108 instToVar :: Inst -> Var
109 instToVar (LitInst {tci_name = nm, tci_ty = ty})
111 instToVar (Method {tci_id = id})
113 instToVar (Dict {tci_name = nm, tci_pred = pred})
114 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
115 | otherwise = mkLocalId nm (mkPredTy pred)
116 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
117 tci_wanted = wanteds})
118 = mkLocalId nm (mkImplicTy tvs givens wanteds)
119 instToVar i@(EqInst {})
120 = eitherEqInst i id (\(TyVarTy covar) -> covar)
122 instType :: Inst -> Type
123 instType (LitInst {tci_ty = ty}) = ty
124 instType (Method {tci_id = id}) = idType id
125 instType (Dict {tci_pred = pred}) = mkPredTy pred
126 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
128 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
129 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
131 mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
132 mkImplicTy tvs givens wanteds -- The type of an implication constraint
133 = ASSERT( all isAbstractableInst givens )
134 -- pprTrace "mkImplicTy" (ppr givens) $
135 -- See [Equational Constraints in Implication Constraints]
136 let dict_wanteds = filter (not . isEqInst) wanteds
139 mkPhiTy (map dictPred givens) $
140 if isSingleton dict_wanteds then
141 instType (head dict_wanteds)
143 mkTupleTy Boxed (length dict_wanteds) (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
284 newDictBndr inst_loc pred@(EqPred ty1 ty2)
285 = do { uniq <- newUnique
286 ; let name = mkPredName uniq inst_loc pred
287 ; return (EqInst {tci_name = name,
291 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
293 newDictBndr inst_loc pred
294 = do { uniq <- newUnique
295 ; let name = mkPredName uniq inst_loc pred
296 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
299 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
300 -- Instantiate the constraints of a call
301 -- (instCall o tys theta)
302 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
303 -- (b) Throws these dictionaries into the LIE
304 -- (c) Returns an HsWrapper ([.] tys dicts)
306 instCall orig tys theta
307 = do { loc <- getInstLoc orig
308 ; dict_app <- instCallDicts loc theta
309 ; return (dict_app <.> mkWpTyApps tys) }
312 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
313 -- Similar to instCall, but only emit the constraints in the LIE
314 -- Used exclusively for the 'stupid theta' of a data constructor
315 instStupidTheta orig theta
316 = do { loc <- getInstLoc orig
317 ; _co <- instCallDicts loc theta -- Discard the coercion
321 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
322 -- Instantiates the TcTheta, puts all constraints thereby generated
323 -- into the LIE, and returns a HsWrapper to enclose the call site.
324 -- This is the key place where equality predicates
325 -- are unleashed into the world
326 instCallDicts _ [] = return idHsWrapper
328 -- instCallDicts loc (EqPred ty1 ty2 : preds)
329 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
330 -- -- Later on, when we do associated types,
331 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
332 -- ; (dicts, co_fn) <- instCallDicts loc preds
333 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
334 -- -- We use type application to apply the function to the
335 -- -- coercion; here ty1 *is* the appropriate identity coercion
337 instCallDicts loc (EqPred ty1 ty2 : preds)
338 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
339 ; coi <- boxyUnify ty1 ty2
340 -- ; coi <- unifyType ty1 ty2
341 ; let co = fromCoI coi ty1
342 ; co_fn <- instCallDicts loc preds
343 ; return (co_fn <.> WpTyApp co) }
345 instCallDicts loc (pred : preds)
346 = do { uniq <- newUnique
347 ; let name = mkPredName uniq loc pred
348 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
350 ; co_fn <- instCallDicts loc preds
351 ; return (co_fn <.> WpApp (instToId dict)) }
354 cloneDict :: Inst -> TcM Inst
355 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
356 ; return (dict {tci_name = setNameUnique nm uniq}) }
357 cloneDict eq@(EqInst {}) = return eq
358 cloneDict other = pprPanic "cloneDict" (ppr other)
360 -- For vanilla implicit parameters, there is only one in scope
361 -- at any time, so we used to use the name of the implicit parameter itself
362 -- But with splittable implicit parameters there may be many in
363 -- scope, so we make up a new namea.
364 newIPDict :: InstOrigin -> IPName Name -> Type
365 -> TcM (IPName Id, Inst)
366 newIPDict orig ip_name ty = do
367 inst_loc <- getInstLoc orig
370 pred = IParam ip_name ty
371 name = mkPredName uniq inst_loc pred
372 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
374 return (mapIPName (\_ -> instToId dict) ip_name, dict)
379 mkPredName :: Unique -> InstLoc -> PredType -> Name
380 mkPredName uniq loc pred_ty
381 = mkInternalName uniq occ (instLocSpan loc)
383 occ = case pred_ty of
384 ClassP cls _ -> mkDictOcc (getOccName cls)
385 IParam ip _ -> getOccName (ipNameName ip)
386 EqPred ty _ -> mkEqPredCoOcc baseOcc
388 -- we use the outermost tycon of the lhs, if there is one, to
389 -- improve readability of Core code
390 baseOcc = case splitTyConApp_maybe ty of
391 Nothing -> mkOccName tcName "$"
392 Just (tc, _) -> getOccName tc
395 %************************************************************************
397 \subsection{Building methods (calls of overloaded functions)}
399 %************************************************************************
403 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
404 newMethodFromName origin ty name = do
405 id <- tcLookupId name
406 -- Use tcLookupId not tcLookupGlobalId; the method is almost
407 -- always a class op, but with -fno-implicit-prelude GHC is
408 -- meant to find whatever thing is in scope, and that may
409 -- be an ordinary function.
410 loc <- getInstLoc origin
411 inst <- tcInstClassOp loc id [ty]
413 return (instToId inst)
415 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
416 newMethodWithGivenTy orig id tys = do
417 loc <- getInstLoc orig
418 inst <- newMethod loc id tys
420 return (instToId inst)
422 --------------------------------------------
423 -- tcInstClassOp, and newMethod do *not* drop the
424 -- Inst into the LIE; they just returns the Inst
425 -- This is important because they are used by TcSimplify
428 -- NB: the kind of the type variable to be instantiated
429 -- might be a sub-kind of the type to which it is applied,
430 -- notably when the latter is a type variable of kind ??
431 -- Hence the call to checkKind
432 -- A worry: is this needed anywhere else?
433 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
434 tcInstClassOp inst_loc sel_id tys = do
436 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
437 zipWithM_ checkKind tyvars tys
438 newMethod inst_loc sel_id tys
440 checkKind :: TyVar -> TcType -> TcM ()
441 -- Ensure that the type has a sub-kind of the tyvar
444 -- ty1 <- zonkTcType ty
445 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
449 pprPanic "checkKind: adding kind constraint"
450 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
451 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
453 -- do { tv1 <- tcInstTyVar tv
454 -- ; unifyType ty1 (mkTyVarTy tv1) } }
457 ---------------------------
458 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
459 newMethod inst_loc id tys = do
460 new_uniq <- newUnique
462 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
463 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
464 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
465 tci_theta = theta, tci_loc = inst_loc}
466 loc = instLocSpan inst_loc
472 mkOverLit :: OverLitVal -> TcM HsLit
473 mkOverLit (HsIntegral i)
474 = do { integer_ty <- tcMetaTy integerTyConName
475 ; return (HsInteger i integer_ty) }
477 mkOverLit (HsFractional r)
478 = do { rat_ty <- tcMetaTy rationalTyConName
479 ; return (HsRat r rat_ty) }
481 mkOverLit (HsIsString s) = return (HsString s)
483 isHsVar :: HsExpr Name -> Name -> Bool
484 isHsVar (HsVar f) g = f == g
489 %************************************************************************
493 %************************************************************************
495 Zonking makes sure that the instance types are fully zonked.
498 zonkInst :: Inst -> TcM Inst
499 zonkInst dict@(Dict { tci_pred = pred}) = do
500 new_pred <- zonkTcPredType pred
501 return (dict {tci_pred = new_pred})
503 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
505 -- Essential to zonk the id in case it's a local variable
506 -- Can't use zonkIdOcc because the id might itself be
507 -- an InstId, in which case it won't be in scope
509 new_tys <- zonkTcTypes tys
510 new_theta <- zonkTcThetaType theta
511 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
512 -- No need to zonk the tci_id
514 zonkInst lit@(LitInst {tci_ty = ty}) = do
515 new_ty <- zonkTcType ty
516 return (lit {tci_ty = new_ty})
518 zonkInst implic@(ImplicInst {})
519 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
520 do { givens' <- zonkInsts (tci_given implic)
521 ; wanteds' <- zonkInsts (tci_wanted implic)
522 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
524 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
525 = do { co' <- eitherEqInst eqinst
526 (\covar -> return (mkWantedCo covar))
527 (\co -> liftM mkGivenCo $ zonkTcType co)
528 ; ty1' <- zonkTcType ty1
529 ; ty2' <- zonkTcType ty2
530 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
533 zonkInsts :: [Inst] -> TcRn [Inst]
534 zonkInsts insts = mapM zonkInst insts
538 %************************************************************************
540 \subsection{Printing}
542 %************************************************************************
544 ToDo: improve these pretty-printing things. The ``origin'' is really only
545 relevant in error messages.
548 instance Outputable Inst where
549 ppr inst = pprInst inst
551 pprDictsTheta :: [Inst] -> SDoc
552 -- Print in type-like fashion (Eq a, Show b)
553 -- The Inst can be an implication constraint, but not a Method or LitInst
554 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
556 pprDictsInFull :: [Inst] -> SDoc
557 -- Print in type-like fashion, but with source location
559 = vcat (map go dicts)
561 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
563 pprInsts :: [Inst] -> SDoc
564 -- Debugging: print the evidence :: type
565 pprInsts insts = brackets (interpp'SP insts)
567 pprInst, pprInstInFull :: Inst -> SDoc
568 -- Debugging: print the evidence :: type
569 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
571 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
572 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
573 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
574 <+> braces (ppr (instType inst) <> implicWantedEqs)
578 | isImplicInst inst = text " &" <+>
579 ppr (filter isEqInst (tci_wanted inst))
582 pprInstInFull inst@(EqInst {}) = pprInst inst
583 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
585 tidyInst :: TidyEnv -> Inst -> Inst
586 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
587 eq { tci_left = tidyType env lty
588 , tci_right = tidyType env rty
589 , tci_co = either Left (Right . tidyType env) co
591 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
592 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
593 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
594 tidyInst env implic@(ImplicInst {})
595 = implic { tci_tyvars = tvs'
596 , tci_given = map (tidyInst env') (tci_given implic)
597 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
599 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
601 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
602 -- This function doesn't assume that the tyvars are in scope
603 -- so it works like tidyOpenType, returning a TidyEnv
604 tidyMoreInsts env insts
605 = (env', map (tidyInst env') insts)
607 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
609 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
610 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
612 showLIE :: SDoc -> TcM () -- Debugging
614 = do { lie_var <- getLIEVar ;
615 lie <- readMutVar lie_var ;
616 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
620 %************************************************************************
622 Extending the instance environment
624 %************************************************************************
627 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
628 -- Add new locally-defined instances
629 tcExtendLocalInstEnv dfuns thing_inside
630 = do { traceDFuns dfuns
632 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
633 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
634 tcg_inst_env = inst_env' }
635 ; setGblEnv env' thing_inside }
637 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
638 -- Check that the proposed new instance is OK,
639 -- and then add it to the home inst env
640 addLocalInst home_ie ispec
641 = do { -- Instantiate the dfun type so that we extend the instance
642 -- envt with completely fresh template variables
643 -- This is important because the template variables must
644 -- not overlap with anything in the things being looked up
645 -- (since we do unification).
646 -- We use tcInstSkolType because we don't want to allocate fresh
647 -- *meta* type variables.
648 let dfun = instanceDFunId ispec
649 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
650 ; let (cls, tys') = tcSplitDFunHead tau'
651 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
652 ispec' = setInstanceDFunId ispec dfun'
654 -- Load imported instances, so that we report
655 -- duplicates correctly
657 ; let inst_envs = (eps_inst_env eps, home_ie)
659 -- Check functional dependencies
660 ; case checkFunDeps inst_envs ispec' of
661 Just specs -> funDepErr ispec' specs
664 -- Check for duplicate instance decls
665 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
666 ; dup_ispecs = [ dup_ispec
667 | (dup_ispec, _) <- matches
668 , let (_,_,_,dup_tys) = instanceHead dup_ispec
669 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
670 -- Find memebers of the match list which ispec itself matches.
671 -- If the match is 2-way, it's a duplicate
673 dup_ispec : _ -> dupInstErr ispec' dup_ispec
676 -- OK, now extend the envt
677 ; return (extendInstEnv home_ie ispec') }
679 getOverlapFlag :: TcM OverlapFlag
681 = do { dflags <- getDOpts
682 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
683 incoherent_ok = dopt Opt_IncoherentInstances dflags
684 overlap_flag | incoherent_ok = Incoherent
685 | overlap_ok = OverlapOk
686 | otherwise = NoOverlap
688 ; return overlap_flag }
690 traceDFuns :: [Instance] -> TcRn ()
692 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
694 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
695 -- Print the dfun name itself too
697 funDepErr :: Instance -> [Instance] -> TcRn ()
698 funDepErr ispec ispecs
700 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
701 2 (pprInstances (ispec:ispecs)))
702 dupInstErr :: Instance -> Instance -> TcRn ()
703 dupInstErr ispec dup_ispec
705 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
706 2 (pprInstances [ispec, dup_ispec]))
708 addDictLoc :: Instance -> TcRn a -> TcRn a
709 addDictLoc ispec thing_inside
710 = setSrcSpan (mkSrcSpan loc loc) thing_inside
712 loc = getSrcLoc ispec
716 %************************************************************************
718 \subsection{Looking up Insts}
720 %************************************************************************
723 data LookupInstResult
725 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
727 lookupSimpleInst :: Inst -> TcM LookupInstResult
728 -- This is "simple" in that it returns NoInstance for implication constraints
730 -- It's important that lookupInst does not put any new stuff into
731 -- the LIE. Instead, any Insts needed by the lookup are returned in
732 -- the LookupInstResult, where they can be further processed by tcSimplify
734 lookupSimpleInst (EqInst {}) = return NoInstance
736 --------------------- Implications ------------------------
737 lookupSimpleInst (ImplicInst {}) = return NoInstance
739 --------------------- Methods ------------------------
740 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
741 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
742 ; let co_fn = dict_app <.> mkWpTyApps tys
743 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
745 span = instLocSpan loc
747 --------------------- Literals ------------------------
748 -- Look for short cuts first: if the literal is *definitely* a
749 -- int, integer, float or a double, generate the real thing here.
750 -- This is essential (see nofib/spectral/nucleic).
751 -- [Same shortcut as in newOverloadedLit, but we
752 -- may have done some unification by now]
754 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
755 , ol_rebindable = rebindable }
756 , tci_ty = ty, tci_loc = iloc})
757 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
758 | Just witness <- shortCutLit lit_val ty
759 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
760 ; return (GenInst [] (L loc (HsOverLit lit'))) }
763 = do { hs_lit <- mkOverLit lit_val
764 ; from_thing <- tcLookupId (hsOverLitName lit_val)
765 -- Not rebindable, so hsOverLitName is the right thing
766 ; method_inst <- tcInstClassOp iloc from_thing [ty]
767 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
768 (L loc (HsLit hs_lit))
769 lit' = lit { ol_witness = witness, ol_type = ty }
770 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
772 loc = instLocSpan iloc
774 --------------------- Dictionaries ------------------------
775 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
776 = do { mb_result <- lookupPred pred
777 ; case mb_result of {
778 Nothing -> return NoInstance ;
779 Just (dfun_id, mb_inst_tys) -> do
781 { use_stage <- getStage
782 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
783 (topIdLvl dfun_id) use_stage
785 -- It's possible that not all the tyvars are in
786 -- the substitution, tenv. For example:
787 -- instance C X a => D X where ...
788 -- (presumably there's a functional dependency in class C)
789 -- Hence mb_inst_tys :: Either TyVar TcType
791 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
792 inst_tv (Right ty) = return ty
793 ; tys <- mapM inst_tv mb_inst_tys
795 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
796 src_loc = instLocSpan loc
799 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
801 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
802 ; let co_fn = dict_app <.> mkWpTyApps tys
803 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
807 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
808 -- Look up a class constraint in the instance environment
809 lookupPred pred@(ClassP clas tys)
811 ; tcg_env <- getGblEnv
812 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
813 ; case lookupInstEnv inst_envs clas tys of {
814 ([(ispec, inst_tys)], [])
815 -> do { let dfun_id = is_dfun ispec
816 ; traceTc (text "lookupInst success" <+>
817 vcat [text "dict" <+> ppr pred,
818 text "witness" <+> ppr dfun_id
819 <+> ppr (idType dfun_id) ])
820 -- Record that this dfun is needed
821 ; record_dfun_usage dfun_id
822 ; return (Just (dfun_id, inst_tys)) } ;
825 -> do { traceTc (text "lookupInst fail" <+>
826 vcat [text "dict" <+> ppr pred,
827 text "matches" <+> ppr matches,
828 text "unifs" <+> ppr unifs])
829 -- In the case of overlap (multiple matches) we report
830 -- NoInstance here. That has the effect of making the
831 -- context-simplifier return the dict as an irreducible one.
832 -- Then it'll be given to addNoInstanceErrs, which will do another
833 -- lookupInstEnv to get the detailed info about what went wrong.
837 lookupPred (IParam {}) = return Nothing -- Implicit parameters
838 lookupPred (EqPred {}) = panic "lookupPred EqPred"
840 record_dfun_usage :: Id -> TcRn ()
841 record_dfun_usage dfun_id
842 = do { hsc_env <- getTopEnv
843 ; let dfun_name = idName dfun_id
844 dfun_mod = nameModule dfun_name
845 ; if isInternalName dfun_name || -- Internal name => defined in this module
846 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
847 then return () -- internal, or in another package
848 else do { tcg_env <- getGblEnv
849 ; updMutVar (tcg_inst_uses tcg_env)
850 (`addOneToNameSet` idName dfun_id) }}
853 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
854 -- Gets both the external-package inst-env
855 -- and the home-pkg inst env (includes module being compiled)
856 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
857 return (eps_inst_env eps, tcg_inst_env env) }
862 %************************************************************************
866 %************************************************************************
868 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
869 a do-expression. We have to find (>>) in the current environment, which is
870 done by the rename. Then we have to check that it has the same type as
871 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
874 (>>) :: HB m n mn => m a -> n b -> mn b
876 So the idea is to generate a local binding for (>>), thus:
878 let then72 :: forall a b. m a -> m b -> m b
879 then72 = ...something involving the user's (>>)...
881 ...the do-expression...
883 Now the do-expression can proceed using then72, which has exactly
886 In fact tcSyntaxName just generates the RHS for then72, because we only
887 want an actual binding in the do-expression case. For literals, we can
888 just use the expression inline.
891 tcSyntaxName :: InstOrigin
892 -> TcType -- Type to instantiate it at
893 -> (Name, HsExpr Name) -- (Standard name, user name)
894 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
895 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
896 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
897 -- So we do not call it from lookupInst, which is called from tcSimplify
899 tcSyntaxName orig ty (std_nm, HsVar user_nm)
901 = do id <- newMethodFromName orig ty std_nm
902 return (std_nm, HsVar id)
904 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
905 std_id <- tcLookupId std_nm
907 -- C.f. newMethodAtLoc
908 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
909 sigma1 = substTyWith [tv] [ty] tau
910 -- Actually, the "tau-type" might be a sigma-type in the
911 -- case of locally-polymorphic methods.
913 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
915 -- Check that the user-supplied thing has the
916 -- same type as the standard one.
917 -- Tiresome jiggling because tcCheckSigma takes a located expression
919 expr <- tcPolyExpr (L span user_nm_expr) sigma1
920 return (std_nm, unLoc expr)
922 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
923 -> TcRn (TidyEnv, SDoc)
924 syntaxNameCtxt name orig ty tidy_env = do
925 inst_loc <- getInstLoc orig
927 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
928 ptext (sLit "(needed by a syntactic construct)"),
929 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
930 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
932 return (tidy_env, msg)
935 %************************************************************************
939 %************************************************************************
942 mkGivenCo :: Coercion -> Either TcTyVar Coercion
945 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
948 fromGivenCo :: Either TcTyVar Coercion -> Coercion
949 fromGivenCo (Right co) = co
950 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
952 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
953 fromWantedCo _ (Left covar) = covar
954 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
956 eitherEqInst :: Inst -- given or wanted EqInst
957 -> (TcTyVar -> a) -- result if wanted
958 -> (Coercion -> a) -- result if given
960 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
962 Left covar -> withWanted covar
963 Right co -> withGiven co
964 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
966 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
967 mkEqInsts preds cos = zipWithM mkEqInst preds cos
969 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
970 mkEqInst (EqPred ty1 ty2) co
971 = do { uniq <- newUnique
972 ; src_span <- getSrcSpanM
973 ; err_ctxt <- getErrCtxt
974 ; let loc = InstLoc EqOrigin src_span err_ctxt
975 name = mkName uniq src_span
976 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
979 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
980 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
982 mkWantedEqInst :: PredType -> TcM Inst
983 mkWantedEqInst pred@(EqPred ty1 ty2)
984 = do { cotv <- newMetaCoVar ty1 ty2
985 ; mkEqInst pred (Left cotv)
987 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
990 -- We want to promote the wanted EqInst to a given EqInst
991 -- in the signature context.
992 -- This means we have to give the coercion a name
993 -- and fill it in as its own name.
997 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
998 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
999 ; writeWantedCoercion wanted (TyVarTy var)
1000 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1003 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1006 :: Inst -- wanted EqInst
1007 -> Coercion -- coercion to fill the hole with
1009 writeWantedCoercion wanted co
1010 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1011 ; writeMetaTyVar cotv co
1014 eqInstType :: Inst -> TcType
1015 eqInstType inst = eitherEqInst inst mkTyVarTy id
1017 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1018 eqInstCoercion = tci_co
1020 eqInstTys :: Inst -> (TcType, TcType)
1021 eqInstTys inst = (tci_left inst, tci_right inst)
1023 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1024 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}