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, matchTys,
66 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
67 pprPred, pprParendType, pprThetaArrow, pprClassPred
69 import HscTypes ( ExternalPackageState(..) )
70 import CoreFVs ( idFreeTyVars )
71 import DataCon ( DataCon,dataConSig )
72 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
73 import PrelInfo ( isStandardClass, isNoDictClass )
74 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
75 import NameSet ( addOneToNameSet )
76 import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
77 import Literal ( inIntRange )
79 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
80 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
81 import TysWiredIn ( floatDataCon, doubleDataCon )
82 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
83 import BasicTypes( IPName(..), mapIPName, ipNameName )
84 import UniqSupply( uniqsFromSupply )
85 import CmdLineOpts( DynFlags )
86 import Maybes ( isJust )
94 instName :: Inst -> Name
95 instName inst = idName (instToId inst)
97 instToId :: Inst -> TcId
98 instToId (Dict id _ _) = id
99 instToId (Method id _ _ _ _ _) = id
100 instToId (LitInst id _ _ _) = id
102 instLoc (Dict _ _ loc) = loc
103 instLoc (Method _ _ _ _ _ loc) = loc
104 instLoc (LitInst _ _ _ loc) = loc
106 dictPred (Dict _ pred _ ) = pred
107 dictPred inst = pprPanic "dictPred" (ppr inst)
109 getDictClassTys (Dict _ pred _) = getClassPredTys pred
111 -- fdPredsOfInst is used to get predicates that contain functional
112 -- dependencies *or* might do so. The "might do" part is because
113 -- a constraint (C a b) might have a superclass with FDs
114 -- Leaving these in is really important for the call to fdPredsOfInsts
115 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
116 -- which is supposed to be conservative
117 fdPredsOfInst (Dict _ pred _) = [pred]
118 fdPredsOfInst (Method _ _ _ theta _ _) = theta
119 fdPredsOfInst other = [] -- LitInsts etc
121 fdPredsOfInsts :: [Inst] -> [PredType]
122 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
124 isInheritableInst (Dict _ pred _) = isInheritablePred pred
125 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
126 isInheritableInst other = True
129 ipNamesOfInsts :: [Inst] -> [Name]
130 ipNamesOfInst :: Inst -> [Name]
131 -- Get the implicit parameters mentioned by these Insts
132 -- NB: ?x and %x get different Names
133 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
135 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
136 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
137 ipNamesOfInst other = []
139 tyVarsOfInst :: Inst -> TcTyVarSet
140 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
141 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
142 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
143 -- The id might have free type variables; in the case of
144 -- locally-overloaded class methods, for example
147 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
148 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
154 isDict :: Inst -> Bool
155 isDict (Dict _ _ _) = True
158 isClassDict :: Inst -> Bool
159 isClassDict (Dict _ pred _) = isClassPred pred
160 isClassDict other = False
162 isTyVarDict :: Inst -> Bool
163 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
164 isTyVarDict other = False
166 isIPDict :: Inst -> Bool
167 isIPDict (Dict _ pred _) = isIPPred pred
168 isIPDict other = False
170 isMethod :: Inst -> Bool
171 isMethod (Method _ _ _ _ _ _) = True
172 isMethod other = False
174 isMethodFor :: TcIdSet -> Inst -> Bool
175 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
176 isMethodFor ids inst = False
178 isLinearInst :: Inst -> Bool
179 isLinearInst (Dict _ pred _) = isLinearPred pred
180 isLinearInst other = False
181 -- We never build Method Insts that have
182 -- linear implicit paramters in them.
183 -- Hence no need to look for Methods
186 linearInstType :: Inst -> TcType -- %x::t --> t
187 linearInstType (Dict _ (IParam _ ty) _) = ty
190 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
191 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
195 Two predicates which deal with the case where class constraints don't
196 necessarily result in bindings. The first tells whether an @Inst@
197 must be witnessed by an actual binding; the second tells whether an
198 @Inst@ can be generalised over.
201 instBindingRequired :: Inst -> Bool
202 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
203 instBindingRequired other = True
207 %************************************************************************
209 \subsection{Building dictionaries}
211 %************************************************************************
214 newDicts :: InstOrigin
218 = getInstLoc orig `thenM` \ loc ->
219 newDictsAtLoc loc theta
221 cloneDict :: Inst -> TcM Inst
222 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
223 returnM (Dict (setIdUnique id uniq) ty loc)
225 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
226 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
228 -- Local function, similar to newDicts,
229 -- but with slightly different interface
230 newDictsAtLoc :: InstLoc
233 newDictsAtLoc inst_loc theta
234 = newUniqueSupply `thenM` \ us ->
235 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
237 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
239 loc = instLocSrcLoc inst_loc
241 -- For vanilla implicit parameters, there is only one in scope
242 -- at any time, so we used to use the name of the implicit parameter itself
243 -- But with splittable implicit parameters there may be many in
244 -- scope, so we make up a new name.
245 newIPDict :: InstOrigin -> IPName Name -> Type
246 -> TcM (IPName Id, Inst)
247 newIPDict orig ip_name ty
248 = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) ->
249 newUnique `thenM` \ uniq ->
251 pred = IParam ip_name ty
252 id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
254 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
259 %************************************************************************
261 \subsection{Building methods (calls of overloaded functions)}
263 %************************************************************************
267 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
268 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
269 = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
270 newDicts orig theta `thenM` \ dicts ->
271 extendLIEs dicts `thenM_`
273 inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
275 returnM (mkCoercion inst_fn, tau)
277 tcInstDataCon :: InstOrigin -> DataCon
278 -> TcM ([TcType], -- Types to instantiate at
279 [Inst], -- Existential dictionaries to apply to
280 [TcType], -- Argument types of constructor
281 TcType, -- Result type
282 [TyVar]) -- Existential tyvars
283 tcInstDataCon orig data_con
285 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
286 -- We generate constraints for the stupid theta even when
287 -- pattern matching (as the Report requires)
289 tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
291 stupid_theta' = substTheta tenv stupid_theta
292 ex_theta' = substTheta tenv ex_theta
293 arg_tys' = map (substTy tenv) arg_tys
295 n_normal_tvs = length tvs
296 ex_tvs' = drop n_normal_tvs all_tvs'
297 result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
299 newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
300 newDicts orig ex_theta' `thenM` \ ex_dicts ->
302 -- Note that we return the stupid theta *only* in the LIE;
303 -- we don't otherwise use it at all
304 extendLIEs stupid_dicts `thenM_`
306 returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
308 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
309 newMethodFromName origin ty name
310 = tcLookupId name `thenM` \ id ->
311 -- Use tcLookupId not tcLookupGlobalId; the method is almost
312 -- always a class op, but with -fno-implicit-prelude GHC is
313 -- meant to find whatever thing is in scope, and that may
314 -- be an ordinary function.
315 getInstLoc origin `thenM` \ loc ->
316 tcInstClassOp loc id [ty] `thenM` \ inst ->
317 extendLIE inst `thenM_`
318 returnM (instToId inst)
320 newMethodWithGivenTy orig id tys theta tau
321 = getInstLoc orig `thenM` \ loc ->
322 newMethod loc id tys theta tau `thenM` \ inst ->
323 extendLIE inst `thenM_`
324 returnM (instToId inst)
326 --------------------------------------------
327 -- tcInstClassOp, and newMethod do *not* drop the
328 -- Inst into the LIE; they just returns the Inst
329 -- This is important because they are used by TcSimplify
332 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
333 tcInstClassOp inst_loc sel_id tys
335 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
336 rho_ty = ASSERT( length tyvars == length tys )
337 substTyWith tyvars tys rho
338 (preds,tau) = tcSplitPhiTy rho_ty
340 newMethod inst_loc sel_id tys preds tau
342 ---------------------------
343 newMethod inst_loc id tys theta tau
344 = newUnique `thenM` \ new_uniq ->
346 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
347 inst = Method meth_id id tys theta tau inst_loc
348 loc = instLocSrcLoc inst_loc
353 In newOverloadedLit we convert directly to an Int or Integer if we
354 know that's what we want. This may save some time, by not
355 temporarily generating overloaded literals, but it won't catch all
356 cases (the rest are caught in lookupInst).
359 newOverloadedLit :: InstOrigin
363 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
364 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
365 -- syntax. Reason: tcSyntaxName does unification
366 -- which is very inconvenient in tcSimplify
367 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
368 mkIntegerLit i `thenM` \ integer_lit ->
369 returnM (HsApp expr integer_lit)
371 | Just expr <- shortCutIntLit i expected_ty
375 = newLitInst orig lit expected_ty
377 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
378 | fr /= fromRationalName -- c.f. HsIntegral case
379 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
380 mkRatLit r `thenM` \ rat_lit ->
381 returnM (HsApp expr rat_lit)
383 | Just expr <- shortCutFracLit r expected_ty
387 = newLitInst orig lit expected_ty
389 newLitInst orig lit expected_ty
390 = getInstLoc orig `thenM` \ loc ->
391 newUnique `thenM` \ new_uniq ->
393 lit_inst = LitInst lit_id lit expected_ty loc
394 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
396 extendLIE lit_inst `thenM_`
397 returnM (HsVar (instToId lit_inst))
399 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
401 | isIntTy ty && inIntRange i -- Short cut for Int
402 = Just (HsLit (HsInt i))
403 | isIntegerTy ty -- Short cut for Integer
404 = Just (HsLit (HsInteger i ty))
405 | otherwise = Nothing
407 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
410 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
412 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
413 | otherwise = Nothing
415 mkIntegerLit :: Integer -> TcM TcExpr
417 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
418 returnM (HsLit (HsInteger i integer_ty))
420 mkRatLit :: Rational -> TcM TcExpr
422 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
423 returnM (HsLit (HsRat r rat_ty))
427 %************************************************************************
431 %************************************************************************
433 Zonking makes sure that the instance types are fully zonked,
434 but doesn't do the same for any of the Ids in an Inst. There's no
435 need, and it's a lot of extra work.
438 zonkInst :: Inst -> TcM Inst
439 zonkInst (Dict id pred loc)
440 = zonkTcPredType pred `thenM` \ new_pred ->
441 returnM (Dict id new_pred loc)
443 zonkInst (Method m id tys theta tau loc)
444 = zonkId id `thenM` \ new_id ->
445 -- Essential to zonk the id in case it's a local variable
446 -- Can't use zonkIdOcc because the id might itself be
447 -- an InstId, in which case it won't be in scope
449 zonkTcTypes tys `thenM` \ new_tys ->
450 zonkTcThetaType theta `thenM` \ new_theta ->
451 zonkTcType tau `thenM` \ new_tau ->
452 returnM (Method m new_id new_tys new_theta new_tau loc)
454 zonkInst (LitInst id lit ty loc)
455 = zonkTcType ty `thenM` \ new_ty ->
456 returnM (LitInst id lit new_ty loc)
458 zonkInsts insts = mappM zonkInst insts
462 %************************************************************************
464 \subsection{Printing}
466 %************************************************************************
468 ToDo: improve these pretty-printing things. The ``origin'' is really only
469 relevant in error messages.
472 instance Outputable Inst where
473 ppr inst = pprInst inst
475 pprInsts :: [Inst] -> SDoc
476 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
479 = vcat (map go insts)
481 go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
483 pprInst (LitInst u lit ty loc)
484 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
486 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
488 pprInst m@(Method u id tys theta tau loc)
489 = hsep [ppr id, ptext SLIT("at"),
490 brackets (sep (map pprParendType tys)) {- ,
491 ptext SLIT("theta"), ppr theta,
492 ptext SLIT("tau"), ppr tau
497 pprDFuns :: [DFunId] -> SDoc
498 -- Prints the dfun as an instance declaration
499 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
500 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
501 pprClassPred clas tys])
503 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
504 -- Print without the for-all, which the programmer doesn't write
506 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
508 tidyInst :: TidyEnv -> Inst -> Inst
509 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
510 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
511 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
513 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
514 -- This function doesn't assume that the tyvars are in scope
515 -- so it works like tidyOpenType, returning a TidyEnv
516 tidyMoreInsts env insts
517 = (env', map (tidyInst env') insts)
519 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
521 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
522 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
524 showLIE :: SDoc -> TcM () -- Debugging
526 = do { lie_var <- getLIEVar ;
527 lie <- readMutVar lie_var ;
528 traceTc (str <+> pprInstsInFull (lieToList lie)) }
532 %************************************************************************
534 Extending the instance environment
536 %************************************************************************
539 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
540 -- Add new locally-defined instances
541 tcExtendLocalInstEnv dfuns thing_inside
542 = do { traceDFuns dfuns
545 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
546 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
547 tcg_inst_env = inst_env' }
548 ; setGblEnv env' thing_inside }
550 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
551 -- Check that the proposed new instance is OK,
552 -- and then add it to the home inst env
553 addInst dflags home_ie dfun
554 = do { -- Load imported instances, so that we report
555 -- duplicates correctly
556 pkg_ie <- loadImportedInsts cls tys
558 -- Check functional dependencies
559 ; case checkFunDeps (pkg_ie, home_ie) dfun of
560 Just dfuns -> funDepErr dfun dfuns
563 -- Check for duplicate instance decls
564 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
565 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
566 isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
567 -- Find memebers of the match list which
568 -- dfun itself matches. If the match is 2-way, it's a duplicate
570 dup_dfun : _ -> dupInstErr dfun dup_dfun
573 -- OK, now extend the envt
574 ; return (extendInstEnv home_ie dfun) }
576 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
579 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
581 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
584 = addSrcLoc (getSrcLoc dfun) $
585 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
586 2 (pprDFuns (dfun:dfuns)))
587 dupInstErr dfun dup_dfun
588 = addSrcLoc (getSrcLoc dfun) $
589 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
590 2 (pprDFuns [dfun, dup_dfun]))
593 %************************************************************************
595 \subsection{Looking up Insts}
597 %************************************************************************
600 data LookupInstResult s
602 | SimpleInst TcExpr -- Just a variable, type application, or literal
603 | GenInst [Inst] TcExpr -- The expression and its needed insts
605 lookupInst :: Inst -> TcM (LookupInstResult s)
606 -- It's important that lookupInst does not put any new stuff into
607 -- the LIE. Instead, any Insts needed by the lookup are returned in
608 -- the LookupInstResult, where they can be further processed by tcSimplify
613 lookupInst inst@(Method _ id tys theta _ loc)
614 = newDictsAtLoc loc theta `thenM` \ dicts ->
615 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
619 -- Look for short cuts first: if the literal is *definitely* a
620 -- int, integer, float or a double, generate the real thing here.
621 -- This is essential (see nofib/spectral/nucleic).
622 -- [Same shortcut as in newOverloadedLit, but we
623 -- may have done some unification by now]
626 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
627 | Just expr <- shortCutIntLit i ty
628 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
629 -- expr may be a constructor application
631 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
632 tcLookupId fromIntegerName `thenM` \ from_integer ->
633 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
634 mkIntegerLit i `thenM` \ integer_lit ->
635 returnM (GenInst [method_inst]
636 (HsApp (HsVar (instToId method_inst)) integer_lit))
638 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
639 | Just expr <- shortCutFracLit f ty
640 = returnM (GenInst [] expr)
643 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
644 tcLookupId fromRationalName `thenM` \ from_rational ->
645 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
646 mkRatLit f `thenM` \ rat_lit ->
647 returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
650 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
651 | all tcIsTyVarTy tys -- Common special case; no lookup
652 -- NB: tcIsTyVarTy... don't look through newtypes!
656 = do { pkg_ie <- loadImportedInsts clas tys
657 -- Suck in any instance decls that may be relevant
658 ; tcg_env <- getGblEnv
660 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
661 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
662 (matches, unifs) -> do
663 { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
664 text "unifs" <+> ppr unifs])
665 ; return NoInstance } } }
666 -- In the case of overlap (multiple matches) we report
667 -- NoInstance here. That has the effect of making the
668 -- context-simplifier return the dict as an irreducible one.
669 -- Then it'll be given to addNoInstanceErrs, which will do another
670 -- lookupInstEnv to get the detailed info about what went wrong.
672 lookupInst (Dict _ _ _) = returnM NoInstance
675 instantiate_dfun tenv dfun_id pred loc
676 = -- Record that this dfun is needed
677 record_dfun_usage dfun_id `thenM_`
679 -- It's possible that not all the tyvars are in
680 -- the substitution, tenv. For example:
681 -- instance C X a => D X where ...
682 -- (presumably there's a functional dependency in class C)
683 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
684 getStage `thenM` \ use_stage ->
685 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
686 (topIdLvl dfun_id) use_stage `thenM_`
688 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
689 mk_ty_arg tv = case lookupSubstEnv tenv tv of
690 Just (DoneTy ty) -> returnM ty
691 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
692 returnM (mkTyVarTy tc_tv)
694 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
696 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
697 (theta, _) = tcSplitPhiTy dfun_rho
698 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
701 returnM (SimpleInst ty_app)
703 newDictsAtLoc loc theta `thenM` \ dicts ->
705 rhs = mkHsDictApp ty_app (map instToId dicts)
707 returnM (GenInst dicts rhs)
709 record_dfun_usage dfun_id
710 | isInternalName dfun_name = return () -- From this module
711 | not (isHomePackageName dfun_name) = return () -- From another package package
712 | otherwise = getGblEnv `thenM` \ tcg_env ->
713 updMutVar (tcg_inst_uses tcg_env)
714 (`addOneToNameSet` idName dfun_id)
716 dfun_name = idName dfun_id
718 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
719 -- Gets both the home-pkg inst env (includes module being compiled)
720 -- and the external-package inst-env
721 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
722 return (tcg_inst_env env, eps_inst_env eps) }
727 %************************************************************************
731 %************************************************************************
734 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
735 a do-expression. We have to find (>>) in the current environment, which is
736 done by the rename. Then we have to check that it has the same type as
737 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
740 (>>) :: HB m n mn => m a -> n b -> mn b
742 So the idea is to generate a local binding for (>>), thus:
744 let then72 :: forall a b. m a -> m b -> m b
745 then72 = ...something involving the user's (>>)...
747 ...the do-expression...
749 Now the do-expression can proceed using then72, which has exactly
752 In fact tcSyntaxName just generates the RHS for then72, because we only
753 want an actual binding in the do-expression case. For literals, we can
754 just use the expression inline.
757 tcSyntaxName :: InstOrigin
758 -> TcType -- Type to instantiate it at
759 -> (Name, HsExpr Name) -- (Standard name, user name)
760 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
762 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
763 -- So we do not call it from lookupInst, which is called from tcSimplify
765 tcSyntaxName orig ty (std_nm, HsVar user_nm)
767 = tcStdSyntaxName orig ty std_nm
769 tcSyntaxName orig ty (std_nm, user_nm_expr)
770 = tcLookupId std_nm `thenM` \ std_id ->
772 -- C.f. newMethodAtLoc
773 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
774 tau1 = substTyWith [tv] [ty] tau
775 -- Actually, the "tau-type" might be a sigma-type in the
776 -- case of locally-polymorphic methods.
778 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
780 -- Check that the user-supplied thing has the
781 -- same type as the standard one
782 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
783 returnM (std_nm, expr)
785 tcStdSyntaxName :: InstOrigin
786 -> TcType -- Type to instantiate it at
787 -> Name -- Standard name
788 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
790 tcStdSyntaxName orig ty std_nm
791 = newMethodFromName orig ty std_nm `thenM` \ id ->
792 returnM (std_nm, HsVar id)
794 syntaxNameCtxt name orig ty tidy_env
795 = getInstLoc orig `thenM` \ inst_loc ->
797 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
798 ptext SLIT("(needed by a syntactic construct)"),
799 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
800 nest 2 (pprInstLoc inst_loc)]
802 returnM (tidy_env, msg)