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, 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, mkHsConApp, 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 )
72 import Literal ( inIntRange )
74 import VarEnv ( lookupVarEnv, TidyEnv,
75 lookupSubstEnv, SubstResult(..)
77 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
78 import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
79 import TysWiredIn ( intDataCon, isIntTy,
80 floatDataCon, isFloatTy,
81 doubleDataCon, isDoubleTy,
82 integerTy, isIntegerTy
84 import Unique ( fromRationalClassOpKey, rationalTyConKey,
85 fromIntClassOpKey, fromIntegerClassOpKey, Unique
87 import Maybes ( expectJust )
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 getDictPred_maybe (Dict _ p _) = Just p
254 getDictPred_maybe _ = Nothing
256 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
257 getMethodTheta_maybe _ = Nothing
259 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
261 getFunDeps (FunDep clas fds _) = Just (clas, fds)
262 getFunDeps _ = Nothing
264 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
266 getIPsOfPred (IParam n ty) = [(n, ty)]
268 getIPsOfTheta theta = concatMap getIPsOfPred theta
270 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
271 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
274 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
276 getAllFunDeps (FunDep clas fds _) = fds
277 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
279 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
281 tyVarsOfInst :: Inst -> TcTyVarSet
282 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
283 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
284 -- The id might have free type variables; in the case of
285 -- locally-overloaded class methods, for example
286 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
287 tyVarsOfInst (FunDep _ fds _)
288 = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
289 where tyVarsOfFd (ts1, ts2) =
290 tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
293 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
296 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
297 where insts = lieToList lie
303 isDict :: Inst -> Bool
304 isDict (Dict _ _ _) = True
306 isClassDict :: Inst -> Bool
307 isClassDict (Dict _ (Class _ _) _) = True
308 isClassDict other = False
310 isMethodFor :: TcIdSet -> Inst -> Bool
311 isMethodFor ids (Method uniq id tys _ _ loc)
312 = id `elemVarSet` ids
316 isTyVarDict :: Inst -> Bool
317 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
318 isTyVarDict other = False
320 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
321 = isStandardClass clas && isTyVarTy ty
322 isStdClassTyVarDict other
325 notFunDep :: Inst -> Bool
326 notFunDep (FunDep _ _ _) = False
327 notFunDep other = True
330 Two predicates which deal with the case where class constraints don't
331 necessarily result in bindings. The first tells whether an @Inst@
332 must be witnessed by an actual binding; the second tells whether an
333 @Inst@ can be generalised over.
336 instBindingRequired :: Inst -> Bool
337 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
338 instBindingRequired (Dict _ (IParam _ _) _) = False
339 instBindingRequired other = True
341 instCanBeGeneralised :: Inst -> Bool
342 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
343 instCanBeGeneralised other = True
351 newDicts :: InstOrigin
353 -> NF_TcM s (LIE, [TcId])
355 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
356 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
357 returnNF_Tc (listToBag dicts, ids)
359 newClassDicts :: InstOrigin
360 -> [(Class,[TcType])]
361 -> NF_TcM s (LIE, [TcId])
362 newClassDicts orig theta
363 = newDicts orig (map (uncurry Class) theta)
365 -- Local function, similar to newDicts,
366 -- but with slightly different interface
367 newDictsAtLoc :: InstLoc
369 -> NF_TcM s ([Inst], [TcId])
370 newDictsAtLoc loc theta =
371 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
373 mk_dict u pred = Dict u pred loc
374 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
376 returnNF_Tc (dicts, map instToId dicts)
378 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
379 newDictFromOld (Dict _ _ loc) clas tys
380 = tcGetUnique `thenNF_Tc` \ uniq ->
381 returnNF_Tc (Dict uniq (Class clas tys) loc)
384 newMethod :: InstOrigin
387 -> NF_TcM s (LIE, TcId)
388 newMethod orig id tys
389 = -- Get the Id type and instantiate it at the specified types
391 (tyvars, rho) = splitForAllTys (idType id)
392 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
393 (theta, tau) = splitRhoTy rho_ty
395 newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
396 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
398 instOverloadedFun orig (HsVar v) arg_tys theta tau
399 = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
400 instFunDeps orig theta `thenNF_Tc` \ fds ->
401 returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
403 instFunDeps orig theta
404 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
405 let ifd (Class clas tys) =
406 let fds = instantiateFdClassTys clas tys in
407 if null fds then Nothing else Just (FunDep clas fds loc)
409 in returnNF_Tc (catMaybes (map ifd theta))
411 newMethodWithGivenTy orig id tys theta tau
412 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
413 newMethodWith id tys theta tau loc
415 newMethodWith id tys theta tau loc
416 = tcGetUnique `thenNF_Tc` \ new_uniq ->
417 returnNF_Tc (Method new_uniq id tys theta tau loc)
419 newMethodAtLoc :: InstLoc
421 -> NF_TcM s (Inst, TcId)
422 newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
423 -- slightly different interface
424 = -- Get the Id type and instantiate it at the specified types
425 tcGetUnique `thenNF_Tc` \ new_uniq ->
427 (tyvars,rho) = splitForAllTys (idType real_id)
428 rho_ty = ASSERT( length tyvars == length tys )
429 substTy (mkTopTyVarSubst tyvars tys) rho
430 (theta, tau) = splitRhoTy rho_ty
431 meth_inst = Method new_uniq real_id tys theta tau loc
433 returnNF_Tc (meth_inst, instToId meth_inst)
436 In newOverloadedLit we convert directly to an Int or Integer if we
437 know that's what we want. This may save some time, by not
438 temporarily generating overloaded literals, but it won't catch all
439 cases (the rest are caught in lookupInst).
442 newOverloadedLit :: InstOrigin
445 -> NF_TcM s (TcExpr, LIE)
446 newOverloadedLit orig (OverloadedIntegral i) ty
447 | isIntTy ty && inIntRange i -- Short cut for Int
448 = returnNF_Tc (int_lit, emptyLIE)
450 | isIntegerTy ty -- Short cut for Integer
451 = returnNF_Tc (integer_lit, emptyLIE)
454 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
455 integer_lit = HsLitOut (HsInt i) integerTy
456 int_lit = mkHsConApp intDataCon [] [intprim_lit]
458 newOverloadedLit orig lit ty -- The general case
459 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
460 tcGetUnique `thenNF_Tc` \ new_uniq ->
462 lit_inst = LitInst new_uniq lit ty loc
464 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
468 newIPDict name ty loc
469 = tcGetUnique `thenNF_Tc` \ new_uniq ->
470 let d = Dict new_uniq (IParam name ty) loc in
475 instToId :: Inst -> TcId
476 instToId inst = instToIdBndr inst
478 instToIdBndr :: Inst -> TcId
479 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
480 = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
481 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
484 instToIdBndr (Method u id tys theta tau (_,loc,_))
485 = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
487 instToIdBndr (LitInst u list ty loc)
488 = mkSysLocal SLIT("lit") u ty
490 instToIdBndr (FunDep clas fds _)
491 = panic "FunDep escaped!!!"
494 = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
500 Zonking makes sure that the instance types are fully zonked,
501 but doesn't do the same for the Id in a Method. There's no
502 need, and it's a lot of extra work.
505 zonkPred :: TcPredType -> NF_TcM s TcPredType
506 zonkPred (Class clas tys)
507 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
508 returnNF_Tc (Class clas new_tys)
509 zonkPred (IParam n ty)
510 = zonkTcType ty `thenNF_Tc` \ new_ty ->
511 returnNF_Tc (IParam n new_ty)
513 zonkInst :: Inst -> NF_TcM s Inst
514 zonkInst (Dict u pred loc)
515 = zonkPred pred `thenNF_Tc` \ new_pred ->
516 returnNF_Tc (Dict u new_pred loc)
518 zonkInst (Method u id tys theta tau loc)
519 = zonkId id `thenNF_Tc` \ new_id ->
520 -- Essential to zonk the id in case it's a local variable
521 -- Can't use zonkIdOcc because the id might itself be
522 -- an InstId, in which case it won't be in scope
524 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
525 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
526 zonkTcType tau `thenNF_Tc` \ new_tau ->
527 returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
529 zonkInst (LitInst u lit ty loc)
530 = zonkTcType ty `thenNF_Tc` \ new_ty ->
531 returnNF_Tc (LitInst u lit new_ty loc)
533 zonkInst (FunDep clas fds loc)
534 = zonkFunDeps fds `thenNF_Tc` \ fds' ->
535 returnNF_Tc (FunDep clas fds' loc)
537 zonkPreds preds = mapNF_Tc zonkPred preds
538 zonkInsts insts = mapNF_Tc zonkInst insts
540 zonkFunDeps fds = mapNF_Tc zonkFd fds
543 = zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
544 zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
545 returnNF_Tc (ts1', ts2')
547 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
550 = zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
551 zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
552 returnNF_Tc (tvs1', tvs2')
558 ToDo: improve these pretty-printing things. The ``origin'' is really only
559 relevant in error messages.
562 instance Outputable Inst where
563 ppr inst = pprInst inst
565 pprInst (LitInst u lit ty loc)
567 OverloadedIntegral i -> integer i
568 OverloadedFractional f -> rational f,
573 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
575 pprInst m@(Method u id tys theta tau loc)
576 = hsep [ppr id, ptext SLIT("at"),
577 brackets (interppSP tys),
582 pprInst (FunDep clas fds loc)
583 = hsep [ppr clas, ppr fds]
585 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
586 tidyPred env (Class clas tys)
587 = (env', Class clas tys')
589 (env', tys') = tidyOpenTypes env tys
590 tidyPred env (IParam n ty)
591 = (env', IParam n ty')
593 (env', ty') = tidyOpenType env ty
595 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
596 tidyInst env (LitInst u lit ty loc)
597 = (env', LitInst u lit ty' loc)
599 (env', ty') = tidyOpenType env ty
601 tidyInst env (Dict u pred loc)
602 = (env', Dict u pred' loc)
604 (env', pred') = tidyPred env pred
606 tidyInst env (Method u id tys theta tau loc)
607 = (env', Method u id tys' theta tau loc)
608 -- Leave theta, tau alone cos we don't print them
610 (env', tys') = tidyOpenTypes env tys
612 -- this case shouldn't arise... (we never print fundeps)
613 tidyInst env fd@(FunDep clas fds loc)
616 tidyInsts env insts = mapAccumL tidyInst env insts
618 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
622 %************************************************************************
624 \subsection[InstEnv-types]{Type declarations}
626 %************************************************************************
629 type InstanceMapper = Class -> InstEnv
632 A @ClassInstEnv@ lives inside a class, and identifies all the instances
633 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
636 There is an important consistency constraint between the @MatchEnv@s
637 in and the dfun @Id@s inside them: the free type variables of the
638 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
639 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
640 contain the following entry:
642 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
644 The "a" in the pattern must be one of the forall'd variables in
648 data LookupInstResult s
650 | SimpleInst TcExpr -- Just a variable, type application, or literal
651 | GenInst [Inst] TcExpr -- The expression and its needed insts
654 -> NF_TcM s (LookupInstResult s)
658 lookupInst dict@(Dict _ (Class clas tys) loc)
659 = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
663 subst = mkSubst (tyVarsOfTypes tys) tenv
664 (tyvars, rho) = splitForAllTys (idType dfun_id)
665 ty_args = map subst_tv tyvars
666 dfun_rho = substTy subst rho
667 (theta, tau) = splitRhoTy dfun_rho
668 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
669 subst_tv tv = case lookupSubstEnv tenv tv of
670 Just (DoneTy ty) -> ty
671 -- tenv should bind all the tyvars
674 returnNF_Tc (SimpleInst ty_app)
676 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
678 rhs = mkHsDictApp ty_app dict_ids
680 returnNF_Tc (GenInst dicts rhs)
682 Nothing -> returnNF_Tc NoInstance
683 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
687 lookupInst inst@(Method _ id tys theta _ loc)
688 = newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
689 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
693 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
694 | isIntTy ty && in_int_range -- Short cut for Int
695 = returnNF_Tc (GenInst [] int_lit)
696 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
698 | isIntegerTy ty -- Short cut for Integer
699 = returnNF_Tc (GenInst [] integer_lit)
701 | in_int_range -- It's overloaded but small enough to fit into an Int
702 = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
703 newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
704 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
706 | otherwise -- Alas, it is overloaded and a big literal!
707 = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
708 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
709 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
711 in_int_range = inIntRange i
712 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
713 integer_lit = HsLitOut (HsInt i) integerTy
714 int_lit = mkHsConApp intDataCon [] [intprim_lit]
716 -- similar idea for overloaded floating point literals: if the literal is
717 -- *definitely* a float or a double, generate the real thing here.
718 -- This is essential (see nofib/spectral/nucleic).
720 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
721 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
722 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
725 = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
727 -- The type Rational isn't wired in so we have to conjure it up
728 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
730 rational_ty = mkSynTy rational_tycon []
731 rational_lit = HsLitOut (HsFrac f) rational_ty
733 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
734 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
737 floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy
738 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
739 doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
740 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
742 -- there are no `instances' of functional dependencies or implicit params
744 lookupInst _ = returnNF_Tc NoInstance
748 There is a second, simpler interface, when you want an instance of a
749 class at a given nullary type constructor. It just returns the
750 appropriate dictionary if it exists. It is used only when resolving
751 ambiguous dictionaries.
754 lookupSimpleInst :: InstEnv
756 -> [Type] -- Look up (c,t)
757 -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
759 lookupSimpleInst class_inst_env clas tys
760 = case lookupInstEnv (ppr clas) class_inst_env tys of
761 Nothing -> returnNF_Tc Nothing
764 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
766 (_, theta, _) = splitSigmaTy (idType dfun)
767 theta' = map (\(Class clas tys) -> (clas,tys)) theta