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,
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 ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
59 import PprType ( pprPred )
60 import Type ( Type, PredType(..),
61 isTyVarTy, mkDictTy, mkPredTy,
62 splitForAllTys, splitSigmaTy, funArgTy,
63 splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
64 tidyOpenType, tidyOpenTypes
66 import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet,
67 substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
69 import Literal ( inIntRange )
70 import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
71 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
72 import TysWiredIn ( isIntTy,
73 floatDataCon, isFloatTy,
74 doubleDataCon, isDoubleTy,
77 import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
78 import Maybe ( catMaybes )
79 import Util ( thenCmp, zipWithEqual, mapAccumL )
83 %************************************************************************
85 \subsection[Inst-collections]{LIE: a collection of Insts}
87 %************************************************************************
92 isEmptyLIE = isEmptyBag
94 unitLIE inst = unitBag inst
95 mkLIE insts = listToBag insts
96 plusLIE lie1 lie2 = lie1 `unionBags` lie2
97 consLIE inst lie = inst `consBag` lie
98 plusLIEs lies = unionManyBags lies
100 listToLIE = listToBag
102 zonkLIE :: LIE -> NF_TcM LIE
103 zonkLIE lie = mapBagNF_Tc zonkInst lie
105 pprInsts :: [Inst] -> SDoc
106 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
110 = vcat (map go insts)
112 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
115 %************************************************************************
117 \subsection[Inst-types]{@Inst@ types}
119 %************************************************************************
121 An @Inst@ is either a dictionary, an instance of an overloaded
122 literal, or an instance of an overloaded value. We call the latter a
123 ``method'' even though it may not correspond to a class operation.
124 For example, we might have an instance of the @double@ function at
125 type Int, represented by
127 Method 34 doubleId [Int] origin
139 TcId -- The overloaded function
140 -- This function will be a global, local, or ClassOpId;
141 -- inside instance decls (only) it can also be an InstId!
142 -- The id needn't be completely polymorphic.
143 -- You'll probably find its name (for documentation purposes)
144 -- inside the InstOrigin
146 [TcType] -- The types to which its polymorphic tyvars
147 -- should be instantiated.
148 -- These types must saturate the Id's foralls.
150 TcThetaType -- The (types of the) dictionaries to which the function
151 -- must be applied to get the method
153 TcTauType -- The type of the method
157 -- INVARIANT: in (Method u f tys theta tau loc)
158 -- type of (f tys dicts(from theta)) = tau
162 RenamedHsOverLit -- The literal from the occurrence site
163 TcType -- The type at which the literal is used
168 Class -- the class from which this arises
175 @Insts@ are ordered by their class/type info, rather than by their
176 unique. This allows the context-reduction mechanism to use standard finite
177 maps to do their stuff.
180 instance Ord Inst where
183 instance Eq Inst where
184 (==) i1 i2 = case i1 `cmpInst` i2 of
188 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
189 cmpInst (Dict _ _ _) other = LT
191 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
192 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
193 cmpInst (Method _ _ _ _ _ _) other = LT
195 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
196 cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT
197 cmpInst (LitInst _ _ _ _) other = GT
199 cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
200 cmpInst (FunDep _ _ _ _) other = GT
202 -- and they can only have HsInt or HsFracs in them.
209 instLoc (Dict u pred loc) = loc
210 instLoc (Method u _ _ _ _ loc) = loc
211 instLoc (LitInst u lit ty loc) = loc
212 instLoc (FunDep _ _ _ loc) = loc
214 getDictPred_maybe (Dict _ p _) = Just p
215 getDictPred_maybe _ = Nothing
217 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
218 getMethodTheta_maybe _ = Nothing
220 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
222 getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
223 getFunDeps _ = Nothing
225 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
227 getIPsOfPred (IParam n ty) = [(n, ty)]
229 getIPsOfTheta theta = concatMap getIPsOfPred theta
231 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
232 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
235 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
237 getAllFunDeps (FunDep _ clas fds _) = fds
238 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
240 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
242 tyVarsOfInst :: Inst -> TcTyVarSet
243 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
244 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
245 -- The id might have free type variables; in the case of
246 -- locally-overloaded class methods, for example
247 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
248 tyVarsOfInst (FunDep _ _ fds _)
249 = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
250 where tyVarsOfFd (ts1, ts2) =
251 tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
254 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
257 = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
258 where insts = lieToList lie
264 isDict :: Inst -> Bool
265 isDict (Dict _ _ _) = True
268 isClassDict :: Inst -> Bool
269 isClassDict (Dict _ (Class _ _) _) = True
270 isClassDict other = False
272 isMethod :: Inst -> Bool
273 isMethod (Method _ _ _ _ _ _) = True
274 isMethod other = False
276 isMethodFor :: TcIdSet -> Inst -> Bool
277 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
278 isMethodFor ids inst = False
280 isTyVarDict :: Inst -> Bool
281 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
282 isTyVarDict other = False
284 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
285 = isStandardClass clas && isTyVarTy ty
286 isStdClassTyVarDict other
289 notFunDep :: Inst -> Bool
290 notFunDep (FunDep _ _ _ _) = False
291 notFunDep other = True
294 Two predicates which deal with the case where class constraints don't
295 necessarily result in bindings. The first tells whether an @Inst@
296 must be witnessed by an actual binding; the second tells whether an
297 @Inst@ can be generalised over.
300 instBindingRequired :: Inst -> Bool
301 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
302 instBindingRequired (Dict _ (IParam _ _) _) = False
303 instBindingRequired other = True
305 instCanBeGeneralised :: Inst -> Bool
306 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
307 instCanBeGeneralised other = True
315 newDicts :: InstOrigin
317 -> NF_TcM (LIE, [TcId])
319 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
320 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
321 returnNF_Tc (listToBag dicts, ids)
323 newClassDicts :: InstOrigin
324 -> [(Class,[TcType])]
325 -> NF_TcM (LIE, [TcId])
326 newClassDicts orig theta
327 = newDicts orig (map (uncurry Class) theta)
329 -- Local function, similar to newDicts,
330 -- but with slightly different interface
331 newDictsAtLoc :: InstLoc
333 -> NF_TcM ([Inst], [TcId])
334 newDictsAtLoc loc theta =
335 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
337 mk_dict u pred = Dict u pred loc
338 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
340 returnNF_Tc (dicts, map instToId dicts)
342 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst
343 newDictFromOld (Dict _ _ loc) clas tys
344 = tcGetUnique `thenNF_Tc` \ uniq ->
345 returnNF_Tc (Dict uniq (Class clas tys) loc)
348 newMethod :: InstOrigin
351 -> NF_TcM (LIE, TcId)
352 newMethod orig id tys
353 = -- Get the Id type and instantiate it at the specified types
355 (tyvars, rho) = splitForAllTys (idType id)
356 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
357 (theta, tau) = splitRhoTy rho_ty
359 newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
360 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
362 instOverloadedFun orig v arg_tys theta tau
363 -- This is where we introduce new functional dependencies into the LIE
364 = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
365 instFunDeps orig theta `thenNF_Tc` \ fds ->
366 returnNF_Tc (instToId inst, mkLIE (inst : fds))
368 instFunDeps orig theta
369 = tcGetUnique `thenNF_Tc` \ uniq ->
370 tcGetInstLoc orig `thenNF_Tc` \ loc ->
371 let ifd (Class clas tys) =
372 let fds = instantiateFdClassTys clas tys in
373 if null fds then Nothing else Just (FunDep uniq clas fds loc)
375 in returnNF_Tc (catMaybes (map ifd theta))
377 instFunDepsOfTheta theta
378 = let ifd (Class clas tys) = instantiateFdClassTys clas tys
379 ifd (IParam n ty) = [([], [ty])]
380 in concat (map ifd theta)
382 newMethodWithGivenTy orig id tys theta tau
383 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
384 newMethodWith id tys theta tau loc
386 newMethodWith id tys theta tau loc
387 = tcGetUnique `thenNF_Tc` \ new_uniq ->
388 returnNF_Tc (Method new_uniq id tys theta tau loc)
390 newMethodAtLoc :: InstLoc
392 -> NF_TcM (Inst, TcId)
393 newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
394 -- slightly different interface
395 = -- Get the Id type and instantiate it at the specified types
396 tcGetUnique `thenNF_Tc` \ new_uniq ->
398 (tyvars,rho) = splitForAllTys (idType real_id)
399 rho_ty = ASSERT( length tyvars == length tys )
400 substTy (mkTopTyVarSubst tyvars tys) rho
401 (theta, tau) = splitRhoTy rho_ty
402 meth_inst = Method new_uniq real_id tys theta tau loc
404 returnNF_Tc (meth_inst, instToId meth_inst)
407 In newOverloadedLit we convert directly to an Int or Integer if we
408 know that's what we want. This may save some time, by not
409 temporarily generating overloaded literals, but it won't catch all
410 cases (the rest are caught in lookupInst).
413 newOverloadedLit :: InstOrigin
416 -> NF_TcM (TcExpr, LIE)
417 newOverloadedLit orig (HsIntegral i _) ty
418 | isIntTy ty && inIntRange i -- Short cut for Int
419 = returnNF_Tc (int_lit, emptyLIE)
421 | isIntegerTy ty -- Short cut for Integer
422 = returnNF_Tc (integer_lit, emptyLIE)
425 int_lit = HsLit (HsInt i)
426 integer_lit = HsLit (HsInteger i)
428 newOverloadedLit orig lit ty -- The general case
429 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
430 tcGetUnique `thenNF_Tc` \ new_uniq ->
432 lit_inst = LitInst new_uniq lit ty loc
434 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
438 newFunDepFromDict dict
440 = tcGetUnique `thenNF_Tc` \ uniq ->
441 let (clas, tys) = getDictClassTys dict
442 fds = instantiateFdClassTys clas tys
443 inst = FunDep uniq clas fds (instLoc dict)
445 if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
447 = returnNF_Tc Nothing
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 u clas fds _)
474 = mkSysLocal SLIT("FunDep") u voidTy
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 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 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 u clas fds loc)
517 = zonkFunDeps fds `thenNF_Tc` \ fds' ->
518 returnNF_Tc (FunDep u clas fds' loc)
520 zonkInsts insts = mapNF_Tc zonkInst insts
522 zonkFunDeps fds = mapNF_Tc zonkFd fds
525 = zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
526 zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
527 returnNF_Tc (ts1', ts2')
529 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
532 = zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
533 zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
534 returnNF_Tc (tvs1', tvs2')
540 ToDo: improve these pretty-printing things. The ``origin'' is really only
541 relevant in error messages.
544 instance Outputable Inst where
545 ppr inst = pprInst inst
547 pprInst (LitInst u lit ty loc)
548 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
550 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
552 pprInst m@(Method u id tys theta tau loc)
553 = hsep [ppr id, ptext SLIT("at"),
554 brackets (interppSP tys) {- ,
559 pprInst (FunDep _ clas fds loc)
560 = hsep [ppr clas, ppr fds]
562 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
563 tidyPred env (Class clas tys)
564 = (env', Class clas tys')
566 (env', tys') = tidyOpenTypes env tys
567 tidyPred env (IParam n ty)
568 = (env', IParam n ty')
570 (env', ty') = tidyOpenType env ty
572 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
573 tidyInst env (LitInst u lit ty loc)
574 = (env', LitInst u lit ty' loc)
576 (env', ty') = tidyOpenType env ty
578 tidyInst env (Dict u pred loc)
579 = (env', Dict u pred' loc)
581 (env', pred') = tidyPred env pred
583 tidyInst env (Method u id tys theta tau loc)
584 = (env', Method u id tys' theta tau loc)
585 -- Leave theta, tau alone cos we don't print them
587 (env', tys') = tidyOpenTypes env tys
589 -- this case shouldn't arise... (we never print fundeps)
590 tidyInst env fd@(FunDep _ clas fds loc)
593 tidyInsts env insts = mapAccumL tidyInst env insts
595 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
599 %************************************************************************
601 \subsection[InstEnv-types]{Type declarations}
603 %************************************************************************
606 data LookupInstResult s
608 | SimpleInst TcExpr -- Just a variable, type application, or literal
609 | GenInst [Inst] TcExpr -- The expression and its needed insts
612 -> NF_TcM (LookupInstResult s)
616 lookupInst dict@(Dict _ (Class clas tys) loc)
617 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
618 case lookupInstEnv inst_env clas tys of
620 FoundInst tenv dfun_id
622 subst = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv
623 (tyvars, rho) = splitForAllTys (idType dfun_id)
624 ty_args = map subst_tv tyvars
625 dfun_rho = substTy subst rho
626 (theta, _) = splitRhoTy dfun_rho
627 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
628 subst_tv tv = case lookupSubstEnv tenv tv of
629 Just (DoneTy ty) -> ty
630 -- tenv should bind all the tyvars
633 returnNF_Tc (SimpleInst ty_app)
635 newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
637 rhs = mkHsDictApp ty_app dict_ids
639 returnNF_Tc (GenInst dicts rhs)
641 other -> returnNF_Tc NoInstance
642 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
646 lookupInst inst@(Method _ id tys theta _ loc)
647 = newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
648 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
652 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
653 | isIntTy ty && in_int_range -- Short cut for Int
654 = returnNF_Tc (GenInst [] int_lit)
655 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
657 | isIntegerTy ty -- Short cut for Integer
658 = returnNF_Tc (GenInst [] integer_lit)
660 | in_int_range -- It's overloaded but small enough to fit into an Int
661 && from_integer_name `hasKey` fromIntegerClassOpKey -- And it's the built-in prelude fromInteger
662 -- (i.e. no funny business with user-defined
663 -- packages of numeric classes)
664 = -- So we can use the Prelude fromInt
665 tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int ->
666 newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
667 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
669 | otherwise -- Alas, it is overloaded and a big literal!
670 = tcLookupGlobalId from_integer_name `thenNF_Tc` \ from_integer ->
671 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
672 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
674 in_int_range = inIntRange i
675 integer_lit = HsLit (HsInteger i)
676 int_lit = HsLit (HsInt i)
678 -- similar idea for overloaded floating point literals: if the literal is
679 -- *definitely* a float or a double, generate the real thing here.
680 -- This is essential (see nofib/spectral/nucleic).
682 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
683 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
684 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
687 = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational ->
688 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
690 rational_ty = funArgTy (idType method_id)
691 rational_lit = HsLit (HsRat f rational_ty)
693 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
696 floatprim_lit = HsLit (HsFloatPrim f)
697 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
698 doubleprim_lit = HsLit (HsDoublePrim f)
699 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
701 -- there are no `instances' of functional dependencies or implicit params
703 lookupInst _ = returnNF_Tc NoInstance
707 There is a second, simpler interface, when you want an instance of a
708 class at a given nullary type constructor. It just returns the
709 appropriate dictionary if it exists. It is used only when resolving
710 ambiguous dictionaries.
713 lookupSimpleInst :: Class
714 -> [Type] -- Look up (c,t)
715 -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
717 lookupSimpleInst clas tys
718 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
719 case lookupInstEnv inst_env clas tys of
721 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
723 (_, theta, _) = splitSigmaTy (idType dfun)
724 theta' = map (\(Class clas tys) -> (clas,tys)) theta
726 other -> returnNF_Tc Nothing