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, 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( tcCheckSigma )
41 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
42 import TcHsSyn ( TcExpr, TcId, TcIdSet,
43 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
47 import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
48 import InstEnv ( InstLookupResult(..), lookupInstEnv )
49 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
50 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
52 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
53 SourceType(..), PredType, TyVarDetails(VanillaTv),
54 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
55 tcSplitPhiTy, mkGenTyConApp,
56 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
57 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
58 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
59 isClassPred, isTyVarClassPred, isLinearPred,
60 getClassPredTys, getClassPredTys_maybe, mkPredName,
61 isInheritablePred, isIPPred,
62 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
64 import CoreFVs ( idFreeTyVars )
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 ( 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 *or* might do so. The "might do" part is because
105 -- a constraint (C a b) might have a superclass with FDs
106 -- Leaving these in is really important for the call to fdPredsOfInsts
107 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
108 -- which is supposed to be conservative
109 fdPredsOfInst (Dict _ pred _) = [pred]
110 fdPredsOfInst (Method _ _ _ theta _ _) = theta
111 fdPredsOfInst other = [] -- LitInsts etc
113 fdPredsOfInsts :: [Inst] -> [PredType]
114 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
116 isInheritableInst (Dict _ pred _) = isInheritablePred pred
117 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
118 isInheritableInst other = True
121 ipNamesOfInsts :: [Inst] -> [Name]
122 ipNamesOfInst :: Inst -> [Name]
123 -- Get the implicit parameters mentioned by these Insts
124 -- NB: ?x and %x get different Names
125 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
127 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
128 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
129 ipNamesOfInst other = []
131 tyVarsOfInst :: Inst -> TcTyVarSet
132 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
133 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
134 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
135 -- The id might have free type variables; in the case of
136 -- locally-overloaded class methods, for example
139 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
140 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
146 isDict :: Inst -> Bool
147 isDict (Dict _ _ _) = True
150 isClassDict :: Inst -> Bool
151 isClassDict (Dict _ pred _) = isClassPred pred
152 isClassDict other = False
154 isTyVarDict :: Inst -> Bool
155 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
156 isTyVarDict other = False
158 isIPDict :: Inst -> Bool
159 isIPDict (Dict _ pred _) = isIPPred pred
160 isIPDict other = False
162 isMethod :: Inst -> Bool
163 isMethod (Method _ _ _ _ _ _) = True
164 isMethod other = False
166 isMethodFor :: TcIdSet -> Inst -> Bool
167 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
168 isMethodFor ids inst = False
170 isLinearInst :: Inst -> Bool
171 isLinearInst (Dict _ pred _) = isLinearPred pred
172 isLinearInst other = False
173 -- We never build Method Insts that have
174 -- linear implicit paramters in them.
175 -- Hence no need to look for Methods
178 linearInstType :: Inst -> TcType -- %x::t --> t
179 linearInstType (Dict _ (IParam _ ty) _) = ty
182 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
183 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
187 Two predicates which deal with the case where class constraints don't
188 necessarily result in bindings. The first tells whether an @Inst@
189 must be witnessed by an actual binding; the second tells whether an
190 @Inst@ can be generalised over.
193 instBindingRequired :: Inst -> Bool
194 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
195 instBindingRequired other = True
197 instCanBeGeneralised :: Inst -> Bool
198 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
199 instCanBeGeneralised other = True
203 %************************************************************************
205 \subsection{Building dictionaries}
207 %************************************************************************
210 newDicts :: InstOrigin
214 = getInstLoc orig `thenM` \ loc ->
215 newDictsAtLoc loc theta
217 cloneDict :: Inst -> TcM Inst
218 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
219 returnM (Dict (setIdUnique id uniq) ty loc)
221 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
222 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
224 -- Local function, similar to newDicts,
225 -- but with slightly different interface
226 newDictsAtLoc :: InstLoc
229 newDictsAtLoc inst_loc theta
230 = newUniqueSupply `thenM` \ us ->
231 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
233 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
235 loc = instLocSrcLoc 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@(InstLoc _ 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 (ExprCoFn, 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 (mkCoercion 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')
304 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
305 newMethodFromName origin ty name
306 = tcLookupId name `thenM` \ id ->
307 -- Use tcLookupId not tcLookupGlobalId; the method is almost
308 -- always a class op, but with -fno-implicit-prelude GHC is
309 -- meant to find whatever thing is in scope, and that may
310 -- be an ordinary function.
311 getInstLoc origin `thenM` \ loc ->
312 tcInstClassOp loc id [ty] `thenM` \ inst ->
313 extendLIE inst `thenM_`
314 returnM (instToId inst)
316 newMethodWithGivenTy orig id tys theta tau
317 = getInstLoc orig `thenM` \ loc ->
318 newMethod loc id tys theta tau `thenM` \ inst ->
319 extendLIE inst `thenM_`
320 returnM (instToId inst)
322 --------------------------------------------
323 -- tcInstClassOp, and newMethod do *not* drop the
324 -- Inst into the LIE; they just returns the Inst
325 -- This is important because they are used by TcSimplify
328 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
329 tcInstClassOp inst_loc sel_id tys
331 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
332 rho_ty = ASSERT( length tyvars == length tys )
333 substTyWith tyvars tys rho
334 (preds,tau) = tcSplitPhiTy rho_ty
336 newMethod inst_loc sel_id tys preds tau
338 ---------------------------
339 newMethod inst_loc id tys theta tau
340 = newUnique `thenM` \ new_uniq ->
342 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
343 inst = Method meth_id id tys theta tau inst_loc
344 loc = instLocSrcLoc inst_loc
349 In newOverloadedLit we convert directly to an Int or Integer if we
350 know that's what we want. This may save some time, by not
351 temporarily generating overloaded literals, but it won't catch all
352 cases (the rest are caught in lookupInst).
355 newOverloadedLit :: InstOrigin
359 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
360 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
361 -- syntax. Reason: tcSyntaxName does unification
362 -- which is very inconvenient in tcSimplify
363 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
364 returnM (HsApp expr (HsLit (HsInteger i)))
366 | Just expr <- shortCutIntLit i expected_ty
370 = newLitInst orig lit expected_ty
372 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
373 | fr /= fromRationalName -- c.f. HsIntegral case
374 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
375 mkRatLit r `thenM` \ rat_lit ->
376 returnM (HsApp expr rat_lit)
378 | Just expr <- shortCutFracLit r expected_ty
382 = newLitInst orig lit expected_ty
384 newLitInst orig lit expected_ty
385 = getInstLoc orig `thenM` \ loc ->
386 newUnique `thenM` \ new_uniq ->
388 lit_inst = LitInst lit_id lit expected_ty loc
389 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
391 extendLIE lit_inst `thenM_`
392 returnM (HsVar (instToId lit_inst))
394 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
396 | isIntTy ty && inIntRange i -- Short cut for Int
397 = Just (HsLit (HsInt i))
398 | isIntegerTy ty -- Short cut for Integer
399 = Just (HsLit (HsInteger i))
400 | otherwise = Nothing
402 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
405 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
407 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
408 | otherwise = Nothing
410 mkRatLit :: Rational -> TcM TcExpr
412 = tcLookupTyCon rationalTyConName `thenM` \ rat_tc ->
414 rational_ty = mkGenTyConApp rat_tc []
416 returnM (HsLit (HsRat r rational_ty))
420 %************************************************************************
424 %************************************************************************
426 Zonking makes sure that the instance types are fully zonked,
427 but doesn't do the same for any of the Ids in an Inst. There's no
428 need, and it's a lot of extra work.
431 zonkInst :: Inst -> TcM Inst
432 zonkInst (Dict id pred loc)
433 = zonkTcPredType pred `thenM` \ new_pred ->
434 returnM (Dict id new_pred loc)
436 zonkInst (Method m id tys theta tau loc)
437 = zonkId id `thenM` \ new_id ->
438 -- Essential to zonk the id in case it's a local variable
439 -- Can't use zonkIdOcc because the id might itself be
440 -- an InstId, in which case it won't be in scope
442 zonkTcTypes tys `thenM` \ new_tys ->
443 zonkTcThetaType theta `thenM` \ new_theta ->
444 zonkTcType tau `thenM` \ new_tau ->
445 returnM (Method m new_id new_tys new_theta new_tau loc)
447 zonkInst (LitInst id lit ty loc)
448 = zonkTcType ty `thenM` \ new_ty ->
449 returnM (LitInst id lit new_ty loc)
451 zonkInsts insts = mappM zonkInst insts
455 %************************************************************************
457 \subsection{Printing}
459 %************************************************************************
461 ToDo: improve these pretty-printing things. The ``origin'' is really only
462 relevant in error messages.
465 instance Outputable Inst where
466 ppr inst = pprInst inst
468 pprInsts :: [Inst] -> SDoc
469 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
472 = vcat (map go insts)
474 go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
476 pprInst (LitInst u lit ty loc)
477 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
479 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
481 pprInst m@(Method u id tys theta tau loc)
482 = hsep [ppr id, ptext SLIT("at"),
483 brackets (sep (map pprParendType tys)) {- ,
484 ptext SLIT("theta"), ppr theta,
485 ptext SLIT("tau"), ppr tau
489 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
491 tidyInst :: TidyEnv -> Inst -> Inst
492 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
493 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
494 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
496 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
497 -- This function doesn't assume that the tyvars are in scope
498 -- so it works like tidyOpenType, returning a TidyEnv
499 tidyMoreInsts env insts
500 = (env', map (tidyInst env') insts)
502 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
504 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
505 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
507 showLIE :: SDoc -> TcM () -- Debugging
509 = do { lie_var <- getLIEVar ;
510 lie <- readMutVar lie_var ;
511 traceTc (str <+> pprInstsInFull (lieToList lie)) }
515 %************************************************************************
517 \subsection{Looking up Insts}
519 %************************************************************************
522 data LookupInstResult s
524 | SimpleInst TcExpr -- Just a variable, type application, or literal
525 | GenInst [Inst] TcExpr -- The expression and its needed insts
527 lookupInst :: Inst -> TcM (LookupInstResult s)
528 -- It's important that lookupInst does not put any new stuff into
529 -- the LIE. Instead, any Insts needed by the lookup are returned in
530 -- the LookupInstResult, where they can be further processed by tcSimplify
534 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
535 = getDOpts `thenM` \ dflags ->
536 tcGetInstEnv `thenM` \ inst_env ->
537 case lookupInstEnv dflags inst_env clas tys of
539 FoundInst tenv dfun_id
540 -> -- It's possible that not all the tyvars are in
541 -- the substitution, tenv. For example:
542 -- instance C X a => D X where ...
543 -- (presumably there's a functional dependency in class C)
544 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
545 getStage `thenM` \ use_stage ->
546 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
547 (topIdLvl dfun_id) use_stage `thenM_`
548 traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
550 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
551 mk_ty_arg tv = case lookupSubstEnv tenv tv of
552 Just (DoneTy ty) -> returnM ty
553 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
554 returnM (mkTyVarTy tc_tv)
556 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
558 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
559 (theta, _) = tcSplitPhiTy dfun_rho
560 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
563 returnM (SimpleInst ty_app)
565 newDictsAtLoc loc theta `thenM` \ dicts ->
567 rhs = mkHsDictApp ty_app (map instToId dicts)
569 returnM (GenInst dicts rhs)
571 other -> returnM NoInstance
573 lookupInst (Dict _ _ _) = returnM NoInstance
577 lookupInst inst@(Method _ id tys theta _ loc)
578 = newDictsAtLoc loc theta `thenM` \ dicts ->
579 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
583 -- Look for short cuts first: if the literal is *definitely* a
584 -- int, integer, float or a double, generate the real thing here.
585 -- This is essential (see nofib/spectral/nucleic).
586 -- [Same shortcut as in newOverloadedLit, but we
587 -- may have done some unification by now]
590 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
591 | Just expr <- shortCutIntLit i ty
592 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
593 -- expr may be a constructor application
595 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
596 tcLookupId fromIntegerName `thenM` \ from_integer ->
597 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
598 returnM (GenInst [method_inst]
599 (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
602 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
603 | Just expr <- shortCutFracLit f ty
604 = returnM (GenInst [] expr)
607 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
608 tcLookupId fromRationalName `thenM` \ from_rational ->
609 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
610 mkRatLit f `thenM` \ rat_lit ->
611 returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
616 %************************************************************************
620 %************************************************************************
623 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
624 a do-expression. We have to find (>>) in the current environment, which is
625 done by the rename. Then we have to check that it has the same type as
626 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
629 (>>) :: HB m n mn => m a -> n b -> mn b
631 So the idea is to generate a local binding for (>>), thus:
633 let then72 :: forall a b. m a -> m b -> m b
634 then72 = ...something involving the user's (>>)...
636 ...the do-expression...
638 Now the do-expression can proceed using then72, which has exactly
641 In fact tcSyntaxName just generates the RHS for then72, because we only
642 want an actual binding in the do-expression case. For literals, we can
643 just use the expression inline.
646 tcSyntaxName :: InstOrigin
647 -> TcType -- Type to instantiate it at
648 -> (Name, HsExpr Name) -- (Standard name, user name)
649 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
651 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
652 -- So we do not call it from lookupInst, which is called from tcSimplify
654 tcSyntaxName orig ty (std_nm, HsVar user_nm)
656 = newMethodFromName orig ty std_nm `thenM` \ id ->
657 returnM (std_nm, HsVar id)
659 tcSyntaxName orig ty (std_nm, user_nm_expr)
660 = tcLookupId std_nm `thenM` \ std_id ->
662 -- C.f. newMethodAtLoc
663 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
664 tau1 = substTyWith [tv] [ty] tau
665 -- Actually, the "tau-type" might be a sigma-type in the
666 -- case of locally-polymorphic methods.
668 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
669 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
670 returnM (std_nm, expr)
672 syntaxNameCtxt name orig ty tidy_env
673 = getInstLoc orig `thenM` \ inst_loc ->
675 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
676 ptext SLIT("(needed by a syntactic construct)"),
677 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
678 nest 2 (pprInstLoc inst_loc)]
680 returnM (tidy_env, msg)