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, zonkLIE,
9 plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
11 Inst, OverloadedLit(..),
12 pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
14 newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
15 newMethod, newMethodWithGivenTy, newOverloadedLit,
16 newIPDict, instOverloadedFun,
17 instantiateFdClassTys, instFunDeps, instFunDepsOfTheta,
20 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
21 getDictPred_maybe, getMethodTheta_maybe,
22 getFunDeps, getFunDepsOfLIE,
24 getAllFunDeps, getAllFunDepsOfLIE,
26 lookupInst, lookupSimpleInst, LookupInstResult(..),
28 isDict, isClassDict, isMethod,
29 isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
30 instBindingRequired, instCanBeGeneralised,
32 zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
33 instToId, instToIdBndr, ipToId,
35 InstOrigin(..), InstLoc, pprInstLoc
38 #include "HsVersions.h"
40 import HsSyn ( HsLit(..), HsExpr(..) )
41 import TcHsSyn ( TcExpr, TcId,
42 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
45 import TcEnv ( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
46 tcLookupValueByKey, tcLookupTyConByKey
48 import TcType ( TcThetaType,
49 TcType, TcTauType, TcTyVarSet,
50 zonkTcTyVars, zonkTcType, zonkTcTypes,
54 import Class ( Class, FunDep )
55 import FunDeps ( instantiateFdClassTys )
56 import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
57 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
58 import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
59 getOccName, nameUnique )
60 import PprType ( pprPred )
61 import Type ( Type, PredType(..), ThetaType,
62 mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
63 splitForAllTys, splitSigmaTy, funArgTy,
64 splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
65 mkSynTy, tidyOpenType, tidyOpenTypes
67 import Subst ( emptyInScopeSet, mkSubst,
68 substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
70 import Literal ( inIntRange )
71 import VarEnv ( lookupVarEnv, TidyEnv,
72 lookupSubstEnv, SubstResult(..)
74 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
75 import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
76 import TysWiredIn ( intDataCon, isIntTy,
77 floatDataCon, isFloatTy,
78 doubleDataCon, isDoubleTy,
79 integerTy, isIntegerTy,
82 import Unique ( fromRationalClassOpKey, rationalTyConKey,
83 fromIntClassOpKey, fromIntegerClassOpKey, Unique
85 import Maybe ( catMaybes )
86 import Util ( thenCmp, zipWithEqual, mapAccumL )
90 %************************************************************************
92 \subsection[Inst-collections]{LIE: a collection of Insts}
94 %************************************************************************
99 isEmptyLIE = isEmptyBag
101 unitLIE inst = unitBag inst
102 mkLIE insts = listToBag insts
103 plusLIE lie1 lie2 = lie1 `unionBags` lie2
104 consLIE inst lie = inst `consBag` lie
105 plusLIEs lies = unionManyBags lies
106 lieToList = bagToList
107 listToLIE = listToBag
109 zonkLIE :: LIE -> NF_TcM s LIE
110 zonkLIE lie = mapBagNF_Tc zonkInst lie
112 pprInsts :: [Inst] -> SDoc
113 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
117 = vcat (map go insts)
119 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
122 %************************************************************************
124 \subsection[Inst-types]{@Inst@ types}
126 %************************************************************************
128 An @Inst@ is either a dictionary, an instance of an overloaded
129 literal, or an instance of an overloaded value. We call the latter a
130 ``method'' even though it may not correspond to a class operation.
131 For example, we might have an instance of the @double@ function at
132 type Int, represented by
134 Method 34 doubleId [Int] origin
146 TcId -- The overloaded function
147 -- This function will be a global, local, or ClassOpId;
148 -- inside instance decls (only) it can also be an InstId!
149 -- The id needn't be completely polymorphic.
150 -- You'll probably find its name (for documentation purposes)
151 -- inside the InstOrigin
153 [TcType] -- The types to which its polymorphic tyvars
154 -- should be instantiated.
155 -- These types must saturate the Id's foralls.
157 TcThetaType -- The (types of the) dictionaries to which the function
158 -- must be applied to get the method
160 TcTauType -- The type of the method
164 -- INVARIANT: in (Method u f tys theta tau loc)
165 -- type of (f tys dicts(from theta)) = tau
170 TcType -- The type at which the literal is used
175 Class -- the class from which this arises
180 = OverloadedIntegral Integer -- The number
181 | OverloadedFractional Rational -- The number
186 @Insts@ are ordered by their class/type info, rather than by their
187 unique. This allows the context-reduction mechanism to use standard finite
188 maps to do their stuff.
191 instance Ord Inst where
194 instance Eq Inst where
195 (==) i1 i2 = case i1 `cmpInst` i2 of
199 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
200 cmpInst (Dict _ _ _) other = LT
202 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
203 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
204 cmpInst (Method _ _ _ _ _ _) other = LT
206 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
207 cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT
208 cmpInst (LitInst _ _ _ _) other = GT
210 cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
211 cmpInst (FunDep _ _ _ _) other = GT
213 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
214 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
215 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
216 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
223 instLoc (Dict u pred loc) = loc
224 instLoc (Method u _ _ _ _ loc) = loc
225 instLoc (LitInst u lit ty loc) = loc
226 instLoc (FunDep _ _ _ loc) = loc
228 getDictPred_maybe (Dict _ p _) = Just p
229 getDictPred_maybe _ = Nothing
231 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
232 getMethodTheta_maybe _ = Nothing
234 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
236 getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
237 getFunDeps _ = Nothing
239 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
241 getIPsOfPred (IParam n ty) = [(n, ty)]
243 getIPsOfTheta theta = concatMap getIPsOfPred theta
245 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
246 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
249 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
251 getAllFunDeps (FunDep _ clas fds _) = fds
252 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
254 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
256 tyVarsOfInst :: Inst -> TcTyVarSet
257 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
258 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
259 -- The id might have free type variables; in the case of
260 -- locally-overloaded class methods, for example
261 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
262 tyVarsOfInst (FunDep _ _ fds _)
263 = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
264 where tyVarsOfFd (ts1, ts2) =
265 tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
268 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
271 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
272 where insts = lieToList lie
278 isDict :: Inst -> Bool
279 isDict (Dict _ _ _) = True
282 isClassDict :: Inst -> Bool
283 isClassDict (Dict _ (Class _ _) _) = True
284 isClassDict other = False
286 isMethod :: Inst -> Bool
287 isMethod (Method _ _ _ _ _ _) = True
288 isMethod other = False
290 isMethodFor :: TcIdSet -> Inst -> Bool
291 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
292 isMethodFor ids inst = False
294 isTyVarDict :: Inst -> Bool
295 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
296 isTyVarDict other = False
298 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
299 = isStandardClass clas && isTyVarTy ty
300 isStdClassTyVarDict other
303 notFunDep :: Inst -> Bool
304 notFunDep (FunDep _ _ _ _) = False
305 notFunDep other = True
308 Two predicates which deal with the case where class constraints don't
309 necessarily result in bindings. The first tells whether an @Inst@
310 must be witnessed by an actual binding; the second tells whether an
311 @Inst@ can be generalised over.
314 instBindingRequired :: Inst -> Bool
315 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
316 instBindingRequired (Dict _ (IParam _ _) _) = False
317 instBindingRequired other = True
319 instCanBeGeneralised :: Inst -> Bool
320 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
321 instCanBeGeneralised other = True
329 newDicts :: InstOrigin
331 -> NF_TcM s (LIE, [TcId])
333 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
334 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
335 returnNF_Tc (listToBag dicts, ids)
337 newClassDicts :: InstOrigin
338 -> [(Class,[TcType])]
339 -> NF_TcM s (LIE, [TcId])
340 newClassDicts orig theta
341 = newDicts orig (map (uncurry Class) theta)
343 -- Local function, similar to newDicts,
344 -- but with slightly different interface
345 newDictsAtLoc :: InstLoc
347 -> NF_TcM s ([Inst], [TcId])
348 newDictsAtLoc loc theta =
349 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
351 mk_dict u pred = Dict u pred loc
352 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
354 returnNF_Tc (dicts, map instToId dicts)
356 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
357 newDictFromOld (Dict _ _ loc) clas tys
358 = tcGetUnique `thenNF_Tc` \ uniq ->
359 returnNF_Tc (Dict uniq (Class clas tys) loc)
362 newMethod :: InstOrigin
365 -> NF_TcM s (LIE, TcId)
366 newMethod orig id tys
367 = -- Get the Id type and instantiate it at the specified types
369 (tyvars, rho) = splitForAllTys (idType id)
370 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
371 (theta, tau) = splitRhoTy rho_ty
373 newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
374 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
376 instOverloadedFun orig v arg_tys theta tau
377 -- This is where we introduce new functional dependencies into the LIE
378 = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
379 instFunDeps orig theta `thenNF_Tc` \ fds ->
380 returnNF_Tc (instToId inst, mkLIE (inst : fds))
382 instFunDeps orig theta
383 = tcGetUnique `thenNF_Tc` \ uniq ->
384 tcGetInstLoc orig `thenNF_Tc` \ loc ->
385 let ifd (Class clas tys) =
386 let fds = instantiateFdClassTys clas tys in
387 if null fds then Nothing else Just (FunDep uniq clas fds loc)
389 in returnNF_Tc (catMaybes (map ifd theta))
391 instFunDepsOfTheta theta
392 = let ifd (Class clas tys) = instantiateFdClassTys clas tys
393 ifd (IParam n ty) = [([], [ty])]
394 in concat (map ifd theta)
396 newMethodWithGivenTy orig id tys theta tau
397 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
398 newMethodWith id tys theta tau loc
400 newMethodWith id tys theta tau loc
401 = tcGetUnique `thenNF_Tc` \ new_uniq ->
402 returnNF_Tc (Method new_uniq id tys theta tau loc)
404 newMethodAtLoc :: InstLoc
406 -> NF_TcM s (Inst, TcId)
407 newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
408 -- slightly different interface
409 = -- Get the Id type and instantiate it at the specified types
410 tcGetUnique `thenNF_Tc` \ new_uniq ->
412 (tyvars,rho) = splitForAllTys (idType real_id)
413 rho_ty = ASSERT( length tyvars == length tys )
414 substTy (mkTopTyVarSubst tyvars tys) rho
415 (theta, tau) = splitRhoTy rho_ty
416 meth_inst = Method new_uniq real_id tys theta tau loc
418 returnNF_Tc (meth_inst, instToId meth_inst)
421 In newOverloadedLit we convert directly to an Int or Integer if we
422 know that's what we want. This may save some time, by not
423 temporarily generating overloaded literals, but it won't catch all
424 cases (the rest are caught in lookupInst).
427 newOverloadedLit :: InstOrigin
430 -> NF_TcM s (TcExpr, LIE)
431 newOverloadedLit orig (OverloadedIntegral i) ty
432 | isIntTy ty && inIntRange i -- Short cut for Int
433 = returnNF_Tc (int_lit, emptyLIE)
435 | isIntegerTy ty -- Short cut for Integer
436 = returnNF_Tc (integer_lit, emptyLIE)
439 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
440 integer_lit = HsLitOut (HsInt i) integerTy
441 int_lit = mkHsConApp intDataCon [] [intprim_lit]
443 newOverloadedLit orig lit ty -- The general case
444 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
445 tcGetUnique `thenNF_Tc` \ new_uniq ->
447 lit_inst = LitInst new_uniq lit ty loc
449 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
453 newFunDepFromDict dict
455 = tcGetUnique `thenNF_Tc` \ uniq ->
456 let (clas, tys) = getDictClassTys dict
457 fds = instantiateFdClassTys clas tys
458 inst = FunDep uniq clas fds (instLoc dict)
460 if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
462 = returnNF_Tc Nothing
466 newIPDict name ty loc
467 = tcGetUnique `thenNF_Tc` \ new_uniq ->
468 let d = Dict new_uniq (IParam name ty) loc in
473 instToId :: Inst -> TcId
474 instToId inst = instToIdBndr inst
476 instToIdBndr :: Inst -> TcId
477 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
478 = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
479 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
482 instToIdBndr (Method u id tys theta tau (_,loc,_))
483 = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
485 instToIdBndr (LitInst u list ty loc)
486 = mkSysLocal SLIT("lit") u ty
488 instToIdBndr (FunDep u clas fds _)
489 = mkSysLocal SLIT("FunDep") u voidTy
492 = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
498 Zonking makes sure that the instance types are fully zonked,
499 but doesn't do the same for the Id in a Method. There's no
500 need, and it's a lot of extra work.
503 zonkPred :: TcPredType -> NF_TcM s TcPredType
504 zonkPred (Class clas tys)
505 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
506 returnNF_Tc (Class clas new_tys)
507 zonkPred (IParam n ty)
508 = zonkTcType ty `thenNF_Tc` \ new_ty ->
509 returnNF_Tc (IParam n new_ty)
511 zonkInst :: Inst -> NF_TcM s Inst
512 zonkInst (Dict u pred loc)
513 = zonkPred pred `thenNF_Tc` \ new_pred ->
514 returnNF_Tc (Dict u new_pred loc)
516 zonkInst (Method u id tys theta tau loc)
517 = zonkId id `thenNF_Tc` \ new_id ->
518 -- Essential to zonk the id in case it's a local variable
519 -- Can't use zonkIdOcc because the id might itself be
520 -- an InstId, in which case it won't be in scope
522 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
523 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
524 zonkTcType tau `thenNF_Tc` \ new_tau ->
525 returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
527 zonkInst (LitInst u lit ty loc)
528 = zonkTcType ty `thenNF_Tc` \ new_ty ->
529 returnNF_Tc (LitInst u lit new_ty loc)
531 zonkInst (FunDep u clas fds loc)
532 = zonkFunDeps fds `thenNF_Tc` \ fds' ->
533 returnNF_Tc (FunDep u clas fds' loc)
535 zonkPreds preds = mapNF_Tc zonkPred preds
536 zonkInsts insts = mapNF_Tc zonkInst insts
538 zonkFunDeps fds = mapNF_Tc zonkFd fds
541 = zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
542 zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
543 returnNF_Tc (ts1', ts2')
545 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
548 = zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
549 zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
550 returnNF_Tc (tvs1', tvs2')
556 ToDo: improve these pretty-printing things. The ``origin'' is really only
557 relevant in error messages.
560 instance Outputable Inst where
561 ppr inst = pprInst inst
563 pprInst (LitInst u lit ty loc)
565 OverloadedIntegral i -> integer i
566 OverloadedFractional f -> rational f,
571 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
573 pprInst m@(Method u id tys theta tau loc)
574 = hsep [ppr id, ptext SLIT("at"),
575 brackets (interppSP tys) {- ,
580 pprInst (FunDep _ clas fds loc)
581 = hsep [ppr clas, ppr fds]
583 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
584 tidyPred env (Class clas tys)
585 = (env', Class clas tys')
587 (env', tys') = tidyOpenTypes env tys
588 tidyPred env (IParam n ty)
589 = (env', IParam n ty')
591 (env', ty') = tidyOpenType env ty
593 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
594 tidyInst env (LitInst u lit ty loc)
595 = (env', LitInst u lit ty' loc)
597 (env', ty') = tidyOpenType env ty
599 tidyInst env (Dict u pred loc)
600 = (env', Dict u pred' loc)
602 (env', pred') = tidyPred env pred
604 tidyInst env (Method u id tys theta tau loc)
605 = (env', Method u id tys' theta tau loc)
606 -- Leave theta, tau alone cos we don't print them
608 (env', tys') = tidyOpenTypes env tys
610 -- this case shouldn't arise... (we never print fundeps)
611 tidyInst env fd@(FunDep _ clas fds loc)
614 tidyInsts env insts = mapAccumL tidyInst env insts
616 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
620 %************************************************************************
622 \subsection[InstEnv-types]{Type declarations}
624 %************************************************************************
627 data LookupInstResult s
629 | SimpleInst TcExpr -- Just a variable, type application, or literal
630 | GenInst [Inst] TcExpr -- The expression and its needed insts
633 -> NF_TcM s (LookupInstResult s)
637 lookupInst dict@(Dict _ (Class clas tys) loc)
638 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
639 case lookupInstEnv inst_env clas tys of
641 FoundInst tenv dfun_id
643 subst = mkSubst (tyVarsOfTypes tys) tenv
644 (tyvars, rho) = splitForAllTys (idType dfun_id)
645 ty_args = map subst_tv tyvars
646 dfun_rho = substTy subst rho
647 (theta, tau) = splitRhoTy dfun_rho
648 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
649 subst_tv tv = case lookupSubstEnv tenv tv of
650 Just (DoneTy ty) -> ty
651 -- tenv should bind all the tyvars
654 returnNF_Tc (SimpleInst ty_app)
656 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
658 rhs = mkHsDictApp ty_app dict_ids
660 returnNF_Tc (GenInst dicts rhs)
662 other -> returnNF_Tc NoInstance
663 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
667 lookupInst inst@(Method _ id tys theta _ loc)
668 = newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
669 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
673 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
674 | isIntTy ty && in_int_range -- Short cut for Int
675 = returnNF_Tc (GenInst [] int_lit)
676 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
678 | isIntegerTy ty -- Short cut for Integer
679 = returnNF_Tc (GenInst [] integer_lit)
681 | in_int_range -- It's overloaded but small enough to fit into an Int
682 = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
683 newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
684 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
686 | otherwise -- Alas, it is overloaded and a big literal!
687 = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
688 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
689 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
691 in_int_range = inIntRange i
692 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
693 integer_lit = HsLitOut (HsInt i) integerTy
694 int_lit = mkHsConApp intDataCon [] [intprim_lit]
696 -- similar idea for overloaded floating point literals: if the literal is
697 -- *definitely* a float or a double, generate the real thing here.
698 -- This is essential (see nofib/spectral/nucleic).
700 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
701 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
702 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
705 = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
706 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
708 rational_ty = funArgTy (idType method_id)
709 rational_lit = HsLitOut (HsFrac f) rational_ty
711 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
714 floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy
715 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
716 doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
717 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
719 -- there are no `instances' of functional dependencies or implicit params
721 lookupInst _ = returnNF_Tc NoInstance
725 There is a second, simpler interface, when you want an instance of a
726 class at a given nullary type constructor. It just returns the
727 appropriate dictionary if it exists. It is used only when resolving
728 ambiguous dictionaries.
731 lookupSimpleInst :: Class
732 -> [Type] -- Look up (c,t)
733 -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
735 lookupSimpleInst clas tys
736 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
737 case lookupInstEnv inst_env clas tys of
739 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
741 (_, theta, _) = splitSigmaTy (idType dfun)
742 theta' = map (\(Class clas tys) -> (clas,tys)) theta
744 other -> returnNF_Tc Nothing