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 newOverloadedLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
20 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
21 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
22 instLoc, getDictClassTys, dictPred,
24 lookupInst, lookupSimpleInst, LookupInstResult(..),
26 isDict, isClassDict, isMethod,
27 isLinearInst, linearInstType, isIPDict, isInheritableInst,
28 isTyVarDict, isStdClassTyVarDict, isMethodFor,
29 instBindingRequired, instCanBeGeneralised,
34 InstOrigin(..), InstLoc(..), pprInstLoc
37 #include "HsVersions.h"
39 import {-# SOURCE #-} TcExpr( tcExpr )
41 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
42 import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
43 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
46 import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
47 import InstEnv ( InstLookupResult(..), lookupInstEnv )
48 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
49 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
51 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
52 SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
53 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
54 tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
55 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
56 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
57 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
58 isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
59 getClassPredTys, getClassPredTys_maybe, mkPredName,
60 isInheritablePred, isIPPred,
61 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
63 import CoreFVs ( idFreeTyVars )
64 import Class ( Class )
65 import DataCon ( DataCon,dataConSig )
66 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
67 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
68 import Name ( Name, mkMethodOcc, getOccName )
69 import PprType ( pprPred, pprParendType )
70 import Subst ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
71 import Literal ( inIntRange )
73 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
74 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
75 import TysWiredIn ( floatDataCon, doubleDataCon )
76 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
77 import BasicTypes( IPName(..), mapIPName, ipNameName )
78 import UniqSupply( uniqsFromSupply )
86 instName :: Inst -> Name
87 instName inst = idName (instToId inst)
89 instToId :: Inst -> TcId
90 instToId (Dict id _ _) = id
91 instToId (Method id _ _ _ _ _) = id
92 instToId (LitInst id _ _ _) = id
94 instLoc (Dict _ _ loc) = loc
95 instLoc (Method _ _ _ _ _ loc) = loc
96 instLoc (LitInst _ _ _ loc) = loc
98 dictPred (Dict _ pred _ ) = pred
99 dictPred inst = pprPanic "dictPred" (ppr inst)
101 getDictClassTys (Dict _ pred _) = getClassPredTys pred
103 -- fdPredsOfInst is used to get predicates that contain functional
104 -- dependencies; i.e. should participate in improvement
105 fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
107 fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
108 fdPredsOfInst other = []
110 fdPredsOfInsts :: [Inst] -> [PredType]
111 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
113 isInheritableInst (Dict _ pred _) = isInheritablePred pred
114 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
115 isInheritableInst other = True
118 ipNamesOfInsts :: [Inst] -> [Name]
119 ipNamesOfInst :: Inst -> [Name]
120 -- Get the implicit parameters mentioned by these Insts
121 -- NB: ?x and %x get different Names
122 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
124 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
125 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
126 ipNamesOfInst other = []
128 tyVarsOfInst :: Inst -> TcTyVarSet
129 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
130 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
131 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
132 -- The id might have free type variables; in the case of
133 -- locally-overloaded class methods, for example
136 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
137 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
143 isDict :: Inst -> Bool
144 isDict (Dict _ _ _) = True
147 isClassDict :: Inst -> Bool
148 isClassDict (Dict _ pred _) = isClassPred pred
149 isClassDict other = False
151 isTyVarDict :: Inst -> Bool
152 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
153 isTyVarDict other = False
155 isIPDict :: Inst -> Bool
156 isIPDict (Dict _ pred _) = isIPPred pred
157 isIPDict other = False
159 isMethod :: Inst -> Bool
160 isMethod (Method _ _ _ _ _ _) = True
161 isMethod other = False
163 isMethodFor :: TcIdSet -> Inst -> Bool
164 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
165 isMethodFor ids inst = False
167 isLinearInst :: Inst -> Bool
168 isLinearInst (Dict _ pred _) = isLinearPred pred
169 isLinearInst other = False
170 -- We never build Method Insts that have
171 -- linear implicit paramters in them.
172 -- Hence no need to look for Methods
175 linearInstType :: Inst -> TcType -- %x::t --> t
176 linearInstType (Dict _ (IParam _ ty) _) = ty
179 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
180 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
184 Two predicates which deal with the case where class constraints don't
185 necessarily result in bindings. The first tells whether an @Inst@
186 must be witnessed by an actual binding; the second tells whether an
187 @Inst@ can be generalised over.
190 instBindingRequired :: Inst -> Bool
191 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
192 instBindingRequired other = True
194 instCanBeGeneralised :: Inst -> Bool
195 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
196 instCanBeGeneralised other = True
200 %************************************************************************
202 \subsection{Building dictionaries}
204 %************************************************************************
207 newDicts :: InstOrigin
211 = getInstLoc orig `thenM` \ loc ->
212 newDictsAtLoc loc theta
214 cloneDict :: Inst -> TcM Inst
215 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
216 returnM (Dict (setIdUnique id uniq) ty loc)
218 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
219 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
221 -- Local function, similar to newDicts,
222 -- but with slightly different interface
223 newDictsAtLoc :: InstLoc
226 newDictsAtLoc inst_loc theta
227 = newUniqueSupply `thenM` \ us ->
228 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
230 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
232 loc = instLocSrcLoc inst_loc
234 -- For vanilla implicit parameters, there is only one in scope
235 -- at any time, so we used to use the name of the implicit parameter itself
236 -- But with splittable implicit parameters there may be many in
237 -- scope, so we make up a new name.
238 newIPDict :: InstOrigin -> IPName Name -> Type
239 -> TcM (IPName Id, Inst)
240 newIPDict orig ip_name ty
241 = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) ->
242 newUnique `thenM` \ uniq ->
244 pred = IParam ip_name ty
245 id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
247 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
252 %************************************************************************
254 \subsection{Building methods (calls of overloaded functions)}
256 %************************************************************************
260 tcInstCall :: InstOrigin -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
261 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
262 = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
263 newDicts orig theta `thenM` \ dicts ->
264 extendLIEs dicts `thenM_`
266 inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
268 returnM (inst_fn, tau)
270 tcInstDataCon :: InstOrigin -> DataCon
271 -> TcM ([TcType], -- Types to instantiate at
272 [Inst], -- Existential dictionaries to apply to
273 [TcType], -- Argument types of constructor
274 TcType, -- Result type
275 [TyVar]) -- Existential tyvars
276 tcInstDataCon orig data_con
278 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
279 -- We generate constraints for the stupid theta even when
280 -- pattern matching (as the Report requires)
282 tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
284 stupid_theta' = substTheta tenv stupid_theta
285 ex_theta' = substTheta tenv ex_theta
286 arg_tys' = map (substTy tenv) arg_tys
288 n_normal_tvs = length tvs
289 ex_tvs' = drop n_normal_tvs all_tvs'
290 result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
292 newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
293 newDicts orig ex_theta' `thenM` \ ex_dicts ->
295 -- Note that we return the stupid theta *only* in the LIE;
296 -- we don't otherwise use it at all
297 extendLIEs stupid_dicts `thenM_`
299 returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
301 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
302 newMethodFromName origin ty name
303 = tcLookupId name `thenM` \ id ->
304 -- Use tcLookupId not tcLookupGlobalId; the method is almost
305 -- always a class op, but with -fno-implicit-prelude GHC is
306 -- meant to find whatever thing is in scope, and that may
307 -- be an ordinary function.
308 getInstLoc origin `thenM` \ loc ->
309 tcInstClassOp loc id [ty] `thenM` \ inst ->
310 extendLIE inst `thenM_`
311 returnM (instToId inst)
313 newMethodWithGivenTy orig id tys theta tau
314 = getInstLoc orig `thenM` \ loc ->
315 newMethod loc id tys theta tau `thenM` \ inst ->
316 extendLIE inst `thenM_`
317 returnM (instToId inst)
319 --------------------------------------------
320 -- tcInstClassOp, and newMethod do *not* drop the
321 -- Inst into the LIE; they just returns the Inst
322 -- This is important because they are used by TcSimplify
325 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
326 -- Instantiate the specified class op, but *only* with the main
327 -- class dictionary. For example, given 'op' defined thus:
329 -- op :: (?x :: String) => a -> a
330 -- (tcInstClassOp op T) should return an Inst with type
331 -- (?x :: String) => T -> T
332 -- That is, the class-op's context is still there.
333 -- This is really important in the use of tcInstClassOp in TcClassDcls.mkMethodBind
334 tcInstClassOp inst_loc sel_id tys
336 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
337 rho_ty = substTyWith tyvars tys rho
338 (pred,tau) = tcSplitMethodTy rho_ty
339 -- Split off exactly one predicate (see the example above)
341 ASSERT( isClassPred pred )
342 newMethod inst_loc sel_id tys [pred] tau
344 ---------------------------
345 newMethod inst_loc id tys theta tau
346 = newUnique `thenM` \ new_uniq ->
348 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
349 inst = Method meth_id id tys theta tau inst_loc
350 loc = instLocSrcLoc inst_loc
355 In newOverloadedLit we convert directly to an Int or Integer if we
356 know that's what we want. This may save some time, by not
357 temporarily generating overloaded literals, but it won't catch all
358 cases (the rest are caught in lookupInst).
361 newOverloadedLit :: InstOrigin
365 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
366 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
367 -- syntax. Reason: tcSyntaxName does unification
368 -- which is very inconvenient in tcSimplify
369 = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) ->
370 returnM (HsApp expr (HsLit (HsInteger i)))
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 fr `thenM` \ (expr, _) ->
381 mkRatLit r `thenM` \ rat_lit ->
382 returnM (HsApp expr rat_lit)
384 | Just expr <- shortCutFracLit r expected_ty
388 = newLitInst orig lit expected_ty
390 newLitInst orig lit expected_ty
391 = getInstLoc orig `thenM` \ loc ->
392 newUnique `thenM` \ new_uniq ->
393 zapToType expected_ty `thenM_`
394 -- The expected type might be a 'hole' type variable,
395 -- in which case we must zap it to an ordinary type variable
397 lit_inst = LitInst lit_id lit expected_ty loc
398 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
400 extendLIE lit_inst `thenM_`
401 returnM (HsVar (instToId lit_inst))
403 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
405 | isIntTy ty && inIntRange i -- Short cut for Int
406 = Just (HsLit (HsInt i))
407 | isIntegerTy ty -- Short cut for Integer
408 = Just (HsLit (HsInteger i))
409 | otherwise = Nothing
411 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
414 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
416 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
417 | otherwise = Nothing
419 mkRatLit :: Rational -> TcM TcExpr
421 = tcLookupTyCon rationalTyConName `thenM` \ rat_tc ->
423 rational_ty = mkGenTyConApp rat_tc []
425 returnM (HsLit (HsRat r rational_ty))
429 %************************************************************************
433 %************************************************************************
435 Zonking makes sure that the instance types are fully zonked,
436 but doesn't do the same for any of the Ids in an Inst. There's no
437 need, and it's a lot of extra work.
440 zonkInst :: Inst -> TcM Inst
441 zonkInst (Dict id pred loc)
442 = zonkTcPredType pred `thenM` \ new_pred ->
443 returnM (Dict id new_pred loc)
445 zonkInst (Method m id tys theta tau loc)
446 = zonkId id `thenM` \ new_id ->
447 -- Essential to zonk the id in case it's a local variable
448 -- Can't use zonkIdOcc because the id might itself be
449 -- an InstId, in which case it won't be in scope
451 zonkTcTypes tys `thenM` \ new_tys ->
452 zonkTcThetaType theta `thenM` \ new_theta ->
453 zonkTcType tau `thenM` \ new_tau ->
454 returnM (Method m new_id new_tys new_theta new_tau loc)
456 zonkInst (LitInst id lit ty loc)
457 = zonkTcType ty `thenM` \ new_ty ->
458 returnM (LitInst id lit new_ty loc)
460 zonkInsts insts = mappM zonkInst insts
464 %************************************************************************
466 \subsection{Printing}
468 %************************************************************************
470 ToDo: improve these pretty-printing things. The ``origin'' is really only
471 relevant in error messages.
474 instance Outputable Inst where
475 ppr inst = pprInst inst
477 pprInsts :: [Inst] -> SDoc
478 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
481 = vcat (map go insts)
483 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
485 pprInst (LitInst u lit ty loc)
486 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
488 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
490 pprInst m@(Method u id tys theta tau loc)
491 = hsep [ppr id, ptext SLIT("at"),
492 brackets (sep (map pprParendType tys)) {- ,
493 ptext SLIT("theta"), ppr theta,
494 ptext SLIT("tau"), ppr tau
498 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
500 tidyInst :: TidyEnv -> Inst -> Inst
501 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
502 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
503 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
505 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
506 -- This function doesn't assume that the tyvars are in scope
507 -- so it works like tidyOpenType, returning a TidyEnv
508 tidyMoreInsts env insts
509 = (env', map (tidyInst env') insts)
511 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
513 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
514 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
516 showLIE :: String -> TcM () -- Debugging
518 = do { lie_var <- getLIEVar ;
519 lie <- readMutVar lie_var ;
520 traceTc (text str <+> pprInstsInFull (lieToList lie)) }
524 %************************************************************************
526 \subsection{Looking up Insts}
528 %************************************************************************
531 data LookupInstResult s
533 | SimpleInst TcExpr -- Just a variable, type application, or literal
534 | GenInst [Inst] TcExpr -- The expression and its needed insts
536 lookupInst :: Inst -> TcM (LookupInstResult s)
537 -- It's important that lookupInst does not put any new stuff into
538 -- the LIE. Instead, any Insts needed by the lookup are returned in
539 -- the LookupInstResult, where they can be further processed by tcSimplify
543 lookupInst dict@(Dict _ (ClassP clas tys) loc)
544 = getDOpts `thenM` \ dflags ->
545 tcGetInstEnv `thenM` \ inst_env ->
546 case lookupInstEnv dflags inst_env clas tys of
548 FoundInst tenv dfun_id
549 -> -- It's possible that not all the tyvars are in
550 -- the substitution, tenv. For example:
551 -- instance C X a => D X where ...
552 -- (presumably there's a functional dependency in class C)
553 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
555 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
556 mk_ty_arg tv = case lookupSubstEnv tenv tv of
557 Just (DoneTy ty) -> returnM ty
558 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
559 returnM (mkTyVarTy tc_tv)
561 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
563 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
564 (theta, _) = tcSplitPhiTy dfun_rho
565 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
568 returnM (SimpleInst ty_app)
570 newDictsAtLoc loc theta `thenM` \ dicts ->
572 rhs = mkHsDictApp ty_app (map instToId dicts)
574 returnM (GenInst dicts rhs)
576 other -> returnM NoInstance
578 lookupInst (Dict _ _ _) = returnM NoInstance
582 lookupInst inst@(Method _ id tys theta _ loc)
583 = newDictsAtLoc loc theta `thenM` \ dicts ->
584 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
588 -- Look for short cuts first: if the literal is *definitely* a
589 -- int, integer, float or a double, generate the real thing here.
590 -- This is essential (see nofib/spectral/nucleic).
591 -- [Same shortcut as in newOverloadedLit, but we
592 -- may have done some unification by now]
595 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
596 | Just expr <- shortCutIntLit i ty
597 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
598 -- expr may be a constructor application
600 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
601 tcLookupId fromIntegerName `thenM` \ from_integer ->
602 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
603 returnM (GenInst [method_inst]
604 (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
607 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
608 | Just expr <- shortCutFracLit f ty
609 = returnM (GenInst [] expr)
612 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
613 tcLookupId fromRationalName `thenM` \ from_rational ->
614 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
615 mkRatLit f `thenM` \ rat_lit ->
616 returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
619 There is a second, simpler interface, when you want an instance of a
620 class at a given nullary type constructor. It just returns the
621 appropriate dictionary if it exists. It is used only when resolving
622 ambiguous dictionaries.
625 lookupSimpleInst :: Class
626 -> [Type] -- Look up (c,t)
627 -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s
629 lookupSimpleInst clas tys
630 = getDOpts `thenM` \ dflags ->
631 tcGetInstEnv `thenM` \ inst_env ->
632 case lookupInstEnv dflags inst_env clas tys of
634 -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
636 (_, rho) = tcSplitForAllTys (idType dfun)
637 (theta,_) = tcSplitPhiTy rho
639 other -> returnM Nothing
643 %************************************************************************
647 %************************************************************************
650 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
651 a do-expression. We have to find (>>) in the current environment, which is
652 done by the rename. Then we have to check that it has the same type as
653 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
656 (>>) :: HB m n mn => m a -> n b -> mn b
658 So the idea is to generate a local binding for (>>), thus:
660 let then72 :: forall a b. m a -> m b -> m b
661 then72 = ...something involving the user's (>>)...
663 ...the do-expression...
665 Now the do-expression can proceed using then72, which has exactly
668 In fact tcSyntaxName just generates the RHS for then72, because we only
669 want an actual binding in the do-expression case. For literals, we can
670 just use the expression inline.
673 tcSyntaxName :: InstOrigin
674 -> TcType -- Type to instantiate it at
675 -> Name -> Name -- (Standard name, user name)
676 -> TcM (TcExpr, TcType) -- Suitable expression with its type
678 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
679 -- So we do not call it from lookupInst, which is called from tcSimplify
681 tcSyntaxName orig ty std_nm user_nm
683 = newMethodFromName orig ty std_nm `thenM` \ id ->
684 returnM (HsVar id, idType id)
687 = tcLookupId std_nm `thenM` \ std_id ->
689 -- C.f. newMethodAtLoc
690 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
691 tau1 = substTyWith [tv] [ty] tau
693 addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
694 tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
695 returnM (user_fn, tau1)
697 syntaxNameCtxt name orig ty tidy_env
698 = getInstLoc orig `thenM` \ inst_loc ->
700 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
701 ptext SLIT("(needed by a syntactic construct)"),
702 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
703 nest 2 (pprInstLoc inst_loc)]
705 returnM (tidy_env, msg)