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,
19 tcSyntaxName, tcStdSyntaxName,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
25 lookupInst, LookupInstResult(..),
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(..) )
43 import TcHsSyn ( TcExpr, TcId, TcIdSet,
44 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
48 import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
49 import InstEnv ( InstLookupResult(..), lookupInstEnv )
50 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
51 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
53 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
54 SourceType(..), PredType, TyVarDetails(VanillaTv),
55 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
56 tcSplitPhiTy, mkGenTyConApp,
57 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
58 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
59 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
60 isClassPred, isTyVarClassPred, isLinearPred,
61 getClassPredTys, getClassPredTys_maybe, mkPredName,
62 isInheritablePred, isIPPred,
63 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
65 import CoreFVs ( idFreeTyVars )
66 import DataCon ( DataCon,dataConSig )
67 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
68 import PrelInfo ( isStandardClass, isNoDictClass )
69 import Name ( Name, mkMethodOcc, getOccName )
70 import PprType ( pprPred, pprParendType )
71 import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
72 import Literal ( inIntRange )
74 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
75 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
76 import TysWiredIn ( floatDataCon, doubleDataCon )
77 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
78 import BasicTypes( IPName(..), mapIPName, ipNameName )
79 import UniqSupply( uniqsFromSupply )
87 instName :: Inst -> Name
88 instName inst = idName (instToId inst)
90 instToId :: Inst -> TcId
91 instToId (Dict id _ _) = id
92 instToId (Method id _ _ _ _ _) = id
93 instToId (LitInst id _ _ _) = id
95 instLoc (Dict _ _ loc) = loc
96 instLoc (Method _ _ _ _ _ loc) = loc
97 instLoc (LitInst _ _ _ loc) = loc
99 dictPred (Dict _ pred _ ) = pred
100 dictPred inst = pprPanic "dictPred" (ppr inst)
102 getDictClassTys (Dict _ pred _) = getClassPredTys pred
104 -- fdPredsOfInst is used to get predicates that contain functional
105 -- dependencies *or* might do so. The "might do" part is because
106 -- a constraint (C a b) might have a superclass with FDs
107 -- Leaving these in is really important for the call to fdPredsOfInsts
108 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
109 -- which is supposed to be conservative
110 fdPredsOfInst (Dict _ pred _) = [pred]
111 fdPredsOfInst (Method _ _ _ theta _ _) = theta
112 fdPredsOfInst other = [] -- LitInsts etc
114 fdPredsOfInsts :: [Inst] -> [PredType]
115 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
117 isInheritableInst (Dict _ pred _) = isInheritablePred pred
118 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
119 isInheritableInst other = True
122 ipNamesOfInsts :: [Inst] -> [Name]
123 ipNamesOfInst :: Inst -> [Name]
124 -- Get the implicit parameters mentioned by these Insts
125 -- NB: ?x and %x get different Names
126 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
128 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
129 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
130 ipNamesOfInst other = []
132 tyVarsOfInst :: Inst -> TcTyVarSet
133 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
134 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
135 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
136 -- The id might have free type variables; in the case of
137 -- locally-overloaded class methods, for example
140 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
141 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
147 isDict :: Inst -> Bool
148 isDict (Dict _ _ _) = True
151 isClassDict :: Inst -> Bool
152 isClassDict (Dict _ pred _) = isClassPred pred
153 isClassDict other = False
155 isTyVarDict :: Inst -> Bool
156 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
157 isTyVarDict other = False
159 isIPDict :: Inst -> Bool
160 isIPDict (Dict _ pred _) = isIPPred pred
161 isIPDict other = False
163 isMethod :: Inst -> Bool
164 isMethod (Method _ _ _ _ _ _) = True
165 isMethod other = False
167 isMethodFor :: TcIdSet -> Inst -> Bool
168 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
169 isMethodFor ids inst = False
171 isLinearInst :: Inst -> Bool
172 isLinearInst (Dict _ pred _) = isLinearPred pred
173 isLinearInst other = False
174 -- We never build Method Insts that have
175 -- linear implicit paramters in them.
176 -- Hence no need to look for Methods
179 linearInstType :: Inst -> TcType -- %x::t --> t
180 linearInstType (Dict _ (IParam _ ty) _) = ty
183 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
184 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
188 Two predicates which deal with the case where class constraints don't
189 necessarily result in bindings. The first tells whether an @Inst@
190 must be witnessed by an actual binding; the second tells whether an
191 @Inst@ can be generalised over.
194 instBindingRequired :: Inst -> Bool
195 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
196 instBindingRequired 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 (ExprCoFn, 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 (mkCoercion 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 tcInstClassOp inst_loc sel_id tys
328 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
329 rho_ty = ASSERT( length tyvars == length tys )
330 substTyWith tyvars tys rho
331 (preds,tau) = tcSplitPhiTy rho_ty
333 newMethod inst_loc sel_id tys preds tau
335 ---------------------------
336 newMethod inst_loc id tys theta tau
337 = newUnique `thenM` \ new_uniq ->
339 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
340 inst = Method meth_id id tys theta tau inst_loc
341 loc = instLocSrcLoc inst_loc
346 In newOverloadedLit we convert directly to an Int or Integer if we
347 know that's what we want. This may save some time, by not
348 temporarily generating overloaded literals, but it won't catch all
349 cases (the rest are caught in lookupInst).
352 newOverloadedLit :: InstOrigin
356 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
357 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable
358 -- syntax. Reason: tcSyntaxName does unification
359 -- which is very inconvenient in tcSimplify
360 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
361 returnM (HsApp expr (HsLit (HsInteger i)))
363 | Just expr <- shortCutIntLit i expected_ty
367 = newLitInst orig lit expected_ty
369 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
370 | fr /= fromRationalName -- c.f. HsIntegral case
371 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
372 mkRatLit r `thenM` \ rat_lit ->
373 returnM (HsApp expr rat_lit)
375 | Just expr <- shortCutFracLit r expected_ty
379 = newLitInst orig lit expected_ty
381 newLitInst orig lit expected_ty
382 = getInstLoc orig `thenM` \ loc ->
383 newUnique `thenM` \ new_uniq ->
385 lit_inst = LitInst lit_id lit expected_ty loc
386 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
388 extendLIE lit_inst `thenM_`
389 returnM (HsVar (instToId lit_inst))
391 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
393 | isIntTy ty && inIntRange i -- Short cut for Int
394 = Just (HsLit (HsInt i))
395 | isIntegerTy ty -- Short cut for Integer
396 = Just (HsLit (HsInteger i))
397 | otherwise = Nothing
399 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
402 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
404 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
405 | otherwise = Nothing
407 mkRatLit :: Rational -> TcM TcExpr
409 = tcLookupTyCon rationalTyConName `thenM` \ rat_tc ->
411 rational_ty = mkGenTyConApp rat_tc []
413 returnM (HsLit (HsRat r rational_ty))
417 %************************************************************************
421 %************************************************************************
423 Zonking makes sure that the instance types are fully zonked,
424 but doesn't do the same for any of the Ids in an Inst. There's no
425 need, and it's a lot of extra work.
428 zonkInst :: Inst -> TcM Inst
429 zonkInst (Dict id pred loc)
430 = zonkTcPredType pred `thenM` \ new_pred ->
431 returnM (Dict id new_pred loc)
433 zonkInst (Method m id tys theta tau loc)
434 = zonkId id `thenM` \ new_id ->
435 -- Essential to zonk the id in case it's a local variable
436 -- Can't use zonkIdOcc because the id might itself be
437 -- an InstId, in which case it won't be in scope
439 zonkTcTypes tys `thenM` \ new_tys ->
440 zonkTcThetaType theta `thenM` \ new_theta ->
441 zonkTcType tau `thenM` \ new_tau ->
442 returnM (Method m new_id new_tys new_theta new_tau loc)
444 zonkInst (LitInst id lit ty loc)
445 = zonkTcType ty `thenM` \ new_ty ->
446 returnM (LitInst id lit new_ty loc)
448 zonkInsts insts = mappM zonkInst insts
452 %************************************************************************
454 \subsection{Printing}
456 %************************************************************************
458 ToDo: improve these pretty-printing things. The ``origin'' is really only
459 relevant in error messages.
462 instance Outputable Inst where
463 ppr inst = pprInst inst
465 pprInsts :: [Inst] -> SDoc
466 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
469 = vcat (map go insts)
471 go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
473 pprInst (LitInst u lit ty loc)
474 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
476 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
478 pprInst m@(Method u id tys theta tau loc)
479 = hsep [ppr id, ptext SLIT("at"),
480 brackets (sep (map pprParendType tys)) {- ,
481 ptext SLIT("theta"), ppr theta,
482 ptext SLIT("tau"), ppr tau
486 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
488 tidyInst :: TidyEnv -> Inst -> Inst
489 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
490 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
491 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
493 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
494 -- This function doesn't assume that the tyvars are in scope
495 -- so it works like tidyOpenType, returning a TidyEnv
496 tidyMoreInsts env insts
497 = (env', map (tidyInst env') insts)
499 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
501 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
502 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
504 showLIE :: SDoc -> TcM () -- Debugging
506 = do { lie_var <- getLIEVar ;
507 lie <- readMutVar lie_var ;
508 traceTc (str <+> pprInstsInFull (lieToList lie)) }
512 %************************************************************************
514 \subsection{Looking up Insts}
516 %************************************************************************
519 data LookupInstResult s
521 | SimpleInst TcExpr -- Just a variable, type application, or literal
522 | GenInst [Inst] TcExpr -- The expression and its needed insts
524 lookupInst :: Inst -> TcM (LookupInstResult s)
525 -- It's important that lookupInst does not put any new stuff into
526 -- the LIE. Instead, any Insts needed by the lookup are returned in
527 -- the LookupInstResult, where they can be further processed by tcSimplify
531 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
532 = getDOpts `thenM` \ dflags ->
533 tcGetInstEnv `thenM` \ inst_env ->
534 case lookupInstEnv dflags inst_env clas tys of
536 FoundInst tenv dfun_id
537 -> -- It's possible that not all the tyvars are in
538 -- the substitution, tenv. For example:
539 -- instance C X a => D X where ...
540 -- (presumably there's a functional dependency in class C)
541 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
542 getStage `thenM` \ use_stage ->
543 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
544 (topIdLvl dfun_id) use_stage `thenM_`
545 traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
547 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
548 mk_ty_arg tv = case lookupSubstEnv tenv tv of
549 Just (DoneTy ty) -> returnM ty
550 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
551 returnM (mkTyVarTy tc_tv)
553 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
555 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
556 (theta, _) = tcSplitPhiTy dfun_rho
557 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
560 returnM (SimpleInst ty_app)
562 newDictsAtLoc loc theta `thenM` \ dicts ->
564 rhs = mkHsDictApp ty_app (map instToId dicts)
566 returnM (GenInst dicts rhs)
568 other -> returnM NoInstance
570 lookupInst (Dict _ _ _) = returnM NoInstance
574 lookupInst inst@(Method _ id tys theta _ loc)
575 = newDictsAtLoc loc theta `thenM` \ dicts ->
576 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
580 -- Look for short cuts first: if the literal is *definitely* a
581 -- int, integer, float or a double, generate the real thing here.
582 -- This is essential (see nofib/spectral/nucleic).
583 -- [Same shortcut as in newOverloadedLit, but we
584 -- may have done some unification by now]
587 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
588 | Just expr <- shortCutIntLit i ty
589 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
590 -- expr may be a constructor application
592 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
593 tcLookupId fromIntegerName `thenM` \ from_integer ->
594 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
595 returnM (GenInst [method_inst]
596 (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
599 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
600 | Just expr <- shortCutFracLit f ty
601 = returnM (GenInst [] expr)
604 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
605 tcLookupId fromRationalName `thenM` \ from_rational ->
606 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
607 mkRatLit f `thenM` \ rat_lit ->
608 returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
613 %************************************************************************
617 %************************************************************************
620 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
621 a do-expression. We have to find (>>) in the current environment, which is
622 done by the rename. Then we have to check that it has the same type as
623 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
626 (>>) :: HB m n mn => m a -> n b -> mn b
628 So the idea is to generate a local binding for (>>), thus:
630 let then72 :: forall a b. m a -> m b -> m b
631 then72 = ...something involving the user's (>>)...
633 ...the do-expression...
635 Now the do-expression can proceed using then72, which has exactly
638 In fact tcSyntaxName just generates the RHS for then72, because we only
639 want an actual binding in the do-expression case. For literals, we can
640 just use the expression inline.
643 tcSyntaxName :: InstOrigin
644 -> TcType -- Type to instantiate it at
645 -> (Name, HsExpr Name) -- (Standard name, user name)
646 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
648 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
649 -- So we do not call it from lookupInst, which is called from tcSimplify
651 tcSyntaxName orig ty (std_nm, HsVar user_nm)
653 = tcStdSyntaxName orig ty std_nm
655 tcSyntaxName orig ty (std_nm, user_nm_expr)
656 = tcLookupId std_nm `thenM` \ std_id ->
658 -- C.f. newMethodAtLoc
659 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
660 tau1 = substTyWith [tv] [ty] tau
661 -- Actually, the "tau-type" might be a sigma-type in the
662 -- case of locally-polymorphic methods.
664 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
665 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
666 returnM (std_nm, expr)
668 tcStdSyntaxName :: InstOrigin
669 -> TcType -- Type to instantiate it at
670 -> Name -- Standard name
671 -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
673 tcStdSyntaxName orig ty std_nm
674 = newMethodFromName orig ty std_nm `thenM` \ id ->
675 returnM (std_nm, HsVar id)
677 syntaxNameCtxt name orig ty tidy_env
678 = getInstLoc orig `thenM` \ inst_loc ->
680 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
681 ptext SLIT("(needed by a syntactic construct)"),
682 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
683 nest 2 (pprInstLoc inst_loc)]
685 returnM (tidy_env, msg)