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,
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(..), HsOverLit(..), HsExpr(..) )
41 import RnHsSyn ( RenamedHsOverLit )
42 import TcHsSyn ( TcExpr, TcId,
43 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
46 import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
47 import InstEnv ( InstLookupResult(..), lookupInstEnv )
48 import TcType ( TcThetaType,
49 TcType, TcTauType, TcTyVarSet,
50 zonkTcTyVars, zonkTcType, zonkTcTypes,
53 import CoreFVs ( idFreeTyVars )
54 import Class ( Class, FunDep )
55 import FunDeps ( instantiateFdClassTys )
56 import Id ( Id, idType, mkUserLocal, mkSysLocal )
57 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
58 import Name ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
59 import PprType ( pprPred )
60 import Type ( Type, PredType(..),
61 isTyVarTy, mkDictTy, mkPredTy,
62 splitForAllTys, splitSigmaTy, funArgTy,
63 splitMethodTy, splitRhoTy,
64 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
65 tidyOpenType, tidyOpenTypes
67 import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet,
68 substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
70 import Literal ( inIntRange )
71 import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
72 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
73 import TysWiredIn ( isIntTy,
74 floatDataCon, isFloatTy,
75 doubleDataCon, isDoubleTy,
78 import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
79 import Maybe ( catMaybes )
80 import Util ( thenCmp, zipWithEqual, mapAccumL )
85 %************************************************************************
87 \subsection[Inst-collections]{LIE: a collection of Insts}
89 %************************************************************************
94 isEmptyLIE = isEmptyBag
96 unitLIE inst = unitBag inst
97 mkLIE insts = listToBag insts
98 plusLIE lie1 lie2 = lie1 `unionBags` lie2
99 consLIE inst lie = inst `consBag` lie
100 plusLIEs lies = unionManyBags lies
101 lieToList = bagToList
102 listToLIE = listToBag
104 zonkLIE :: LIE -> NF_TcM LIE
105 zonkLIE lie = mapBagNF_Tc zonkInst lie
107 pprInsts :: [Inst] -> SDoc
108 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
112 = vcat (map go insts)
114 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
117 %************************************************************************
119 \subsection[Inst-types]{@Inst@ types}
121 %************************************************************************
123 An @Inst@ is either a dictionary, an instance of an overloaded
124 literal, or an instance of an overloaded value. We call the latter a
125 ``method'' even though it may not correspond to a class operation.
126 For example, we might have an instance of the @double@ function at
127 type Int, represented by
129 Method 34 doubleId [Int] origin
141 TcId -- The overloaded function
142 -- This function will be a global, local, or ClassOpId;
143 -- inside instance decls (only) it can also be an InstId!
144 -- The id needn't be completely polymorphic.
145 -- You'll probably find its name (for documentation purposes)
146 -- inside the InstOrigin
148 [TcType] -- The types to which its polymorphic tyvars
149 -- should be instantiated.
150 -- These types must saturate the Id's foralls.
152 TcThetaType -- The (types of the) dictionaries to which the function
153 -- must be applied to get the method
155 TcTauType -- The type of the method
159 -- INVARIANT: in (Method u f tys theta tau loc)
160 -- type of (f tys dicts(from theta)) = tau
164 RenamedHsOverLit -- The literal from the occurrence site
165 TcType -- The type at which the literal is used
170 Class -- the class from which this arises
177 @Insts@ are ordered by their class/type info, rather than by their
178 unique. This allows the context-reduction mechanism to use standard finite
179 maps to do their stuff.
182 instance Ord Inst where
185 instance Eq Inst where
186 (==) i1 i2 = case i1 `cmpInst` i2 of
190 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
191 cmpInst (Dict _ _ _) other = LT
193 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
194 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
195 cmpInst (Method _ _ _ _ _ _) other = LT
197 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
198 cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT
199 cmpInst (LitInst _ _ _ _) other = GT
201 cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
202 cmpInst (FunDep _ _ _ _) other = GT
204 -- and they can only have HsInt or HsFracs in them.
211 instLoc (Dict u pred loc) = loc
212 instLoc (Method u _ _ _ _ loc) = loc
213 instLoc (LitInst u lit ty loc) = loc
214 instLoc (FunDep _ _ _ loc) = loc
216 getDictPred_maybe (Dict _ p _) = Just p
217 getDictPred_maybe _ = Nothing
219 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
220 getMethodTheta_maybe _ = Nothing
222 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
224 getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
225 getFunDeps _ = Nothing
227 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
229 getIPsOfPred (IParam n ty) = [(n, ty)]
231 getIPsOfTheta theta = concatMap getIPsOfPred theta
233 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
234 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
237 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
239 getAllFunDeps (FunDep _ clas fds _) = fds
240 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
242 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
244 tyVarsOfInst :: Inst -> TcTyVarSet
245 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
246 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
247 -- The id might have free type variables; in the case of
248 -- locally-overloaded class methods, for example
249 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
250 tyVarsOfInst (FunDep _ _ fds _)
251 = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
252 where tyVarsOfFd (ts1, ts2) =
253 tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
256 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
259 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
260 where insts = lieToList lie
266 isDict :: Inst -> Bool
267 isDict (Dict _ _ _) = True
270 isClassDict :: Inst -> Bool
271 isClassDict (Dict _ (Class _ _) _) = True
272 isClassDict other = False
274 isMethod :: Inst -> Bool
275 isMethod (Method _ _ _ _ _ _) = True
276 isMethod other = False
278 isMethodFor :: TcIdSet -> Inst -> Bool
279 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
280 isMethodFor ids inst = False
282 isTyVarDict :: Inst -> Bool
283 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
284 isTyVarDict other = False
286 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
287 = isStandardClass clas && isTyVarTy ty
288 isStdClassTyVarDict other
291 notFunDep :: Inst -> Bool
292 notFunDep (FunDep _ _ _ _) = False
293 notFunDep other = True
296 Two predicates which deal with the case where class constraints don't
297 necessarily result in bindings. The first tells whether an @Inst@
298 must be witnessed by an actual binding; the second tells whether an
299 @Inst@ can be generalised over.
302 instBindingRequired :: Inst -> Bool
303 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
304 instBindingRequired (Dict _ (IParam _ _) _) = False
305 instBindingRequired other = True
307 instCanBeGeneralised :: Inst -> Bool
308 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
309 instCanBeGeneralised other = True
317 newDicts :: InstOrigin
319 -> NF_TcM (LIE, [TcId])
321 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
322 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
323 returnNF_Tc (listToBag dicts, ids)
325 newClassDicts :: InstOrigin
326 -> [(Class,[TcType])]
327 -> NF_TcM (LIE, [TcId])
328 newClassDicts orig theta
329 = newDicts orig (map (uncurry Class) theta)
331 -- Local function, similar to newDicts,
332 -- but with slightly different interface
333 newDictsAtLoc :: InstLoc
335 -> NF_TcM ([Inst], [TcId])
336 newDictsAtLoc loc theta =
337 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
339 mk_dict u pred = Dict u pred loc
340 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
342 returnNF_Tc (dicts, map instToId dicts)
344 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst
345 newDictFromOld (Dict _ _ loc) clas tys
346 = tcGetUnique `thenNF_Tc` \ uniq ->
347 returnNF_Tc (Dict uniq (Class clas tys) loc)
350 newMethod :: InstOrigin
353 -> NF_TcM (LIE, TcId)
354 newMethod orig id tys
355 = -- Get the Id type and instantiate it at the specified types
357 (tyvars, rho) = splitForAllTys (idType id)
358 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
359 (pred, tau) = splitMethodTy rho_ty
361 newMethodWithGivenTy orig id tys [pred] tau `thenNF_Tc` \ meth_inst ->
362 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
364 instOverloadedFun orig v arg_tys theta tau
365 -- This is where we introduce new functional dependencies into the LIE
366 = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
367 instFunDeps orig theta `thenNF_Tc` \ fds ->
368 returnNF_Tc (instToId inst, mkLIE (inst : fds))
370 instFunDeps orig theta
371 = tcGetUnique `thenNF_Tc` \ uniq ->
372 tcGetInstLoc orig `thenNF_Tc` \ loc ->
373 let ifd (Class clas tys) =
374 let fds = instantiateFdClassTys clas tys in
375 if null fds then Nothing else Just (FunDep uniq clas fds loc)
377 in returnNF_Tc (catMaybes (map ifd theta))
379 instFunDepsOfTheta theta
380 = let ifd (Class clas tys) = instantiateFdClassTys clas tys
381 ifd (IParam n ty) = [([], [ty])]
382 in concat (map ifd theta)
384 newMethodWithGivenTy orig id tys theta tau
385 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
386 newMethodWith id tys theta tau loc
388 newMethodWith id tys theta tau loc
389 = tcGetUnique `thenNF_Tc` \ new_uniq ->
390 returnNF_Tc (Method new_uniq id tys theta tau loc)
392 newMethodAtLoc :: InstLoc
394 -> NF_TcM (Inst, TcId)
395 newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
396 -- slightly different interface
397 = -- Get the Id type and instantiate it at the specified types
398 tcGetUnique `thenNF_Tc` \ new_uniq ->
400 (tyvars,rho) = splitForAllTys (idType real_id)
401 rho_ty = ASSERT( length tyvars == length tys )
402 substTy (mkTopTyVarSubst tyvars tys) rho
403 (theta, tau) = splitRhoTy rho_ty
404 meth_inst = Method new_uniq real_id tys theta tau loc
406 returnNF_Tc (meth_inst, instToId meth_inst)
409 In newOverloadedLit we convert directly to an Int or Integer if we
410 know that's what we want. This may save some time, by not
411 temporarily generating overloaded literals, but it won't catch all
412 cases (the rest are caught in lookupInst).
415 newOverloadedLit :: InstOrigin
418 -> NF_TcM (TcExpr, LIE)
419 newOverloadedLit orig (HsIntegral i _) ty
420 | isIntTy ty && inIntRange i -- Short cut for Int
421 = returnNF_Tc (int_lit, emptyLIE)
423 | isIntegerTy ty -- Short cut for Integer
424 = returnNF_Tc (integer_lit, emptyLIE)
427 int_lit = HsLit (HsInt i)
428 integer_lit = HsLit (HsInteger i)
430 newOverloadedLit orig lit ty -- The general case
431 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
432 tcGetUnique `thenNF_Tc` \ new_uniq ->
434 lit_inst = LitInst new_uniq lit ty loc
436 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
440 newFunDepFromDict dict
442 = tcGetUnique `thenNF_Tc` \ uniq ->
443 let (clas, tys) = getDictClassTys dict
444 fds = instantiateFdClassTys clas tys
445 inst = FunDep uniq clas fds (instLoc dict)
447 if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
449 = returnNF_Tc Nothing
453 newIPDict name ty loc
454 = tcGetUnique `thenNF_Tc` \ new_uniq ->
455 let d = Dict new_uniq (IParam name ty) loc in
460 instToId :: Inst -> TcId
461 instToId inst = instToIdBndr inst
463 instToIdBndr :: Inst -> TcId
464 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
465 = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
466 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
469 instToIdBndr (Method u id tys theta tau (_,loc,_))
470 = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
472 instToIdBndr (LitInst u list ty loc)
473 = mkSysLocal SLIT("lit") u ty
475 instToIdBndr (FunDep u clas fds _)
476 = mkSysLocal SLIT("FunDep") u voidTy
479 = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
485 Zonking makes sure that the instance types are fully zonked,
486 but doesn't do the same for the Id in a Method. There's no
487 need, and it's a lot of extra work.
490 zonkPred :: TcPredType -> NF_TcM TcPredType
491 zonkPred (Class clas tys)
492 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
493 returnNF_Tc (Class clas new_tys)
494 zonkPred (IParam n ty)
495 = zonkTcType ty `thenNF_Tc` \ new_ty ->
496 returnNF_Tc (IParam n new_ty)
498 zonkInst :: Inst -> NF_TcM Inst
499 zonkInst (Dict u pred loc)
500 = zonkPred pred `thenNF_Tc` \ new_pred ->
501 returnNF_Tc (Dict u new_pred loc)
503 zonkInst (Method u id tys theta tau loc)
504 = zonkId id `thenNF_Tc` \ new_id ->
505 -- Essential to zonk the id in case it's a local variable
506 -- Can't use zonkIdOcc because the id might itself be
507 -- an InstId, in which case it won't be in scope
509 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
510 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
511 zonkTcType tau `thenNF_Tc` \ new_tau ->
512 returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
514 zonkInst (LitInst u lit ty loc)
515 = zonkTcType ty `thenNF_Tc` \ new_ty ->
516 returnNF_Tc (LitInst u lit new_ty loc)
518 zonkInst (FunDep u clas fds loc)
519 = zonkFunDeps fds `thenNF_Tc` \ fds' ->
520 returnNF_Tc (FunDep u clas fds' loc)
522 zonkInsts insts = mapNF_Tc zonkInst insts
524 zonkFunDeps fds = mapNF_Tc zonkFd fds
527 = zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
528 zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
529 returnNF_Tc (ts1', ts2')
531 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
534 = zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
535 zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
536 returnNF_Tc (tvs1', tvs2')
542 ToDo: improve these pretty-printing things. The ``origin'' is really only
543 relevant in error messages.
546 instance Outputable Inst where
547 ppr inst = pprInst inst
549 pprInst (LitInst u lit ty loc)
550 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
552 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
554 pprInst m@(Method u id tys theta tau loc)
555 = hsep [ppr id, ptext SLIT("at"),
556 brackets (interppSP tys) {- ,
557 ptext SLIT("theta"), ppr theta,
558 ptext SLIT("tau"), ppr tau
562 pprInst (FunDep _ clas fds loc)
563 = hsep [ppr clas, ppr fds]
565 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
566 tidyPred env (Class clas tys)
567 = (env', Class clas tys')
569 (env', tys') = tidyOpenTypes env tys
570 tidyPred env (IParam n ty)
571 = (env', IParam n ty')
573 (env', ty') = tidyOpenType env ty
575 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
576 tidyInst env (LitInst u lit ty loc)
577 = (env', LitInst u lit ty' loc)
579 (env', ty') = tidyOpenType env ty
581 tidyInst env (Dict u pred loc)
582 = (env', Dict u pred' loc)
584 (env', pred') = tidyPred env pred
586 tidyInst env (Method u id tys theta tau loc)
587 = (env', Method u id tys' theta tau loc)
588 -- Leave theta, tau alone cos we don't print them
590 (env', tys') = tidyOpenTypes env tys
592 -- this case shouldn't arise... (we never print fundeps)
593 tidyInst env fd@(FunDep _ clas fds loc)
596 tidyInsts env insts = mapAccumL tidyInst env insts
598 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
602 %************************************************************************
604 \subsection[InstEnv-types]{Type declarations}
606 %************************************************************************
609 data LookupInstResult s
611 | SimpleInst TcExpr -- Just a variable, type application, or literal
612 | GenInst [Inst] TcExpr -- The expression and its needed insts
615 -> NF_TcM (LookupInstResult s)
619 lookupInst dict@(Dict _ (Class clas tys) loc)
620 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
621 case lookupInstEnv inst_env clas tys of
623 FoundInst tenv dfun_id
625 subst = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv
626 (tyvars, rho) = splitForAllTys (idType dfun_id)
627 ty_args = map subst_tv tyvars
628 dfun_rho = substTy subst rho
629 (theta, _) = splitRhoTy dfun_rho
630 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
631 subst_tv tv = case lookupSubstEnv tenv tv of
632 Just (DoneTy ty) -> ty
633 -- tenv should bind all the tyvars
636 returnNF_Tc (SimpleInst ty_app)
638 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
640 rhs = mkHsDictApp ty_app dict_ids
642 returnNF_Tc (GenInst dicts rhs)
644 other -> returnNF_Tc NoInstance
645 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
649 lookupInst inst@(Method _ id tys theta _ loc)
650 = newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
651 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
655 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
656 | isIntTy ty && in_int_range -- Short cut for Int
657 = returnNF_Tc (GenInst [] int_lit)
658 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
660 | isIntegerTy ty -- Short cut for Integer
661 = returnNF_Tc (GenInst [] integer_lit)
663 | in_int_range -- It's overloaded but small enough to fit into an Int
664 && from_integer_name `hasKey` fromIntegerClassOpKey -- And it's the built-in prelude fromInteger
665 -- (i.e. no funny business with user-defined
666 -- packages of numeric classes)
667 = -- So we can use the Prelude fromInt
668 tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int ->
669 newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
670 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
672 | otherwise -- Alas, it is overloaded and a big literal!
673 = tcLookupGlobalId from_integer_name `thenNF_Tc` \ from_integer ->
674 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
675 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
677 in_int_range = inIntRange i
678 integer_lit = HsLit (HsInteger i)
679 int_lit = HsLit (HsInt i)
681 -- similar idea for overloaded floating point literals: if the literal is
682 -- *definitely* a float or a double, generate the real thing here.
683 -- This is essential (see nofib/spectral/nucleic).
685 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
686 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
687 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
690 = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational ->
691 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
693 rational_ty = funArgTy (idType method_id)
694 rational_lit = HsLit (HsRat f rational_ty)
696 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
699 floatprim_lit = HsLit (HsFloatPrim f)
700 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
701 doubleprim_lit = HsLit (HsDoublePrim f)
702 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
704 -- there are no `instances' of functional dependencies or implicit params
706 lookupInst _ = returnNF_Tc NoInstance
710 There is a second, simpler interface, when you want an instance of a
711 class at a given nullary type constructor. It just returns the
712 appropriate dictionary if it exists. It is used only when resolving
713 ambiguous dictionaries.
716 lookupSimpleInst :: Class
717 -> [Type] -- Look up (c,t)
718 -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
720 lookupSimpleInst clas tys
721 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
722 case lookupInstEnv inst_env clas tys of
724 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
726 (_, theta, _) = splitSigmaTy (idType dfun)
727 theta' = map (\(Class clas tys) -> (clas,tys)) theta
729 other -> returnNF_Tc Nothing