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 getFunDeps, getFunDepsOfLIE,
23 getAllFunDeps, getAllFunDepsOfLIE,
26 lookupInst, lookupSimpleInst, LookupInstResult(..),
28 isDict, isClassDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
29 instBindingRequired, instCanBeGeneralised,
31 zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
32 instToId, instToIdBndr, ipToId,
34 InstOrigin(..), InstLoc, pprInstLoc
37 #include "HsVersions.h"
39 import HsSyn ( HsLit(..), HsExpr(..) )
40 import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
41 import TcHsSyn ( TcExpr, TcId,
42 mkHsTyApp, mkHsDictApp, zonkId
45 import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
46 import TcType ( TcThetaType,
47 TcType, TcTauType, TcTyVarSet,
48 zonkTcTyVars, zonkTcType, zonkTcTypes,
52 import Class ( classInstEnv, Class )
53 import FunDeps ( instantiateFdClassTys )
54 import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
55 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
56 import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
57 getOccName, nameUnique )
58 import PprType ( pprPred )
59 import InstEnv ( InstEnv, lookupInstEnv )
60 import SrcLoc ( SrcLoc )
61 import Type ( Type, PredType(..), ThetaType,
62 mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
63 splitForAllTys, splitSigmaTy,
64 splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
65 mkSynTy, tidyOpenType, tidyOpenTypes
67 import InstEnv ( InstEnv )
68 import Subst ( emptyInScopeSet, mkSubst,
69 substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
71 import TyCon ( TyCon )
73 import VarEnv ( lookupVarEnv, TidyEnv,
74 lookupSubstEnv, SubstResult(..)
76 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
77 import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
78 import TysWiredIn ( intDataCon, isIntTy, inIntRange,
79 floatDataCon, isFloatTy,
80 doubleDataCon, isDoubleTy,
81 integerTy, isIntegerTy
83 import Unique ( fromRationalClassOpKey, rationalTyConKey,
84 fromIntClassOpKey, fromIntegerClassOpKey, Unique
86 import Maybes ( expectJust )
87 import List ( partition )
88 import Maybe ( catMaybes )
89 import Util ( thenCmp, zipWithEqual, mapAccumL )
93 %************************************************************************
95 \subsection[Inst-collections]{LIE: a collection of Insts}
97 %************************************************************************
102 isEmptyLIE = isEmptyBag
104 unitLIE inst = unitBag inst
105 mkLIE insts = listToBag insts
106 plusLIE lie1 lie2 = lie1 `unionBags` lie2
107 consLIE inst lie = inst `consBag` lie
108 plusLIEs lies = unionManyBags lies
109 lieToList = bagToList
110 listToLIE = listToBag
112 zonkLIE :: LIE -> NF_TcM s LIE
113 zonkLIE lie = mapBagNF_Tc zonkInst lie
115 pprInsts :: [Inst] -> SDoc
116 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
120 = vcat (map go insts)
122 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
125 %************************************************************************
127 \subsection[Inst-types]{@Inst@ types}
129 %************************************************************************
131 An @Inst@ is either a dictionary, an instance of an overloaded
132 literal, or an instance of an overloaded value. We call the latter a
133 ``method'' even though it may not correspond to a class operation.
134 For example, we might have an instance of the @double@ function at
135 type Int, represented by
137 Method 34 doubleId [Int] origin
149 TcId -- The overloaded function
150 -- This function will be a global, local, or ClassOpId;
151 -- inside instance decls (only) it can also be an InstId!
152 -- The id needn't be completely polymorphic.
153 -- You'll probably find its name (for documentation purposes)
154 -- inside the InstOrigin
156 [TcType] -- The types to which its polymorphic tyvars
157 -- should be instantiated.
158 -- These types must saturate the Id's foralls.
160 TcThetaType -- The (types of the) dictionaries to which the function
161 -- must be applied to get the method
163 TcTauType -- The type of the method
167 -- INVARIANT: in (Method u f tys theta tau loc)
168 -- type of (f tys dicts(from theta)) = tau
173 TcType -- The type at which the literal is used
177 Class -- the class from which this arises
178 [([TcType], [TcType])]
182 = OverloadedIntegral Integer -- The number
183 | OverloadedFractional Rational -- The number
188 @Insts@ are ordered by their class/type info, rather than by their
189 unique. This allows the context-reduction mechanism to use standard finite
190 maps to do their stuff.
193 instance Ord Inst where
195 instance Ord PredType where
198 instance Eq Inst where
199 (==) i1 i2 = case i1 `cmpInst` i2 of
202 instance Eq PredType where
203 (==) p1 p2 = case p1 `cmpPred` p2 of
207 cmpInst (Dict _ pred1 _) (Dict _ pred2 _)
208 = (pred1 `cmpPred` pred2)
209 cmpInst (Dict _ _ _) other
212 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _)
214 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
215 = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
216 cmpInst (Method _ _ _ _ _ _) other
219 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
220 = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
221 cmpInst (LitInst _ _ _ _) (FunDep _ _ _)
223 cmpInst (LitInst _ _ _ _) other
226 cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _)
227 = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
228 cmpInst (FunDep _ _ _) other
231 cmpPred (Class c1 tys1) (Class c2 tys2)
232 = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2)
233 cmpPred (IParam n1 ty1) (IParam n2 ty2)
234 = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2)
235 cmpPred (Class _ _) (IParam _ _) = LT
238 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
239 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
240 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
241 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
248 instLoc (Dict u pred loc) = loc
249 instLoc (Method u _ _ _ _ loc) = loc
250 instLoc (LitInst u lit ty loc) = loc
251 instLoc (FunDep _ _ loc) = loc
253 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
255 getFunDeps (FunDep clas fds _) = Just (clas, fds)
256 getFunDeps _ = Nothing
258 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
260 getIPsOfPred (IParam n ty) = [(n, ty)]
262 getIPsOfTheta theta = concatMap getIPsOfPred theta
264 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
265 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
268 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
270 getAllFunDeps (FunDep clas fds _) = fds
271 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
273 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
275 partitionLIEbyMeth pred lie
276 = foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts
277 where insts = lieToList lie
279 partMethod pred (ips, lie) m@(Method u id tys theta tau loc)
281 returnTc (ips, consLIE m lie)
282 else if null theta_ then
283 returnTc (consLIE m ips, lie)
285 newMethodWith id tys theta_ tau loc `thenTc` \ new_m2 ->
286 let id_m1 = instToIdBndr new_m2
287 new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in
288 -- newMethodWith id_m1 tys ips_ tau loc `thenTc` \ new_m1 ->
289 returnTc (consLIE new_m1 ips, consLIE new_m2 lie)
290 where (ips_, theta_) = partition pred theta
291 partMethod pred (ips, lie) inst@(LitInst u lit ty loc)
292 = returnTc (ips, consLIE inst lie)
294 tyVarsOfInst :: Inst -> TcTyVarSet
295 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
296 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
297 -- The id might have free type variables; in the case of
298 -- locally-overloaded class methods, for example
299 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
300 tyVarsOfInst (FunDep _ fds _)
301 = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
302 where tyVarsOfFd (ts1, ts2) =
303 tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
306 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
309 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
310 where insts = lieToList lie
316 isDict :: Inst -> Bool
317 isDict (Dict _ _ _) = True
319 isClassDict :: Inst -> Bool
320 isClassDict (Dict _ (Class _ _) _) = True
321 isClassDict other = False
323 isMethodFor :: TcIdSet -> Inst -> Bool
324 isMethodFor ids (Method uniq id tys _ _ loc)
325 = id `elemVarSet` ids
329 isTyVarDict :: Inst -> Bool
330 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
331 isTyVarDict other = False
333 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
334 = isStandardClass clas && isTyVarTy ty
335 isStdClassTyVarDict other
338 notFunDep :: Inst -> Bool
339 notFunDep (FunDep _ _ _) = False
340 notFunDep other = True
343 Two predicates which deal with the case where class constraints don't
344 necessarily result in bindings. The first tells whether an @Inst@
345 must be witnessed by an actual binding; the second tells whether an
346 @Inst@ can be generalised over.
349 instBindingRequired :: Inst -> Bool
350 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
351 instBindingRequired (Dict _ (IParam _ _) _) = False
352 instBindingRequired other = True
354 instCanBeGeneralised :: Inst -> Bool
355 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
356 instCanBeGeneralised other = True
364 newDicts :: InstOrigin
366 -> NF_TcM s (LIE, [TcId])
368 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
369 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
370 returnNF_Tc (listToBag dicts, ids)
372 newClassDicts :: InstOrigin
373 -> [(Class,[TcType])]
374 -> NF_TcM s (LIE, [TcId])
375 newClassDicts orig theta
376 = newDicts orig (map (uncurry Class) theta)
378 -- Local function, similar to newDicts,
379 -- but with slightly different interface
380 newDictsAtLoc :: InstLoc
382 -> NF_TcM s ([Inst], [TcId])
383 newDictsAtLoc loc theta =
384 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
386 mk_dict u pred = Dict u pred loc
387 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
389 returnNF_Tc (dicts, map instToId dicts)
391 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
392 newDictFromOld (Dict _ _ loc) clas tys
393 = tcGetUnique `thenNF_Tc` \ uniq ->
394 returnNF_Tc (Dict uniq (Class clas tys) loc)
397 newMethod :: InstOrigin
400 -> NF_TcM s (LIE, TcId)
401 newMethod orig id tys
402 = -- Get the Id type and instantiate it at the specified types
404 (tyvars, rho) = splitForAllTys (idType id)
405 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
406 (theta, tau) = splitRhoTy rho_ty
408 newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
409 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
411 instOverloadedFun orig (HsVar v) arg_tys theta tau
412 = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
413 instFunDeps orig theta `thenNF_Tc` \ fds ->
414 returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
416 instFunDeps orig theta
417 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
418 let ifd (Class clas tys) =
419 let fds = instantiateFdClassTys clas tys in
420 if null fds then Nothing else Just (FunDep clas fds loc)
422 in returnNF_Tc (catMaybes (map ifd theta))
424 newMethodWithGivenTy orig id tys theta tau
425 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
426 newMethodWith id tys theta tau loc
428 newMethodWith id tys theta tau loc
429 = tcGetUnique `thenNF_Tc` \ new_uniq ->
430 returnNF_Tc (Method new_uniq id tys theta tau loc)
432 newMethodAtLoc :: InstLoc
434 -> NF_TcM s (Inst, TcId)
435 newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
436 -- slightly different interface
437 = -- Get the Id type and instantiate it at the specified types
438 tcGetUnique `thenNF_Tc` \ new_uniq ->
440 (tyvars,rho) = splitForAllTys (idType real_id)
441 rho_ty = ASSERT( length tyvars == length tys )
442 substTy (mkTopTyVarSubst tyvars tys) rho
443 (theta, tau) = splitRhoTy rho_ty
444 meth_inst = Method new_uniq real_id tys theta tau loc
446 returnNF_Tc (meth_inst, instToId meth_inst)
449 In newOverloadedLit we convert directly to an Int or Integer if we
450 know that's what we want. This may save some time, by not
451 temporarily generating overloaded literals, but it won't catch all
452 cases (the rest are caught in lookupInst).
455 newOverloadedLit :: InstOrigin
458 -> NF_TcM s (TcExpr, LIE)
459 newOverloadedLit orig (OverloadedIntegral i) ty
460 | isIntTy ty && inIntRange i -- Short cut for Int
461 = returnNF_Tc (int_lit, emptyLIE)
463 | isIntegerTy ty -- Short cut for Integer
464 = returnNF_Tc (integer_lit, emptyLIE)
467 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
468 integer_lit = HsLitOut (HsInt i) integerTy
469 int_lit = HsCon intDataCon [] [intprim_lit]
471 newOverloadedLit orig lit ty -- The general case
472 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
473 tcGetUnique `thenNF_Tc` \ new_uniq ->
475 lit_inst = LitInst new_uniq lit ty loc
477 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
481 newIPDict name ty loc
482 = tcGetUnique `thenNF_Tc` \ new_uniq ->
483 let d = Dict new_uniq (IParam name ty) loc in
488 instToId :: Inst -> TcId
489 instToId inst = instToIdBndr inst
491 instToIdBndr :: Inst -> TcId
492 instToIdBndr (Dict u (Class clas ty) (_,loc,_))
493 = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
494 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
497 instToIdBndr (Method u id tys theta tau (_,loc,_))
498 = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
500 instToIdBndr (LitInst u list ty loc)
501 = mkSysLocal SLIT("lit") u ty
503 instToIdBndr (FunDep clas fds _)
504 = panic "FunDep escaped!!!"
507 = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
513 Zonking makes sure that the instance types are fully zonked,
514 but doesn't do the same for the Id in a Method. There's no
515 need, and it's a lot of extra work.
518 zonkPred :: TcPredType -> NF_TcM s TcPredType
519 zonkPred (Class clas tys)
520 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
521 returnNF_Tc (Class clas new_tys)
522 zonkPred (IParam n ty)
523 = zonkTcType ty `thenNF_Tc` \ new_ty ->
524 returnNF_Tc (IParam n new_ty)
526 zonkInst :: Inst -> NF_TcM s Inst
527 zonkInst (Dict u pred loc)
528 = zonkPred pred `thenNF_Tc` \ new_pred ->
529 returnNF_Tc (Dict u new_pred loc)
531 zonkInst (Method u id tys theta tau loc)
532 = zonkId id `thenNF_Tc` \ new_id ->
533 -- Essential to zonk the id in case it's a local variable
534 -- Can't use zonkIdOcc because the id might itself be
535 -- an InstId, in which case it won't be in scope
537 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
538 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
539 zonkTcType tau `thenNF_Tc` \ new_tau ->
540 returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
542 zonkInst (LitInst u lit ty loc)
543 = zonkTcType ty `thenNF_Tc` \ new_ty ->
544 returnNF_Tc (LitInst u lit new_ty loc)
546 zonkInst (FunDep clas fds loc)
547 = zonkFunDeps fds `thenNF_Tc` \ fds' ->
548 returnNF_Tc (FunDep clas fds' loc)
550 zonkInsts insts = mapNF_Tc zonkInst insts
552 zonkFunDeps fds = mapNF_Tc zonkFd fds
555 = zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
556 zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
557 returnNF_Tc (ts1', ts2')
559 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
562 = zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
563 zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
564 returnNF_Tc (tvs1', tvs2')
570 ToDo: improve these pretty-printing things. The ``origin'' is really only
571 relevant in error messages.
574 instance Outputable Inst where
575 ppr inst = pprInst inst
577 pprInst (LitInst u lit ty loc)
579 OverloadedIntegral i -> integer i
580 OverloadedFractional f -> rational f,
585 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
587 pprInst (Method u id tys _ _ loc)
588 = hsep [ppr id, ptext SLIT("at"),
589 brackets (interppSP tys),
592 pprInst (FunDep clas fds loc)
593 = hsep [ppr clas, ppr fds]
595 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
596 tidyPred env (Class clas tys)
597 = (env', Class clas tys')
599 (env', tys') = tidyOpenTypes env tys
600 tidyPred env (IParam n ty)
601 = (env', IParam n ty')
603 (env', ty') = tidyOpenType env ty
605 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
606 tidyInst env (LitInst u lit ty loc)
607 = (env', LitInst u lit ty' loc)
609 (env', ty') = tidyOpenType env ty
611 tidyInst env (Dict u pred loc)
612 = (env', Dict u pred' loc)
614 (env', pred') = tidyPred env pred
616 tidyInst env (Method u id tys theta tau loc)
617 = (env', Method u id tys' theta tau loc)
618 -- Leave theta, tau alone cos we don't print them
620 (env', tys') = tidyOpenTypes env tys
622 -- this case shouldn't arise... (we never print fundeps)
623 tidyInst env fd@(FunDep clas fds loc)
626 tidyInsts env insts = mapAccumL tidyInst env insts
628 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
632 %************************************************************************
634 \subsection[InstEnv-types]{Type declarations}
636 %************************************************************************
639 type InstanceMapper = Class -> InstEnv
642 A @ClassInstEnv@ lives inside a class, and identifies all the instances
643 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
646 There is an important consistency constraint between the @MatchEnv@s
647 in and the dfun @Id@s inside them: the free type variables of the
648 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
649 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
650 contain the following entry:
652 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
654 The "a" in the pattern must be one of the forall'd variables in
658 data LookupInstResult s
660 | SimpleInst TcExpr -- Just a variable, type application, or literal
661 | GenInst [Inst] TcExpr -- The expression and its needed insts
664 -> NF_TcM s (LookupInstResult s)
668 lookupInst dict@(Dict _ (Class clas tys) loc)
669 = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
673 subst = mkSubst (tyVarsOfTypes tys) tenv
674 (tyvars, rho) = splitForAllTys (idType dfun_id)
675 ty_args = map subst_tv tyvars
676 dfun_rho = substTy subst rho
677 (theta, tau) = splitRhoTy dfun_rho
678 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
679 subst_tv tv = case lookupSubstEnv tenv tv of
680 Just (DoneTy ty) -> ty
681 -- tenv should bind all the tyvars
684 returnNF_Tc (SimpleInst ty_app)
686 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
688 rhs = mkHsDictApp ty_app dict_ids
690 returnNF_Tc (GenInst dicts rhs)
692 Nothing -> returnNF_Tc NoInstance
693 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
697 lookupInst inst@(Method _ id tys theta _ loc)
698 = newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
699 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
703 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
704 | isIntTy ty && in_int_range -- Short cut for Int
705 = returnNF_Tc (GenInst [] int_lit)
706 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
708 | isIntegerTy ty -- Short cut for Integer
709 = returnNF_Tc (GenInst [] integer_lit)
711 | in_int_range -- It's overloaded but small enough to fit into an Int
712 = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
713 newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
714 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
716 | otherwise -- Alas, it is overloaded and a big literal!
717 = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
718 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
719 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
721 in_int_range = inIntRange i
722 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
723 integer_lit = HsLitOut (HsInt i) integerTy
724 int_lit = HsCon intDataCon [] [intprim_lit]
726 -- similar idea for overloaded floating point literals: if the literal is
727 -- *definitely* a float or a double, generate the real thing here.
728 -- This is essential (see nofib/spectral/nucleic).
730 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
731 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
732 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
735 = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
737 -- The type Rational isn't wired in so we have to conjure it up
738 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
740 rational_ty = mkSynTy rational_tycon []
741 rational_lit = HsLitOut (HsFrac f) rational_ty
743 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
744 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
747 floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy
748 float_lit = HsCon floatDataCon [] [floatprim_lit]
749 doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
750 double_lit = HsCon doubleDataCon [] [doubleprim_lit]
752 -- there are no `instances' of functional dependencies or implicit params
754 lookupInst _ = returnNF_Tc NoInstance
758 There is a second, simpler interface, when you want an instance of a
759 class at a given nullary type constructor. It just returns the
760 appropriate dictionary if it exists. It is used only when resolving
761 ambiguous dictionaries.
764 lookupSimpleInst :: InstEnv
766 -> [Type] -- Look up (c,t)
767 -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
769 lookupSimpleInst class_inst_env clas tys
770 = case lookupInstEnv (ppr clas) class_inst_env tys of
771 Nothing -> returnNF_Tc Nothing
774 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
776 (_, theta, _) = splitSigmaTy (idType dfun)
777 theta' = map (\(Class clas tys) -> (clas,tys)) theta