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,
16 newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
17 newMethod, newMethodWithGivenTy, newOverloadedLit,
18 newIPDict, instOverloadedFun,
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 RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
42 import TcHsSyn ( TcExpr, TcId,
43 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
46 import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
47 import TcType ( TcThetaType,
48 TcType, TcTauType, TcTyVarSet,
49 zonkTcTyVars, zonkTcType, zonkTcTypes,
53 import Class ( classInstEnv, Class, FunDep )
54 import FunDeps ( instantiateFdClassTys )
55 import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
56 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
57 import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
58 getOccName, nameUnique )
59 import PprType ( pprPred )
60 import InstEnv ( InstEnv, lookupInstEnv )
61 import SrcLoc ( SrcLoc )
62 import Type ( Type, PredType(..), ThetaType,
63 mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
64 splitForAllTys, splitSigmaTy,
65 splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
66 mkSynTy, tidyOpenType, tidyOpenTypes
68 import InstEnv ( InstEnv )
69 import Subst ( emptyInScopeSet, mkSubst,
70 substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
72 import TyCon ( TyCon )
73 import Literal ( inIntRange )
75 import VarEnv ( lookupVarEnv, TidyEnv,
76 lookupSubstEnv, SubstResult(..)
78 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
79 import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
80 import TysWiredIn ( intDataCon, isIntTy,
81 floatDataCon, isFloatTy,
82 doubleDataCon, isDoubleTy,
83 integerTy, isIntegerTy
85 import Unique ( fromRationalClassOpKey, rationalTyConKey,
86 fromIntClassOpKey, fromIntegerClassOpKey, Unique
88 import Maybes ( expectJust )
89 import Maybe ( catMaybes )
90 import Util ( thenCmp, zipWithEqual, mapAccumL )
94 %************************************************************************
96 \subsection[Inst-collections]{LIE: a collection of Insts}
98 %************************************************************************
103 isEmptyLIE = isEmptyBag
105 unitLIE inst = unitBag inst
106 mkLIE insts = listToBag insts
107 plusLIE lie1 lie2 = lie1 `unionBags` lie2
108 consLIE inst lie = inst `consBag` lie
109 plusLIEs lies = unionManyBags lies
110 lieToList = bagToList
111 listToLIE = listToBag
113 zonkLIE :: LIE -> NF_TcM s LIE
114 zonkLIE lie = mapBagNF_Tc zonkInst lie
116 pprInsts :: [Inst] -> SDoc
117 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
121 = vcat (map go insts)
123 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
126 %************************************************************************
128 \subsection[Inst-types]{@Inst@ types}
130 %************************************************************************
132 An @Inst@ is either a dictionary, an instance of an overloaded
133 literal, or an instance of an overloaded value. We call the latter a
134 ``method'' even though it may not correspond to a class operation.
135 For example, we might have an instance of the @double@ function at
136 type Int, represented by
138 Method 34 doubleId [Int] origin
150 TcId -- The overloaded function
151 -- This function will be a global, local, or ClassOpId;
152 -- inside instance decls (only) it can also be an InstId!
153 -- The id needn't be completely polymorphic.
154 -- You'll probably find its name (for documentation purposes)
155 -- inside the InstOrigin
157 [TcType] -- The types to which its polymorphic tyvars
158 -- should be instantiated.
159 -- These types must saturate the Id's foralls.
161 TcThetaType -- The (types of the) dictionaries to which the function
162 -- must be applied to get the method
164 TcTauType -- The type of the method
168 -- INVARIANT: in (Method u f tys theta tau loc)
169 -- type of (f tys dicts(from theta)) = tau
174 TcType -- The type at which the literal is used
178 Class -- the class from which this arises
183 = OverloadedIntegral Integer -- The number
184 | OverloadedFractional Rational -- The number
189 @Insts@ are ordered by their class/type info, rather than by their
190 unique. This allows the context-reduction mechanism to use standard finite
191 maps to do their stuff.
194 instance Ord Inst where
197 instance Eq Inst where
198 (==) i1 i2 = case i1 `cmpInst` i2 of
202 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
203 cmpInst (Dict _ _ _) other = LT
205 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
206 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
207 cmpInst (Method _ _ _ _ _ _) other = LT
209 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
210 cmpInst (LitInst _ _ _ _) (FunDep _ _ _) = LT
211 cmpInst (LitInst _ _ _ _) other = GT
213 cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
214 cmpInst (FunDep _ _ _) other = GT
216 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
217 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
218 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
219 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
226 instLoc (Dict u pred loc) = loc
227 instLoc (Method u _ _ _ _ loc) = loc
228 instLoc (LitInst u lit ty loc) = loc
229 instLoc (FunDep _ _ loc) = loc
231 getDictPred_maybe (Dict _ p _) = Just p
232 getDictPred_maybe _ = Nothing
234 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
235 getMethodTheta_maybe _ = Nothing
237 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
239 getFunDeps (FunDep clas fds _) = Just (clas, fds)
240 getFunDeps _ = Nothing
242 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
244 getIPsOfPred (IParam n ty) = [(n, ty)]
246 getIPsOfTheta theta = concatMap getIPsOfPred theta
248 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
249 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
252 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
254 getAllFunDeps (FunDep clas fds _) = fds
255 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
257 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
259 tyVarsOfInst :: Inst -> TcTyVarSet
260 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
261 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
262 -- The id might have free type variables; in the case of
263 -- locally-overloaded class methods, for example
264 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
265 tyVarsOfInst (FunDep _ fds _)
266 = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
267 where tyVarsOfFd (ts1, ts2) =
268 tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
271 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
274 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
275 where insts = lieToList lie
281 isDict :: Inst -> Bool
282 isDict (Dict _ _ _) = True
284 isClassDict :: Inst -> Bool
285 isClassDict (Dict _ (Class _ _) _) = True
286 isClassDict other = False
288 isMethod :: Inst -> Bool
289 isMethod (Method _ _ _ _ _ _) = True
290 isMethod other = False
292 isMethodFor :: TcIdSet -> Inst -> Bool
293 isMethodFor ids (Method uniq id tys _ _ loc)
294 = id `elemVarSet` ids
298 isTyVarDict :: Inst -> Bool
299 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
300 isTyVarDict other = False
302 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
303 = isStandardClass clas && isTyVarTy ty
304 isStdClassTyVarDict other
307 notFunDep :: Inst -> Bool
308 notFunDep (FunDep _ _ _) = False
309 notFunDep other = True
312 Two predicates which deal with the case where class constraints don't
313 necessarily result in bindings. The first tells whether an @Inst@
314 must be witnessed by an actual binding; the second tells whether an
315 @Inst@ can be generalised over.
318 instBindingRequired :: Inst -> Bool
319 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
320 instBindingRequired (Dict _ (IParam _ _) _) = False
321 instBindingRequired other = True
323 instCanBeGeneralised :: Inst -> Bool
324 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
325 instCanBeGeneralised other = True
333 newDicts :: InstOrigin
335 -> NF_TcM s (LIE, [TcId])
337 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
338 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
339 returnNF_Tc (listToBag dicts, ids)
341 newClassDicts :: InstOrigin
342 -> [(Class,[TcType])]
343 -> NF_TcM s (LIE, [TcId])
344 newClassDicts orig theta
345 = newDicts orig (map (uncurry Class) theta)
347 -- Local function, similar to newDicts,
348 -- but with slightly different interface
349 newDictsAtLoc :: InstLoc
351 -> NF_TcM s ([Inst], [TcId])
352 newDictsAtLoc loc theta =
353 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
355 mk_dict u pred = Dict u pred loc
356 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
358 returnNF_Tc (dicts, map instToId dicts)
360 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
361 newDictFromOld (Dict _ _ loc) clas tys
362 = tcGetUnique `thenNF_Tc` \ uniq ->
363 returnNF_Tc (Dict uniq (Class clas tys) loc)
366 newMethod :: InstOrigin
369 -> NF_TcM s (LIE, TcId)
370 newMethod orig id tys
371 = -- Get the Id type and instantiate it at the specified types
373 (tyvars, rho) = splitForAllTys (idType id)
374 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
375 (theta, tau) = splitRhoTy rho_ty
377 newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
378 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
380 instOverloadedFun orig v arg_tys theta tau
381 -- This is where we introduce new functional dependencies into the LIE
382 = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
383 instFunDeps orig theta `thenNF_Tc` \ fds ->
384 returnNF_Tc (instToId inst, mkLIE (inst : fds))
386 instFunDeps orig theta
387 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
388 let ifd (Class clas tys) =
389 let fds = instantiateFdClassTys clas tys in
390 if null fds then Nothing else Just (FunDep clas fds loc)
392 in returnNF_Tc (catMaybes (map ifd theta))
394 newMethodWithGivenTy orig id tys theta tau
395 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
396 newMethodWith id tys theta tau loc
398 newMethodWith id tys theta tau loc
399 = tcGetUnique `thenNF_Tc` \ new_uniq ->
400 returnNF_Tc (Method new_uniq id tys theta tau loc)
402 newMethodAtLoc :: InstLoc
404 -> NF_TcM s (Inst, TcId)
405 newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
406 -- slightly different interface
407 = -- Get the Id type and instantiate it at the specified types
408 tcGetUnique `thenNF_Tc` \ new_uniq ->
410 (tyvars,rho) = splitForAllTys (idType real_id)
411 rho_ty = ASSERT( length tyvars == length tys )
412 substTy (mkTopTyVarSubst tyvars tys) rho
413 (theta, tau) = splitRhoTy rho_ty
414 meth_inst = Method new_uniq real_id tys theta tau loc
416 returnNF_Tc (meth_inst, instToId meth_inst)
419 In newOverloadedLit we convert directly to an Int or Integer if we
420 know that's what we want. This may save some time, by not
421 temporarily generating overloaded literals, but it won't catch all
422 cases (the rest are caught in lookupInst).
425 newOverloadedLit :: InstOrigin
428 -> NF_TcM s (TcExpr, LIE)
429 newOverloadedLit orig (OverloadedIntegral i) ty
430 | isIntTy ty && inIntRange i -- Short cut for Int
431 = returnNF_Tc (int_lit, emptyLIE)
433 | isIntegerTy ty -- Short cut for Integer
434 = returnNF_Tc (integer_lit, emptyLIE)
437 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
438 integer_lit = HsLitOut (HsInt i) integerTy
439 int_lit = mkHsConApp intDataCon [] [intprim_lit]
441 newOverloadedLit orig lit ty -- The general case
442 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
443 tcGetUnique `thenNF_Tc` \ new_uniq ->
445 lit_inst = LitInst new_uniq lit ty loc
447 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
451 newIPDict name ty loc
452 = tcGetUnique `thenNF_Tc` \ new_uniq ->
453 let d = Dict new_uniq (IParam name ty) loc in
458 instToId :: Inst -> TcId
459 instToId inst = instToIdBndr inst
461 instToIdBndr :: Inst -> TcId
462 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
463 = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
464 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
467 instToIdBndr (Method u id tys theta tau (_,loc,_))
468 = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
470 instToIdBndr (LitInst u list ty loc)
471 = mkSysLocal SLIT("lit") u ty
473 instToIdBndr (FunDep clas fds _)
474 = panic "FunDep escaped!!!"
477 = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
483 Zonking makes sure that the instance types are fully zonked,
484 but doesn't do the same for the Id in a Method. There's no
485 need, and it's a lot of extra work.
488 zonkPred :: TcPredType -> NF_TcM s TcPredType
489 zonkPred (Class clas tys)
490 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
491 returnNF_Tc (Class clas new_tys)
492 zonkPred (IParam n ty)
493 = zonkTcType ty `thenNF_Tc` \ new_ty ->
494 returnNF_Tc (IParam n new_ty)
496 zonkInst :: Inst -> NF_TcM s Inst
497 zonkInst (Dict u pred loc)
498 = zonkPred pred `thenNF_Tc` \ new_pred ->
499 returnNF_Tc (Dict u new_pred loc)
501 zonkInst (Method u id tys theta tau loc)
502 = zonkId id `thenNF_Tc` \ new_id ->
503 -- Essential to zonk the id in case it's a local variable
504 -- Can't use zonkIdOcc because the id might itself be
505 -- an InstId, in which case it won't be in scope
507 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
508 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
509 zonkTcType tau `thenNF_Tc` \ new_tau ->
510 returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
512 zonkInst (LitInst u lit ty loc)
513 = zonkTcType ty `thenNF_Tc` \ new_ty ->
514 returnNF_Tc (LitInst u lit new_ty loc)
516 zonkInst (FunDep clas fds loc)
517 = zonkFunDeps fds `thenNF_Tc` \ fds' ->
518 returnNF_Tc (FunDep clas fds' loc)
520 zonkPreds preds = mapNF_Tc zonkPred preds
521 zonkInsts insts = mapNF_Tc zonkInst insts
523 zonkFunDeps fds = mapNF_Tc zonkFd fds
526 = zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
527 zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
528 returnNF_Tc (ts1', ts2')
530 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
533 = zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
534 zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
535 returnNF_Tc (tvs1', tvs2')
541 ToDo: improve these pretty-printing things. The ``origin'' is really only
542 relevant in error messages.
545 instance Outputable Inst where
546 ppr inst = pprInst inst
548 pprInst (LitInst u lit ty loc)
550 OverloadedIntegral i -> integer i
551 OverloadedFractional f -> rational f,
556 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
558 pprInst m@(Method u id tys theta tau loc)
559 = hsep [ppr id, ptext SLIT("at"),
560 brackets (interppSP tys) {- ,
565 pprInst (FunDep clas fds loc)
566 = hsep [ppr clas, ppr fds]
568 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
569 tidyPred env (Class clas tys)
570 = (env', Class clas tys')
572 (env', tys') = tidyOpenTypes env tys
573 tidyPred env (IParam n ty)
574 = (env', IParam n ty')
576 (env', ty') = tidyOpenType env ty
578 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
579 tidyInst env (LitInst u lit ty loc)
580 = (env', LitInst u lit ty' loc)
582 (env', ty') = tidyOpenType env ty
584 tidyInst env (Dict u pred loc)
585 = (env', Dict u pred' loc)
587 (env', pred') = tidyPred env pred
589 tidyInst env (Method u id tys theta tau loc)
590 = (env', Method u id tys' theta tau loc)
591 -- Leave theta, tau alone cos we don't print them
593 (env', tys') = tidyOpenTypes env tys
595 -- this case shouldn't arise... (we never print fundeps)
596 tidyInst env fd@(FunDep clas fds loc)
599 tidyInsts env insts = mapAccumL tidyInst env insts
601 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
605 %************************************************************************
607 \subsection[InstEnv-types]{Type declarations}
609 %************************************************************************
612 type InstanceMapper = Class -> InstEnv
615 A @ClassInstEnv@ lives inside a class, and identifies all the instances
616 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
619 There is an important consistency constraint between the @MatchEnv@s
620 in and the dfun @Id@s inside them: the free type variables of the
621 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
622 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
623 contain the following entry:
625 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
627 The "a" in the pattern must be one of the forall'd variables in
631 data LookupInstResult s
633 | SimpleInst TcExpr -- Just a variable, type application, or literal
634 | GenInst [Inst] TcExpr -- The expression and its needed insts
637 -> NF_TcM s (LookupInstResult s)
641 lookupInst dict@(Dict _ (Class clas tys) loc)
642 = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
646 subst = mkSubst (tyVarsOfTypes tys) tenv
647 (tyvars, rho) = splitForAllTys (idType dfun_id)
648 ty_args = map subst_tv tyvars
649 dfun_rho = substTy subst rho
650 (theta, tau) = splitRhoTy dfun_rho
651 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
652 subst_tv tv = case lookupSubstEnv tenv tv of
653 Just (DoneTy ty) -> ty
654 -- tenv should bind all the tyvars
657 returnNF_Tc (SimpleInst ty_app)
659 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
661 rhs = mkHsDictApp ty_app dict_ids
663 returnNF_Tc (GenInst dicts rhs)
665 Nothing -> returnNF_Tc NoInstance
666 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
670 lookupInst inst@(Method _ id tys theta _ loc)
671 = newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
672 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
676 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
677 | isIntTy ty && in_int_range -- Short cut for Int
678 = returnNF_Tc (GenInst [] int_lit)
679 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
681 | isIntegerTy ty -- Short cut for Integer
682 = returnNF_Tc (GenInst [] integer_lit)
684 | in_int_range -- It's overloaded but small enough to fit into an Int
685 = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
686 newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
687 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
689 | otherwise -- Alas, it is overloaded and a big literal!
690 = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
691 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
692 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
694 in_int_range = inIntRange i
695 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
696 integer_lit = HsLitOut (HsInt i) integerTy
697 int_lit = mkHsConApp intDataCon [] [intprim_lit]
699 -- similar idea for overloaded floating point literals: if the literal is
700 -- *definitely* a float or a double, generate the real thing here.
701 -- This is essential (see nofib/spectral/nucleic).
703 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
704 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
705 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
708 = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
710 -- The type Rational isn't wired in so we have to conjure it up
711 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
713 rational_ty = mkSynTy rational_tycon []
714 rational_lit = HsLitOut (HsFrac f) rational_ty
716 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
717 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
720 floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy
721 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
722 doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
723 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
725 -- there are no `instances' of functional dependencies or implicit params
727 lookupInst _ = returnNF_Tc NoInstance
731 There is a second, simpler interface, when you want an instance of a
732 class at a given nullary type constructor. It just returns the
733 appropriate dictionary if it exists. It is used only when resolving
734 ambiguous dictionaries.
737 lookupSimpleInst :: InstEnv
739 -> [Type] -- Look up (c,t)
740 -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
742 lookupSimpleInst class_inst_env clas tys
743 = case lookupInstEnv (ppr clas) class_inst_env tys of
744 Nothing -> returnNF_Tc Nothing
747 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
749 (_, theta, _) = splitSigmaTy (idType dfun)
750 theta' = map (\(Class clas tys) -> (clas,tys)) theta