2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
8 LIE, emptyLIE, unitLIE, plusLIE, consLIE,
9 plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
13 pprInst, pprInsts, pprInstsInFull, pprDFuns,
14 tidyInsts, tidyMoreInsts,
16 newDictsFromOld, newDicts, cloneDict,
17 newOverloadedLit, newIPDict,
18 newMethod, newMethodFromName, newMethodWithGivenTy,
19 tcInstClassOp, tcInstCall, tcInstDataCon,
20 tcSyntaxName, tcStdSyntaxName,
22 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
23 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
24 instLoc, getDictClassTys, dictPred,
26 lookupInst, LookupInstResult(..),
27 tcExtendLocalInstEnv, tcGetInstEnvs,
29 isDict, isClassDict, isMethod,
30 isLinearInst, linearInstType, isIPDict, isInheritableInst,
31 isTyVarDict, isStdClassTyVarDict, isMethodFor,
37 InstOrigin(..), InstLoc(..), pprInstLoc
40 #include "HsVersions.h"
42 import {-# SOURCE #-} TcExpr( tcCheckSigma )
44 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
45 import TcHsSyn ( TcExpr, TcId, TcIdSet,
46 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
50 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
51 import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
52 import TcIface ( loadImportedInsts )
53 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
54 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
56 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
57 PredType(..), TyVarDetails(VanillaTv),
58 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
59 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
60 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
61 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
62 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
63 isClassPred, isTyVarClassPred, isLinearPred,
64 getClassPredTys, getClassPredTys_maybe, mkPredName,
65 isInheritablePred, isIPPred,
66 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
68 import HscTypes ( ExternalPackageState(..) )
69 import CoreFVs ( idFreeTyVars )
70 import DataCon ( DataCon,dataConSig )
71 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
72 import PrelInfo ( isStandardClass, isNoDictClass )
73 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
74 import NameSet ( addOneToNameSet )
75 import PprType ( pprPred, pprParendType, pprThetaArrow, pprClassPred )
76 import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
77 import Literal ( inIntRange )
79 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
80 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
81 import TysWiredIn ( floatDataCon, doubleDataCon )
82 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
83 import BasicTypes( IPName(..), mapIPName, ipNameName )
84 import UniqSupply( uniqsFromSupply )
92 instName :: Inst -> Name
93 instName inst = idName (instToId inst)
95 instToId :: Inst -> TcId
96 instToId (Dict id _ _) = id
97 instToId (Method id _ _ _ _ _) = id
98 instToId (LitInst id _ _ _) = id
100 instLoc (Dict _ _ loc) = loc
101 instLoc (Method _ _ _ _ _ loc) = loc
102 instLoc (LitInst _ _ _ loc) = loc
104 dictPred (Dict _ pred _ ) = pred
105 dictPred inst = pprPanic "dictPred" (ppr inst)
107 getDictClassTys (Dict _ pred _) = getClassPredTys pred
109 -- fdPredsOfInst is used to get predicates that contain functional
110 -- dependencies *or* might do so. The "might do" part is because
111 -- a constraint (C a b) might have a superclass with FDs
112 -- Leaving these in is really important for the call to fdPredsOfInsts
113 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
114 -- which is supposed to be conservative
115 fdPredsOfInst (Dict _ pred _) = [pred]
116 fdPredsOfInst (Method _ _ _ theta _ _) = theta
117 fdPredsOfInst other = [] -- LitInsts etc
119 fdPredsOfInsts :: [Inst] -> [PredType]
120 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
122 isInheritableInst (Dict _ pred _) = isInheritablePred pred
123 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
124 isInheritableInst other = True
127 ipNamesOfInsts :: [Inst] -> [Name]
128 ipNamesOfInst :: Inst -> [Name]
129 -- Get the implicit parameters mentioned by these Insts
130 -- NB: ?x and %x get different Names
131 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
133 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
134 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
135 ipNamesOfInst other = []
137 tyVarsOfInst :: Inst -> TcTyVarSet
138 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
139 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
140 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
141 -- The id might have free type variables; in the case of
142 -- locally-overloaded class methods, for example
145 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
146 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
152 isDict :: Inst -> Bool
153 isDict (Dict _ _ _) = True
156 isClassDict :: Inst -> Bool
157 isClassDict (Dict _ pred _) = isClassPred pred
158 isClassDict other = False
160 isTyVarDict :: Inst -> Bool
161 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
162 isTyVarDict other = False
164 isIPDict :: Inst -> Bool
165 isIPDict (Dict _ pred _) = isIPPred pred
166 isIPDict other = False
168 isMethod :: Inst -> Bool
169 isMethod (Method _ _ _ _ _ _) = True
170 isMethod other = False
172 isMethodFor :: TcIdSet -> Inst -> Bool
173 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
174 isMethodFor ids inst = False
176 isLinearInst :: Inst -> Bool
177 isLinearInst (Dict _ pred _) = isLinearPred pred
178 isLinearInst other = False
179 -- We never build Method Insts that have
180 -- linear implicit paramters in them.
181 -- Hence no need to look for Methods
184 linearInstType :: Inst -> TcType -- %x::t --> t
185 linearInstType (Dict _ (IParam _ ty) _) = ty
188 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
189 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
193 Two predicates which deal with the case where class constraints don't
194 necessarily result in bindings. The first tells whether an @Inst@
195 must be witnessed by an actual binding; the second tells whether an
196 @Inst@ can be generalised over.
199 instBindingRequired :: Inst -> Bool
200 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
201 instBindingRequired other = True
205 %************************************************************************
207 \subsection{Building dictionaries}
209 %************************************************************************
212 newDicts :: InstOrigin
216 = getInstLoc orig `thenM` \ loc ->
217 newDictsAtLoc loc theta
219 cloneDict :: Inst -> TcM Inst
220 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
221 returnM (Dict (setIdUnique id uniq) ty loc)
223 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
224 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
226 -- Local function, similar to newDicts,
227 -- but with slightly different interface
228 newDictsAtLoc :: InstLoc
231 newDictsAtLoc inst_loc theta
232 = newUniqueSupply `thenM` \ us ->
233 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
235 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
237 loc = instLocSrcLoc inst_loc
239 -- For vanilla implicit parameters, there is only one in scope
240 -- at any time, so we used to use the name of the implicit parameter itself
241 -- But with splittable implicit parameters there may be many in
242 -- scope, so we make up a new name.
243 newIPDict :: InstOrigin -> IPName Name -> Type
244 -> TcM (IPName Id, Inst)
245 newIPDict orig ip_name ty
246 = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) ->
247 newUnique `thenM` \ uniq ->
249 pred = IParam ip_name ty
250 id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
252 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
257 %************************************************************************
259 \subsection{Building methods (calls of overloaded functions)}
261 %************************************************************************
265 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
266 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
267 = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
268 newDicts orig theta `thenM` \ dicts ->
269 extendLIEs dicts `thenM_`
271 inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
273 returnM (mkCoercion inst_fn, tau)
275 tcInstDataCon :: InstOrigin -> DataCon
276 -> TcM ([TcType], -- Types to instantiate at
277 [Inst], -- Existential dictionaries to apply to
278 [TcType], -- Argument types of constructor
279 TcType, -- Result type
280 [TyVar]) -- Existential tyvars
281 tcInstDataCon orig data_con
283 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
284 -- We generate constraints for the stupid theta even when
285 -- pattern matching (as the Report requires)
287 tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
289 stupid_theta' = substTheta tenv stupid_theta
290 ex_theta' = substTheta tenv ex_theta
291 arg_tys' = map (substTy tenv) arg_tys
293 n_normal_tvs = length tvs
294 ex_tvs' = drop n_normal_tvs all_tvs'
295 result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
297 newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
298 newDicts orig ex_theta' `thenM` \ ex_dicts ->
300 -- Note that we return the stupid theta *only* in the LIE;
301 -- we don't otherwise use it at all
302 extendLIEs stupid_dicts `thenM_`
304 returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
306 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
307 newMethodFromName origin ty name
308 = tcLookupId name `thenM` \ id ->
309 -- Use tcLookupId not tcLookupGlobalId; the method is almost
310 -- always a class op, but with -fno-implicit-prelude GHC is
311 -- meant to find whatever thing is in scope, and that may
312 -- be an ordinary function.
313 getInstLoc origin `thenM` \ loc ->
314 tcInstClassOp loc id [ty] `thenM` \ inst ->
315 extendLIE inst `thenM_`
316 returnM (instToId inst)
318 newMethodWithGivenTy orig id tys theta tau
319 = getInstLoc orig `thenM` \ loc ->
320 newMethod loc id tys theta tau `thenM` \ inst ->
321 extendLIE inst `thenM_`
322 returnM (instToId inst)
324 --------------------------------------------
325 -- tcInstClassOp, and newMethod do *not* drop the
326 -- Inst into the LIE; they just returns the Inst
327 -- This is important because they are used by TcSimplify
330 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
331 tcInstClassOp inst_loc sel_id tys
333 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
334 rho_ty = ASSERT( length tyvars == length tys )
335 substTyWith tyvars tys rho
336 (preds,tau) = tcSplitPhiTy rho_ty
338 newMethod inst_loc sel_id tys preds tau
340 ---------------------------
341 newMethod inst_loc id tys theta tau
342 = newUnique `thenM` \ new_uniq ->
344 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
345 inst = Method meth_id id tys theta tau inst_loc
346 loc = instLocSrcLoc inst_loc
351 In newOverloadedLit we convert directly to an Int or Integer if we
352 know that's what we want. This may save some time, by not
353 temporarily generating overloaded literals, but it won't catch all
354 cases (the rest are caught in lookupInst).
357 newOverloadedLit :: InstOrigin
361 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
362 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
363 -- syntax. Reason: tcSyntaxName does unification
364 -- which is very inconvenient in tcSimplify
365 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
366 mkIntegerLit i `thenM` \ integer_lit ->
367 returnM (HsApp expr integer_lit)
369 | Just expr <- shortCutIntLit i expected_ty
373 = newLitInst orig lit expected_ty
375 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
376 | fr /= fromRationalName -- c.f. HsIntegral case
377 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
378 mkRatLit r `thenM` \ rat_lit ->
379 returnM (HsApp expr rat_lit)
381 | Just expr <- shortCutFracLit r expected_ty
385 = newLitInst orig lit expected_ty
387 newLitInst orig lit expected_ty
388 = getInstLoc orig `thenM` \ loc ->
389 newUnique `thenM` \ new_uniq ->
391 lit_inst = LitInst lit_id lit expected_ty loc
392 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
394 extendLIE lit_inst `thenM_`
395 returnM (HsVar (instToId lit_inst))
397 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
399 | isIntTy ty && inIntRange i -- Short cut for Int
400 = Just (HsLit (HsInt i))
401 | isIntegerTy ty -- Short cut for Integer
402 = Just (HsLit (HsInteger i ty))
403 | otherwise = Nothing
405 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
408 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
410 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
411 | otherwise = Nothing
413 mkIntegerLit :: Integer -> TcM TcExpr
415 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
416 returnM (HsLit (HsInteger i integer_ty))
418 mkRatLit :: Rational -> TcM TcExpr
420 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
421 returnM (HsLit (HsRat r rat_ty))
425 %************************************************************************
429 %************************************************************************
431 Zonking makes sure that the instance types are fully zonked,
432 but doesn't do the same for any of the Ids in an Inst. There's no
433 need, and it's a lot of extra work.
436 zonkInst :: Inst -> TcM Inst
437 zonkInst (Dict id pred loc)
438 = zonkTcPredType pred `thenM` \ new_pred ->
439 returnM (Dict id new_pred loc)
441 zonkInst (Method m id tys theta tau loc)
442 = zonkId id `thenM` \ new_id ->
443 -- Essential to zonk the id in case it's a local variable
444 -- Can't use zonkIdOcc because the id might itself be
445 -- an InstId, in which case it won't be in scope
447 zonkTcTypes tys `thenM` \ new_tys ->
448 zonkTcThetaType theta `thenM` \ new_theta ->
449 zonkTcType tau `thenM` \ new_tau ->
450 returnM (Method m new_id new_tys new_theta new_tau loc)
452 zonkInst (LitInst id lit ty loc)
453 = zonkTcType ty `thenM` \ new_ty ->
454 returnM (LitInst id lit new_ty loc)
456 zonkInsts insts = mappM zonkInst insts
460 %************************************************************************
462 \subsection{Printing}
464 %************************************************************************
466 ToDo: improve these pretty-printing things. The ``origin'' is really only
467 relevant in error messages.
470 instance Outputable Inst where
471 ppr inst = pprInst inst
473 pprInsts :: [Inst] -> SDoc
474 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
477 = vcat (map go insts)
479 go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
481 pprInst (LitInst u lit ty loc)
482 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
484 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
486 pprInst m@(Method u id tys theta tau loc)
487 = hsep [ppr id, ptext SLIT("at"),
488 brackets (sep (map pprParendType tys)) {- ,
489 ptext SLIT("theta"), ppr theta,
490 ptext SLIT("tau"), ppr tau
495 pprDFuns :: [DFunId] -> SDoc
496 -- Prints the dfun as an instance declaration
497 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
498 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
499 pprClassPred clas tys])
501 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
502 -- Print without the for-all, which the programmer doesn't write
504 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
506 tidyInst :: TidyEnv -> Inst -> Inst
507 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
508 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
509 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
511 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
512 -- This function doesn't assume that the tyvars are in scope
513 -- so it works like tidyOpenType, returning a TidyEnv
514 tidyMoreInsts env insts
515 = (env', map (tidyInst env') insts)
517 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
519 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
520 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
522 showLIE :: SDoc -> TcM () -- Debugging
524 = do { lie_var <- getLIEVar ;
525 lie <- readMutVar lie_var ;
526 traceTc (str <+> pprInstsInFull (lieToList lie)) }
530 %************************************************************************
532 Extending the instance environment
534 %************************************************************************
537 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
538 -- Add new locally-defined instances
539 tcExtendLocalInstEnv dfuns thing_inside
540 = do { traceDFuns dfuns
543 ; inst_env' <- foldlM (extend (eps_inst_env eps))
546 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
547 tcg_inst_env = inst_env' }
548 ; setGblEnv env' thing_inside }
550 extend pkg_ie home_ie dfun
551 = do { case checkFunDeps (home_ie, pkg_ie) dfun of
552 Just dfuns -> funDepErr dfun dfuns
554 ; return (extendInstEnv home_ie dfun) }
557 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
559 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
562 = addSrcLoc (getSrcLoc dfun) $
563 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
564 2 (pprDFuns (dfun:dfuns)))
567 %************************************************************************
569 \subsection{Looking up Insts}
571 %************************************************************************
574 data LookupInstResult s
576 | SimpleInst TcExpr -- Just a variable, type application, or literal
577 | GenInst [Inst] TcExpr -- The expression and its needed insts
579 lookupInst :: Inst -> TcM (LookupInstResult s)
580 -- It's important that lookupInst does not put any new stuff into
581 -- the LIE. Instead, any Insts needed by the lookup are returned in
582 -- the LookupInstResult, where they can be further processed by tcSimplify
587 lookupInst inst@(Method _ id tys theta _ loc)
588 = newDictsAtLoc loc theta `thenM` \ dicts ->
589 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
593 -- Look for short cuts first: if the literal is *definitely* a
594 -- int, integer, float or a double, generate the real thing here.
595 -- This is essential (see nofib/spectral/nucleic).
596 -- [Same shortcut as in newOverloadedLit, but we
597 -- may have done some unification by now]
600 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
601 | Just expr <- shortCutIntLit i ty
602 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
603 -- expr may be a constructor application
605 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
606 tcLookupId fromIntegerName `thenM` \ from_integer ->
607 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
608 mkIntegerLit i `thenM` \ integer_lit ->
609 returnM (GenInst [method_inst]
610 (HsApp (HsVar (instToId method_inst)) integer_lit))
612 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
613 | Just expr <- shortCutFracLit f ty
614 = returnM (GenInst [] expr)
617 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
618 tcLookupId fromRationalName `thenM` \ from_rational ->
619 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
620 mkRatLit f `thenM` \ rat_lit ->
621 returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
624 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
625 | all tcIsTyVarTy tys -- Common special case; no lookup
626 -- NB: tcIsTyVarTy... don't look through newtypes!
630 = do { pkg_ie <- loadImportedInsts clas tys
631 -- Suck in any instance decls that may be relevant
632 ; tcg_env <- getGblEnv
634 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
635 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
636 (matches, unifs) -> do
637 { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
638 text "unifs" <+> ppr unifs])
639 ; return NoInstance } } }
640 -- In the case of overlap (multiple matches) we report
641 -- NoInstance here. That has the effect of making the
642 -- context-simplifier return the dict as an irreducible one.
643 -- Then it'll be given to addNoInstanceErrs, which will do another
644 -- lookupInstEnv to get the detailed info about what went wrong.
646 lookupInst (Dict _ _ _) = returnM NoInstance
649 instantiate_dfun tenv dfun_id pred loc
650 = -- Record that this dfun is needed
651 record_dfun_usage dfun_id `thenM_`
653 -- It's possible that not all the tyvars are in
654 -- the substitution, tenv. For example:
655 -- instance C X a => D X where ...
656 -- (presumably there's a functional dependency in class C)
657 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
658 getStage `thenM` \ use_stage ->
659 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
660 (topIdLvl dfun_id) use_stage `thenM_`
662 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
663 mk_ty_arg tv = case lookupSubstEnv tenv tv of
664 Just (DoneTy ty) -> returnM ty
665 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
666 returnM (mkTyVarTy tc_tv)
668 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
670 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
671 (theta, _) = tcSplitPhiTy dfun_rho
672 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
675 returnM (SimpleInst ty_app)
677 newDictsAtLoc loc theta `thenM` \ dicts ->
679 rhs = mkHsDictApp ty_app (map instToId dicts)
681 returnM (GenInst dicts rhs)
683 record_dfun_usage dfun_id
684 | isInternalName dfun_name = return () -- From this module
685 | not (isHomePackageName dfun_name) = return () -- From another package package
686 | otherwise = getGblEnv `thenM` \ tcg_env ->
687 updMutVar (tcg_inst_uses tcg_env)
688 (`addOneToNameSet` idName dfun_id)
690 dfun_name = idName dfun_id
692 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
693 -- Gets both the home-pkg inst env (includes module being compiled)
694 -- and the external-package inst-env
695 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
696 return (tcg_inst_env env, eps_inst_env eps) }
701 %************************************************************************
705 %************************************************************************
708 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
709 a do-expression. We have to find (>>) in the current environment, which is
710 done by the rename. Then we have to check that it has the same type as
711 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
714 (>>) :: HB m n mn => m a -> n b -> mn b
716 So the idea is to generate a local binding for (>>), thus:
718 let then72 :: forall a b. m a -> m b -> m b
719 then72 = ...something involving the user's (>>)...
721 ...the do-expression...
723 Now the do-expression can proceed using then72, which has exactly
726 In fact tcSyntaxName just generates the RHS for then72, because we only
727 want an actual binding in the do-expression case. For literals, we can
728 just use the expression inline.
731 tcSyntaxName :: InstOrigin
732 -> TcType -- Type to instantiate it at
733 -> (Name, HsExpr Name) -- (Standard name, user name)
734 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
736 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
737 -- So we do not call it from lookupInst, which is called from tcSimplify
739 tcSyntaxName orig ty (std_nm, HsVar user_nm)
741 = tcStdSyntaxName orig ty std_nm
743 tcSyntaxName orig ty (std_nm, user_nm_expr)
744 = tcLookupId std_nm `thenM` \ std_id ->
746 -- C.f. newMethodAtLoc
747 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
748 tau1 = substTyWith [tv] [ty] tau
749 -- Actually, the "tau-type" might be a sigma-type in the
750 -- case of locally-polymorphic methods.
752 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
754 -- Check that the user-supplied thing has the
755 -- same type as the standard one
756 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
757 returnM (std_nm, expr)
759 tcStdSyntaxName :: InstOrigin
760 -> TcType -- Type to instantiate it at
761 -> Name -- Standard name
762 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
764 tcStdSyntaxName orig ty std_nm
765 = newMethodFromName orig ty std_nm `thenM` \ id ->
766 returnM (std_nm, HsVar id)
768 syntaxNameCtxt name orig ty tidy_env
769 = getInstLoc orig `thenM` \ inst_loc ->
771 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
772 ptext SLIT("(needed by a syntactic construct)"),
773 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
774 nest 2 (pprInstLoc inst_loc)]
776 returnM (tidy_env, msg)