2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
11 pprInst, pprInsts, pprInstsInFull, pprDFuns,
12 tidyInsts, tidyMoreInsts,
14 newDictsFromOld, newDicts, cloneDict,
15 newOverloadedLit, newIPDict,
16 newMethod, newMethodFromName, newMethodWithGivenTy,
17 tcInstClassOp, tcInstCall, tcInstDataCon,
18 tcSyntaxName, tcStdSyntaxName,
20 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
21 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
22 instLoc, getDictClassTys, dictPred,
24 lookupInst, LookupInstResult(..),
25 tcExtendLocalInstEnv, tcGetInstEnvs,
27 isDict, isClassDict, isMethod,
28 isLinearInst, linearInstType, isIPDict, isInheritableInst,
29 isTyVarDict, isStdClassTyVarDict, isMethodFor,
35 InstOrigin(..), InstLoc(..), pprInstLoc
38 #include "HsVersions.h"
40 import {-# SOURCE #-} TcExpr( tcCheckSigma )
42 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, nlHsVar, mkHsApp )
43 import TcHsSyn ( TcId, TcIdSet,
44 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
48 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
49 import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
50 import TcIface ( loadImportedInsts )
51 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
52 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
54 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
55 PredType(..), TyVarDetails(VanillaTv),
56 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
57 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
58 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
59 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
60 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
61 isClassPred, isTyVarClassPred, isLinearPred,
62 getClassPredTys, getClassPredTys_maybe, mkPredName,
63 isInheritablePred, isIPPred, matchTys,
64 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
65 pprPred, pprParendType, pprThetaArrow, pprClassPred
67 import HscTypes ( ExternalPackageState(..) )
68 import CoreFVs ( idFreeTyVars )
69 import DataCon ( DataCon,dataConSig )
70 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
71 import PrelInfo ( isStandardClass, isNoDictClass )
72 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
73 import NameSet ( addOneToNameSet )
74 import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
75 import Literal ( inIntRange )
77 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
78 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
79 import TysWiredIn ( floatDataCon, doubleDataCon )
80 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
81 import BasicTypes( IPName(..), mapIPName, ipNameName )
82 import UniqSupply( uniqsFromSupply )
83 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
84 import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
85 import Maybes ( isJust )
93 instName :: Inst -> Name
94 instName inst = idName (instToId inst)
96 instToId :: Inst -> TcId
97 instToId (Dict id _ _) = id
98 instToId (Method id _ _ _ _ _) = id
99 instToId (LitInst id _ _ _) = id
101 instLoc (Dict _ _ loc) = loc
102 instLoc (Method _ _ _ _ _ loc) = loc
103 instLoc (LitInst _ _ _ loc) = loc
105 dictPred (Dict _ pred _ ) = pred
106 dictPred inst = pprPanic "dictPred" (ppr inst)
108 getDictClassTys (Dict _ pred _) = getClassPredTys pred
110 -- fdPredsOfInst is used to get predicates that contain functional
111 -- dependencies *or* might do so. The "might do" part is because
112 -- a constraint (C a b) might have a superclass with FDs
113 -- Leaving these in is really important for the call to fdPredsOfInsts
114 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
115 -- which is supposed to be conservative
116 fdPredsOfInst (Dict _ pred _) = [pred]
117 fdPredsOfInst (Method _ _ _ theta _ _) = theta
118 fdPredsOfInst other = [] -- LitInsts etc
120 fdPredsOfInsts :: [Inst] -> [PredType]
121 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
123 isInheritableInst (Dict _ pred _) = isInheritablePred pred
124 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
125 isInheritableInst other = True
128 ipNamesOfInsts :: [Inst] -> [Name]
129 ipNamesOfInst :: Inst -> [Name]
130 -- Get the implicit parameters mentioned by these Insts
131 -- NB: ?x and %x get different Names
132 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
134 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
135 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
136 ipNamesOfInst other = []
138 tyVarsOfInst :: Inst -> TcTyVarSet
139 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
140 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
141 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
142 -- The id might have free type variables; in the case of
143 -- locally-overloaded class methods, for example
146 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
147 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
153 isDict :: Inst -> Bool
154 isDict (Dict _ _ _) = True
157 isClassDict :: Inst -> Bool
158 isClassDict (Dict _ pred _) = isClassPred pred
159 isClassDict other = False
161 isTyVarDict :: Inst -> Bool
162 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
163 isTyVarDict other = False
165 isIPDict :: Inst -> Bool
166 isIPDict (Dict _ pred _) = isIPPred pred
167 isIPDict other = False
169 isMethod :: Inst -> Bool
170 isMethod (Method _ _ _ _ _ _) = True
171 isMethod other = False
173 isMethodFor :: TcIdSet -> Inst -> Bool
174 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
175 isMethodFor ids inst = False
177 isLinearInst :: Inst -> Bool
178 isLinearInst (Dict _ pred _) = isLinearPred pred
179 isLinearInst other = False
180 -- We never build Method Insts that have
181 -- linear implicit paramters in them.
182 -- Hence no need to look for Methods
185 linearInstType :: Inst -> TcType -- %x::t --> t
186 linearInstType (Dict _ (IParam _ ty) _) = ty
189 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
190 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
194 Two predicates which deal with the case where class constraints don't
195 necessarily result in bindings. The first tells whether an @Inst@
196 must be witnessed by an actual binding; the second tells whether an
197 @Inst@ can be generalised over.
200 instBindingRequired :: Inst -> Bool
201 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
202 instBindingRequired other = True
206 %************************************************************************
208 \subsection{Building dictionaries}
210 %************************************************************************
213 newDicts :: InstOrigin
217 = getInstLoc orig `thenM` \ loc ->
218 newDictsAtLoc loc theta
220 cloneDict :: Inst -> TcM Inst
221 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
222 returnM (Dict (setIdUnique id uniq) ty loc)
224 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
225 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
227 -- Local function, similar to newDicts,
228 -- but with slightly different interface
229 newDictsAtLoc :: InstLoc
232 newDictsAtLoc inst_loc theta
233 = newUniqueSupply `thenM` \ us ->
234 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
236 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
238 loc = instLocSrcLoc inst_loc
240 -- For vanilla implicit parameters, there is only one in scope
241 -- at any time, so we used to use the name of the implicit parameter itself
242 -- But with splittable implicit parameters there may be many in
243 -- scope, so we make up a new name.
244 newIPDict :: InstOrigin -> IPName Name -> Type
245 -> TcM (IPName Id, Inst)
246 newIPDict orig ip_name ty
247 = getInstLoc orig `thenM` \ inst_loc ->
248 newUnique `thenM` \ uniq ->
250 pred = IParam ip_name ty
251 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
252 id = mkLocalId name (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 = DictApp (mkHsTyApp (noLoc 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
362 -> TcM (LHsExpr TcId)
363 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
364 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
365 -- Reason: tcSyntaxName does unification
366 -- which is very inconvenient in tcSimplify
367 -- ToDo: noLoc sadness
368 = tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) ->
369 mkIntegerLit i `thenM` \ integer_lit ->
370 returnM (mkHsApp expr integer_lit)
372 | Just expr <- shortCutIntLit i expected_ty
376 = newLitInst orig lit expected_ty
378 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
379 | fr /= fromRationalName -- c.f. HsIntegral case
380 = tcSyntaxName orig expected_ty (fromRationalName, noLoc (HsVar fr)) `thenM` \ (_,expr) ->
381 mkRatLit r `thenM` \ rat_lit ->
382 returnM (mkHsApp expr rat_lit)
384 | Just expr <- shortCutFracLit r expected_ty
388 = newLitInst orig lit expected_ty
390 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
391 newLitInst orig lit expected_ty
392 = getInstLoc orig `thenM` \ loc ->
393 newUnique `thenM` \ new_uniq ->
395 lit_inst = LitInst lit_id lit expected_ty loc
396 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
398 extendLIE lit_inst `thenM_`
399 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
401 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
403 | isIntTy ty && inIntRange i -- Short cut for Int
404 = Just (noLoc (HsLit (HsInt i)))
405 | isIntegerTy ty -- Short cut for Integer
406 = Just (noLoc (HsLit (HsInteger i ty)))
407 | otherwise = Nothing
409 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
412 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
414 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
415 | otherwise = Nothing
417 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
419 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
420 getSrcSpanM `thenM` \ span ->
421 returnM (L span $ HsLit (HsInteger i integer_ty))
423 mkRatLit :: Rational -> TcM (LHsExpr TcId)
425 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
426 getSrcSpanM `thenM` \ span ->
427 returnM (L span $ HsLit (HsRat r rat_ty))
431 %************************************************************************
435 %************************************************************************
437 Zonking makes sure that the instance types are fully zonked,
438 but doesn't do the same for any of the Ids in an Inst. There's no
439 need, and it's a lot of extra work.
442 zonkInst :: Inst -> TcM Inst
443 zonkInst (Dict id pred loc)
444 = zonkTcPredType pred `thenM` \ new_pred ->
445 returnM (Dict id new_pred loc)
447 zonkInst (Method m id tys theta tau loc)
448 = zonkId id `thenM` \ new_id ->
449 -- Essential to zonk the id in case it's a local variable
450 -- Can't use zonkIdOcc because the id might itself be
451 -- an InstId, in which case it won't be in scope
453 zonkTcTypes tys `thenM` \ new_tys ->
454 zonkTcThetaType theta `thenM` \ new_theta ->
455 zonkTcType tau `thenM` \ new_tau ->
456 returnM (Method m new_id new_tys new_theta new_tau loc)
458 zonkInst (LitInst id lit ty loc)
459 = zonkTcType ty `thenM` \ new_ty ->
460 returnM (LitInst id lit new_ty loc)
462 zonkInsts insts = mappM zonkInst insts
466 %************************************************************************
468 \subsection{Printing}
470 %************************************************************************
472 ToDo: improve these pretty-printing things. The ``origin'' is really only
473 relevant in error messages.
476 instance Outputable Inst where
477 ppr inst = pprInst inst
479 pprInsts :: [Inst] -> SDoc
480 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
483 = vcat (map go insts)
485 go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
487 pprInst (LitInst u lit ty loc)
488 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
490 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
492 pprInst m@(Method u id tys theta tau loc)
493 = hsep [ppr id, ptext SLIT("at"),
494 brackets (sep (map pprParendType tys)) {- ,
495 ptext SLIT("theta"), ppr theta,
496 ptext SLIT("tau"), ppr tau
501 pprDFuns :: [DFunId] -> SDoc
502 -- Prints the dfun as an instance declaration
503 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
504 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
505 pprClassPred clas tys])
507 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
508 -- Print without the for-all, which the programmer doesn't write
510 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
512 tidyInst :: TidyEnv -> Inst -> Inst
513 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
514 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
515 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
517 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
518 -- This function doesn't assume that the tyvars are in scope
519 -- so it works like tidyOpenType, returning a TidyEnv
520 tidyMoreInsts env insts
521 = (env', map (tidyInst env') insts)
523 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
525 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
526 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
528 showLIE :: SDoc -> TcM () -- Debugging
530 = do { lie_var <- getLIEVar ;
531 lie <- readMutVar lie_var ;
532 traceTc (str <+> pprInstsInFull (lieToList lie)) }
536 %************************************************************************
538 Extending the instance environment
540 %************************************************************************
543 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
544 -- Add new locally-defined instances
545 tcExtendLocalInstEnv dfuns thing_inside
546 = do { traceDFuns dfuns
549 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
550 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
551 tcg_inst_env = inst_env' }
552 ; setGblEnv env' thing_inside }
554 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
555 -- Check that the proposed new instance is OK,
556 -- and then add it to the home inst env
557 addInst dflags home_ie dfun
558 = do { -- Load imported instances, so that we report
559 -- duplicates correctly
560 pkg_ie <- loadImportedInsts cls tys
562 -- Check functional dependencies
563 ; case checkFunDeps (pkg_ie, home_ie) dfun of
564 Just dfuns -> funDepErr dfun dfuns
567 -- Check for duplicate instance decls
568 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
569 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
570 isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
571 -- Find memebers of the match list which
572 -- dfun itself matches. If the match is 2-way, it's a duplicate
574 dup_dfun : _ -> dupInstErr dfun dup_dfun
577 -- OK, now extend the envt
578 ; return (extendInstEnv home_ie dfun) }
580 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
583 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
585 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
589 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
590 2 (pprDFuns (dfun:dfuns)))
591 dupInstErr dfun dup_dfun
593 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
594 2 (pprDFuns [dfun, dup_dfun]))
596 addDictLoc dfun thing_inside
597 = addSrcSpan (mkSrcSpan loc loc) thing_inside
602 %************************************************************************
604 \subsection{Looking up Insts}
606 %************************************************************************
609 data LookupInstResult s
611 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
612 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
614 lookupInst :: Inst -> TcM (LookupInstResult s)
615 -- It's important that lookupInst does not put any new stuff into
616 -- the LIE. Instead, any Insts needed by the lookup are returned in
617 -- the LookupInstResult, where they can be further processed by tcSimplify
622 lookupInst inst@(Method _ id tys theta _ loc)
623 = newDictsAtLoc loc theta `thenM` \ dicts ->
624 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
626 span = instLocSrcSpan loc
630 -- Look for short cuts first: if the literal is *definitely* a
631 -- int, integer, float or a double, generate the real thing here.
632 -- This is essential (see nofib/spectral/nucleic).
633 -- [Same shortcut as in newOverloadedLit, but we
634 -- may have done some unification by now]
637 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
638 | Just expr <- shortCutIntLit i ty
639 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
640 -- expr may be a constructor application
642 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
643 tcLookupId fromIntegerName `thenM` \ from_integer ->
644 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
645 mkIntegerLit i `thenM` \ integer_lit ->
646 returnM (GenInst [method_inst]
647 (mkHsApp (L (instLocSrcSpan loc)
648 (HsVar (instToId method_inst))) integer_lit))
650 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
651 | Just expr <- shortCutFracLit f ty
652 = returnM (GenInst [] expr)
655 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
656 tcLookupId fromRationalName `thenM` \ from_rational ->
657 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
658 mkRatLit f `thenM` \ rat_lit ->
659 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
660 (HsVar (instToId method_inst))) rat_lit))
663 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
664 = do { dflags <- getDOpts
665 ; if all tcIsTyVarTy tys &&
666 not (dopt Opt_AllowUndecidableInstances dflags)
667 -- Common special case; no lookup
668 -- NB: tcIsTyVarTy... don't look through newtypes!
669 -- Don't take this short cut if we allow undecidable instances
670 -- because we might have "instance T a where ...".
671 -- [That means we need -fallow-undecidable-instances in the
672 -- client module, as well as the module with the instance decl.]
673 then return NoInstance
676 { pkg_ie <- loadImportedInsts clas tys
677 -- Suck in any instance decls that may be relevant
678 ; tcg_env <- getGblEnv
679 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
680 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
681 (matches, unifs) -> do
682 { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
683 text "unifs" <+> ppr unifs])
684 ; return NoInstance } } } }
685 -- In the case of overlap (multiple matches) we report
686 -- NoInstance here. That has the effect of making the
687 -- context-simplifier return the dict as an irreducible one.
688 -- Then it'll be given to addNoInstanceErrs, which will do another
689 -- lookupInstEnv to get the detailed info about what went wrong.
691 lookupInst (Dict _ _ _) = returnM NoInstance
694 instantiate_dfun tenv dfun_id pred loc
695 = -- Record that this dfun is needed
696 record_dfun_usage dfun_id `thenM_`
698 -- It's possible that not all the tyvars are in
699 -- the substitution, tenv. For example:
700 -- instance C X a => D X where ...
701 -- (presumably there's a functional dependency in class C)
702 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
703 getStage `thenM` \ use_stage ->
704 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
705 (topIdLvl dfun_id) use_stage `thenM_`
707 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
708 mk_ty_arg tv = case lookupSubstEnv tenv tv of
709 Just (DoneTy ty) -> returnM ty
710 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
711 returnM (mkTyVarTy tc_tv)
713 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
715 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
716 (theta, _) = tcSplitPhiTy dfun_rho
717 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
720 returnM (SimpleInst ty_app)
722 newDictsAtLoc loc theta `thenM` \ dicts ->
724 rhs = mkHsDictApp ty_app (map instToId dicts)
726 returnM (GenInst dicts rhs)
728 record_dfun_usage dfun_id
729 | isInternalName dfun_name = return () -- From this module
730 | not (isHomePackageName dfun_name) = return () -- From another package package
731 | otherwise = getGblEnv `thenM` \ tcg_env ->
732 updMutVar (tcg_inst_uses tcg_env)
733 (`addOneToNameSet` idName dfun_id)
735 dfun_name = idName dfun_id
737 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
738 -- Gets both the home-pkg inst env (includes module being compiled)
739 -- and the external-package inst-env
740 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
741 return (tcg_inst_env env, eps_inst_env eps) }
746 %************************************************************************
750 %************************************************************************
753 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
754 a do-expression. We have to find (>>) in the current environment, which is
755 done by the rename. Then we have to check that it has the same type as
756 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
759 (>>) :: HB m n mn => m a -> n b -> mn b
761 So the idea is to generate a local binding for (>>), thus:
763 let then72 :: forall a b. m a -> m b -> m b
764 then72 = ...something involving the user's (>>)...
766 ...the do-expression...
768 Now the do-expression can proceed using then72, which has exactly
771 In fact tcSyntaxName just generates the RHS for then72, because we only
772 want an actual binding in the do-expression case. For literals, we can
773 just use the expression inline.
776 tcSyntaxName :: InstOrigin
777 -> TcType -- Type to instantiate it at
778 -> (Name, LHsExpr Name) -- (Standard name, user name)
779 -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
781 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
782 -- So we do not call it from lookupInst, which is called from tcSimplify
784 tcSyntaxName orig ty (std_nm, L span (HsVar user_nm))
786 = addSrcSpan span (tcStdSyntaxName orig ty std_nm)
788 tcSyntaxName orig ty (std_nm, user_nm_expr)
789 = tcLookupId std_nm `thenM` \ std_id ->
791 -- C.f. newMethodAtLoc
792 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
793 tau1 = substTyWith [tv] [ty] tau
794 -- Actually, the "tau-type" might be a sigma-type in the
795 -- case of locally-polymorphic methods.
797 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
799 -- Check that the user-supplied thing has the
800 -- same type as the standard one
801 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
802 returnM (std_nm, expr)
804 tcStdSyntaxName :: InstOrigin
805 -> TcType -- Type to instantiate it at
806 -> Name -- Standard name
807 -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
809 tcStdSyntaxName orig ty std_nm
810 = newMethodFromName orig ty std_nm `thenM` \ id ->
811 getSrcSpanM `thenM` \ span ->
812 returnM (std_nm, L span (HsVar id))
814 syntaxNameCtxt name orig ty tidy_env
815 = getInstLoc orig `thenM` \ inst_loc ->
817 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
818 ptext SLIT("(needed by a syntactic construct)"),
819 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
820 nest 2 (pprInstLoc inst_loc)]
822 returnM (tidy_env, msg)