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, tidyInsts, tidyMoreInsts,
15 newDictsFromOld, newDicts, cloneDict,
16 newMethod, newMethodFromName, newMethodWithGivenTy,
17 newMethodWith, newMethodAtLoc,
18 newOverloadedLit, newIPDict,
19 tcInstCall, tcInstDataCon, tcSyntaxName,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
25 lookupInst, lookupSimpleInst, LookupInstResult(..),
27 isDict, isClassDict, isMethod,
28 isLinearInst, linearInstType, isIPDict, isInheritableInst,
29 isTyVarDict, isStdClassTyVarDict, isMethodFor,
30 instBindingRequired, instCanBeGeneralised,
35 InstOrigin(..), InstLoc, pprInstLoc
38 #include "HsVersions.h"
40 import {-# SOURCE #-} TcExpr( tcExpr )
42 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
43 import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
44 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
47 import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
48 import InstEnv ( InstLookupResult(..), lookupInstEnv )
49 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
50 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
52 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
53 SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
54 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
55 tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
56 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
57 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
58 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
59 isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
60 getClassPredTys, getClassPredTys_maybe, mkPredName,
61 isInheritablePred, isIPPred,
62 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
64 import CoreFVs ( idFreeTyVars )
65 import Class ( Class )
66 import DataCon ( DataCon,dataConSig )
67 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
68 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
69 import Name ( Name, mkMethodOcc, getOccName )
70 import PprType ( pprPred, pprParendType )
71 import Subst ( emptyInScopeSet, mkSubst,
72 substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
74 import Literal ( inIntRange )
76 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
77 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
78 import TysWiredIn ( floatDataCon, doubleDataCon )
79 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
80 import Util ( equalLength )
81 import BasicTypes( IPName(..), mapIPName, ipNameName )
82 import UniqSupply( uniqsFromSupply )
91 instName :: Inst -> Name
92 instName inst = idName (instToId inst)
94 instToId :: Inst -> TcId
95 instToId (Dict id _ _) = id
96 instToId (Method id _ _ _ _ _) = id
97 instToId (LitInst id _ _ _) = id
99 instLoc (Dict _ _ loc) = loc
100 instLoc (Method _ _ _ _ _ loc) = loc
101 instLoc (LitInst _ _ _ loc) = loc
103 dictPred (Dict _ pred _ ) = pred
104 dictPred inst = pprPanic "dictPred" (ppr inst)
106 getDictClassTys (Dict _ pred _) = getClassPredTys pred
108 -- fdPredsOfInst is used to get predicates that contain functional
109 -- dependencies; i.e. should participate in improvement
110 fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
112 fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
113 fdPredsOfInst other = []
115 fdPredsOfInsts :: [Inst] -> [PredType]
116 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
118 isInheritableInst (Dict _ pred _) = isInheritablePred pred
119 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
120 isInheritableInst other = True
123 ipNamesOfInsts :: [Inst] -> [Name]
124 ipNamesOfInst :: Inst -> [Name]
125 -- Get the implicit parameters mentioned by these Insts
126 -- NB: ?x and %x get different Names
127 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
129 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
130 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
131 ipNamesOfInst other = []
133 tyVarsOfInst :: Inst -> TcTyVarSet
134 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
135 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
136 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
137 -- The id might have free type variables; in the case of
138 -- locally-overloaded class methods, for example
141 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
142 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
148 isDict :: Inst -> Bool
149 isDict (Dict _ _ _) = True
152 isClassDict :: Inst -> Bool
153 isClassDict (Dict _ pred _) = isClassPred pred
154 isClassDict other = False
156 isTyVarDict :: Inst -> Bool
157 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
158 isTyVarDict other = False
160 isIPDict :: Inst -> Bool
161 isIPDict (Dict _ pred _) = isIPPred pred
162 isIPDict other = False
164 isMethod :: Inst -> Bool
165 isMethod (Method _ _ _ _ _ _) = True
166 isMethod other = False
168 isMethodFor :: TcIdSet -> Inst -> Bool
169 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
170 isMethodFor ids inst = False
172 isLinearInst :: Inst -> Bool
173 isLinearInst (Dict _ pred _) = isLinearPred pred
174 isLinearInst other = False
175 -- We never build Method Insts that have
176 -- linear implicit paramters in them.
177 -- Hence no need to look for Methods
180 linearInstType :: Inst -> TcType -- %x::t --> t
181 linearInstType (Dict _ (IParam _ ty) _) = ty
184 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
185 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
189 Two predicates which deal with the case where class constraints don't
190 necessarily result in bindings. The first tells whether an @Inst@
191 must be witnessed by an actual binding; the second tells whether an
192 @Inst@ can be generalised over.
195 instBindingRequired :: Inst -> Bool
196 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
197 instBindingRequired other = True
199 instCanBeGeneralised :: Inst -> Bool
200 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
201 instCanBeGeneralised 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@(_,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)) pred inst_loc
237 -- For vanilla implicit parameters, there is only one in scope
238 -- at any time, so we used to use the name of the implicit parameter itself
239 -- But with splittable implicit parameters there may be many in
240 -- scope, so we make up a new name.
241 newIPDict :: InstOrigin -> IPName Name -> Type
242 -> TcM (IPName Id, Inst)
243 newIPDict orig ip_name ty
244 = getInstLoc orig `thenM` \ inst_loc@(_,loc,_) ->
245 newUnique `thenM` \ uniq ->
247 pred = IParam ip_name ty
248 id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
250 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
255 %************************************************************************
257 \subsection{Building methods (calls of overloaded functions)}
259 %************************************************************************
263 tcInstCall :: InstOrigin -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
264 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
265 = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
266 newDicts orig theta `thenM` \ dicts ->
267 extendLIEs dicts `thenM_`
269 inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
271 returnM (inst_fn, tau)
273 tcInstDataCon :: InstOrigin -> DataCon
274 -> TcM ([TcType], -- Types to instantiate at
275 [Inst], -- Existential dictionaries to apply to
276 [TcType], -- Argument types of constructor
277 TcType, -- Result type
278 [TyVar]) -- Existential tyvars
279 tcInstDataCon orig data_con
281 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
282 -- We generate constraints for the stupid theta even when
283 -- pattern matching (as the Report requires)
285 tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
287 stupid_theta' = substTheta tenv stupid_theta
288 ex_theta' = substTheta tenv ex_theta
289 arg_tys' = map (substTy tenv) arg_tys
291 n_normal_tvs = length tvs
292 ex_tvs' = drop n_normal_tvs all_tvs'
293 result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
295 newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
296 newDicts orig ex_theta' `thenM` \ ex_dicts ->
298 -- Note that we return the stupid theta *only* in the LIE;
299 -- we don't otherwise use it at all
300 extendLIEs stupid_dicts `thenM_`
302 returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
305 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
306 newMethodFromName origin ty name
307 = tcLookupId name `thenM` \ id ->
308 -- Use tcLookupId not tcLookupGlobalId; the method is almost
309 -- always a class op, but with -fno-implicit-prelude GHC is
310 -- meant to find whatever thing is in scope, and that may
311 -- be an ordinary function.
312 newMethod origin id [ty] `thenM` \ inst ->
313 returnM (instToId inst)
315 newMethod :: InstOrigin
319 newMethod orig id tys
320 = -- Get the Id type and instantiate it at the specified types
322 (tyvars, rho) = tcSplitForAllTys (idType id)
323 rho_ty = substTyWith tyvars tys rho
324 (pred, tau) = tcSplitMethodTy rho_ty
326 newMethodWithGivenTy orig id tys [pred] tau
328 newMethodWithGivenTy orig id tys theta tau
329 = getInstLoc orig `thenM` \ loc ->
330 newMethodWith loc id tys theta tau `thenM` \ inst ->
331 extendLIE inst `thenM_`
334 --------------------------------------------
335 -- newMethodWith and newMethodAtLoc do *not* drop the
336 -- Inst into the LIE; they just returns the Inst
337 -- This is important because they are used by TcSimplify
340 newMethodWith inst_loc@(_,loc,_) id tys theta tau
341 = newUnique `thenM` \ new_uniq ->
343 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
344 inst = Method meth_id id tys theta tau inst_loc
348 newMethodAtLoc :: InstLoc
351 newMethodAtLoc inst_loc real_id tys
352 -- This actually builds the Inst
353 = -- Get the Id type and instantiate it at the specified types
355 (tyvars,rho) = tcSplitForAllTys (idType real_id)
356 rho_ty = ASSERT( equalLength tyvars tys )
357 substTy (mkTopTyVarSubst tyvars tys) rho
358 (theta, tau) = tcSplitPhiTy rho_ty
360 newMethodWith inst_loc real_id tys theta tau
363 In newOverloadedLit we convert directly to an Int or Integer if we
364 know that's what we want. This may save some time, by not
365 temporarily generating overloaded literals, but it won't catch all
366 cases (the rest are caught in lookupInst).
369 newOverloadedLit :: InstOrigin
373 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
374 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
375 -- syntax. Reason: tcSyntaxName does unification
376 -- which is very inconvenient in tcSimplify
377 = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) ->
378 returnM (HsApp expr (HsLit (HsInteger i)))
380 | Just expr <- shortCutIntLit i expected_ty
384 = newLitInst orig lit expected_ty
386 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
387 | fr /= fromRationalName -- c.f. HsIntegral case
388 = tcSyntaxName orig expected_ty fromRationalName fr `thenM` \ (expr, _) ->
389 mkRatLit r `thenM` \ rat_lit ->
390 returnM (HsApp expr rat_lit)
392 | Just expr <- shortCutFracLit r expected_ty
396 = newLitInst orig lit expected_ty
398 newLitInst orig lit expected_ty
399 = getInstLoc orig `thenM` \ loc ->
400 newUnique `thenM` \ new_uniq ->
401 zapToType expected_ty `thenM_`
402 -- The expected type might be a 'hole' type variable,
403 -- in which case we must zap it to an ordinary type variable
405 lit_inst = LitInst lit_id lit expected_ty loc
406 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
408 extendLIE lit_inst `thenM_`
409 returnM (HsVar (instToId lit_inst))
411 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
413 | isIntTy ty && inIntRange i -- Short cut for Int
414 = Just (HsLit (HsInt i))
415 | isIntegerTy ty -- Short cut for Integer
416 = Just (HsLit (HsInteger i))
417 | otherwise = Nothing
419 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
422 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
424 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
425 | otherwise = Nothing
427 mkRatLit :: Rational -> TcM TcExpr
429 = tcLookupTyCon rationalTyConName `thenM` \ rat_tc ->
431 rational_ty = mkGenTyConApp rat_tc []
433 returnM (HsLit (HsRat r rational_ty))
437 %************************************************************************
441 %************************************************************************
443 Zonking makes sure that the instance types are fully zonked,
444 but doesn't do the same for any of the Ids in an Inst. There's no
445 need, and it's a lot of extra work.
448 zonkInst :: Inst -> TcM Inst
449 zonkInst (Dict id pred loc)
450 = zonkTcPredType pred `thenM` \ new_pred ->
451 returnM (Dict id new_pred loc)
453 zonkInst (Method m id tys theta tau loc)
454 = zonkId id `thenM` \ new_id ->
455 -- Essential to zonk the id in case it's a local variable
456 -- Can't use zonkIdOcc because the id might itself be
457 -- an InstId, in which case it won't be in scope
459 zonkTcTypes tys `thenM` \ new_tys ->
460 zonkTcThetaType theta `thenM` \ new_theta ->
461 zonkTcType tau `thenM` \ new_tau ->
462 returnM (Method m new_id new_tys new_theta new_tau loc)
464 zonkInst (LitInst id lit ty loc)
465 = zonkTcType ty `thenM` \ new_ty ->
466 returnM (LitInst id lit new_ty loc)
468 zonkInsts insts = mappM zonkInst insts
472 %************************************************************************
474 \subsection{Printing}
476 %************************************************************************
478 ToDo: improve these pretty-printing things. The ``origin'' is really only
479 relevant in error messages.
482 instance Outputable Inst where
483 ppr inst = pprInst inst
485 pprInsts :: [Inst] -> SDoc
486 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
489 = vcat (map go insts)
491 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
493 pprInst (LitInst u lit ty loc)
494 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
496 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
498 pprInst m@(Method u id tys theta tau loc)
499 = hsep [ppr id, ptext SLIT("at"),
500 brackets (sep (map pprParendType tys)) {- ,
501 ptext SLIT("theta"), ppr theta,
502 ptext SLIT("tau"), ppr tau
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 :: String -> TcM () -- Debugging
526 = do { lie_var <- getLIEVar ;
527 lie <- readMutVar lie_var ;
528 traceTc (text str <+> pprInstsInFull (lieToList lie)) }
532 %************************************************************************
534 \subsection{Looking up Insts}
536 %************************************************************************
539 data LookupInstResult s
541 | SimpleInst TcExpr -- Just a variable, type application, or literal
542 | GenInst [Inst] TcExpr -- The expression and its needed insts
544 lookupInst :: Inst -> TcM (LookupInstResult s)
545 -- It's important that lookupInst does not put any new stuff into
546 -- the LIE. Instead, any Insts needed by the lookup are returned in
547 -- the LookupInstResult, where they can be further processed by tcSimplify
551 lookupInst dict@(Dict _ (ClassP clas tys) loc)
552 = getDOpts `thenM` \ dflags ->
553 tcGetInstEnv `thenM` \ inst_env ->
554 case lookupInstEnv dflags inst_env clas tys of
556 FoundInst tenv dfun_id
557 -> -- It's possible that not all the tyvars are in
558 -- the substitution, tenv. For example:
559 -- instance C X a => D X where ...
560 -- (presumably there's a functional dependency in class C)
561 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
563 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
564 mk_ty_arg tv = case lookupSubstEnv tenv tv of
565 Just (DoneTy ty) -> returnM ty
566 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
567 returnM (mkTyVarTy tc_tv)
569 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
571 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
572 (theta, _) = tcSplitPhiTy dfun_rho
573 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
576 returnM (SimpleInst ty_app)
578 newDictsAtLoc loc theta `thenM` \ dicts ->
580 rhs = mkHsDictApp ty_app (map instToId dicts)
582 returnM (GenInst dicts rhs)
584 other -> returnM NoInstance
586 lookupInst (Dict _ _ _) = returnM NoInstance
590 lookupInst inst@(Method _ id tys theta _ loc)
591 = newDictsAtLoc loc theta `thenM` \ dicts ->
592 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
596 -- Look for short cuts first: if the literal is *definitely* a
597 -- int, integer, float or a double, generate the real thing here.
598 -- This is essential (see nofib/spectral/nucleic).
599 -- [Same shortcut as in newOverloadedLit, but we
600 -- may have done some unification by now]
603 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
604 | Just expr <- shortCutIntLit i ty
605 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
606 -- expr may be a constructor application
608 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
609 tcLookupId fromIntegerName `thenM` \ from_integer ->
610 newMethodAtLoc loc from_integer [ty] `thenM` \ method_inst ->
611 returnM (GenInst [method_inst]
612 (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
615 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
616 | Just expr <- shortCutFracLit f ty
617 = returnM (GenInst [] expr)
620 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
621 tcLookupId fromRationalName `thenM` \ from_rational ->
622 newMethodAtLoc loc from_rational [ty] `thenM` \ method_inst ->
623 mkRatLit f `thenM` \ rat_lit ->
624 returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
627 There is a second, simpler interface, when you want an instance of a
628 class at a given nullary type constructor. It just returns the
629 appropriate dictionary if it exists. It is used only when resolving
630 ambiguous dictionaries.
633 lookupSimpleInst :: Class
634 -> [Type] -- Look up (c,t)
635 -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s
637 lookupSimpleInst clas tys
638 = getDOpts `thenM` \ dflags ->
639 tcGetInstEnv `thenM` \ inst_env ->
640 case lookupInstEnv dflags inst_env clas tys of
642 -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
644 (_, rho) = tcSplitForAllTys (idType dfun)
645 (theta,_) = tcSplitPhiTy rho
647 other -> returnM Nothing
651 %************************************************************************
655 %************************************************************************
658 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
659 a do-expression. We have to find (>>) in the current environment, which is
660 done by the rename. Then we have to check that it has the same type as
661 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
664 (>>) :: HB m n mn => m a -> n b -> mn b
666 So the idea is to generate a local binding for (>>), thus:
668 let then72 :: forall a b. m a -> m b -> m b
669 then72 = ...something involving the user's (>>)...
671 ...the do-expression...
673 Now the do-expression can proceed using then72, which has exactly
676 In fact tcSyntaxName just generates the RHS for then72, because we only
677 want an actual binding in the do-expression case. For literals, we can
678 just use the expression inline.
681 tcSyntaxName :: InstOrigin
682 -> TcType -- Type to instantiate it at
683 -> Name -> Name -- (Standard name, user name)
684 -> TcM (TcExpr, TcType) -- Suitable expression with its type
686 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
687 -- So we do not call it from lookupInst, which is called from tcSimplify
689 tcSyntaxName orig ty std_nm user_nm
691 = newMethodFromName orig ty std_nm `thenM` \ id ->
692 returnM (HsVar id, idType id)
695 = tcLookupId std_nm `thenM` \ std_id ->
697 -- C.f. newMethodAtLoc
698 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
699 tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau
701 addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
702 tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
703 returnM (user_fn, tau1)
705 syntaxNameCtxt name orig ty tidy_env
706 = getInstLoc orig `thenM` \ inst_loc ->
708 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
709 ptext SLIT("(needed by a syntactic construct)"),
710 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
711 nest 2 (pprInstLoc inst_loc)]
713 returnM (tidy_env, msg)