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 newDictsFromOld, newDicts, newClassDicts,
15 newMethod, newMethodWithGivenTy, newOverloadedLit,
18 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
22 lookupInst, lookupSimpleInst, LookupInstResult(..),
24 isDict, isClassDict, isMethod, instMentionsIPs,
25 isTyVarDict, isStdClassTyVarDict, isMethodFor,
26 instBindingRequired, instCanBeGeneralised,
31 InstOrigin(..), InstLoc, pprInstLoc
34 #include "HsVersions.h"
36 import CmdLineOpts ( opt_NoMethodSharing )
37 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
38 import TcHsSyn ( TcExpr, TcId,
39 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
42 import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId )
43 import InstEnv ( InstLookupResult(..), lookupInstEnv )
44 import TcType ( TcThetaType, TcClassContext,
45 TcType, TcTauType, TcTyVarSet,
46 zonkTcType, zonkTcTypes,
47 zonkTcThetaType, tcInstTyVar, tcInstType
49 import CoreFVs ( idFreeTyVars )
50 import Class ( Class )
51 import Id ( Id, idType, mkUserLocal, mkSysLocal, mkVanillaId )
52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
53 import Name ( mkDictOcc, mkMethodOcc, getOccName, mkLocalName )
54 import NameSet ( NameSet )
55 import PprType ( pprPred )
56 import Type ( Type, PredType(..),
57 isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
58 splitForAllTys, splitSigmaTy, funArgTy,
59 splitMethodTy, splitRhoTy, classesOfPreds,
60 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
61 tidyOpenType, tidyOpenTypes, predMentionsIPs
63 import Subst ( emptyInScopeSet, mkSubst,
64 substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
66 import Literal ( inIntRange )
67 import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
68 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
69 import TysWiredIn ( isIntTy,
70 floatDataCon, isFloatTy,
71 doubleDataCon, isDoubleTy,
74 import PrelNames( fromIntegerName, fromRationalName )
75 import Util ( thenCmp, zipWithEqual, mapAccumL )
80 %************************************************************************
82 \subsection[Inst-collections]{LIE: a collection of Insts}
84 %************************************************************************
89 isEmptyLIE = isEmptyBag
91 unitLIE inst = unitBag inst
92 mkLIE insts = listToBag insts
93 plusLIE lie1 lie2 = lie1 `unionBags` lie2
94 consLIE inst lie = inst `consBag` lie
95 plusLIEs lies = unionManyBags lies
99 zonkLIE :: LIE -> NF_TcM LIE
100 zonkLIE lie = mapBagNF_Tc zonkInst lie
102 pprInsts :: [Inst] -> SDoc
103 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
107 = vcat (map go insts)
109 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
112 %************************************************************************
114 \subsection[Inst-types]{@Inst@ types}
116 %************************************************************************
118 An @Inst@ is either a dictionary, an instance of an overloaded
119 literal, or an instance of an overloaded value. We call the latter a
120 ``method'' even though it may not correspond to a class operation.
121 For example, we might have an instance of the @double@ function at
122 type Int, represented by
124 Method 34 doubleId [Int] origin
136 TcId -- The overloaded function
137 -- This function will be a global, local, or ClassOpId;
138 -- inside instance decls (only) it can also be an InstId!
139 -- The id needn't be completely polymorphic.
140 -- You'll probably find its name (for documentation purposes)
141 -- inside the InstOrigin
143 [TcType] -- The types to which its polymorphic tyvars
144 -- should be instantiated.
145 -- These types must saturate the Id's foralls.
147 TcThetaType -- The (types of the) dictionaries to which the function
148 -- must be applied to get the method
150 TcTauType -- The type of the method
154 -- INVARIANT: in (Method u f tys theta tau loc)
155 -- type of (f tys dicts(from theta)) = tau
159 HsOverLit -- The literal from the occurrence site
160 TcType -- The type at which the literal is used
166 @Insts@ are ordered by their class/type info, rather than by their
167 unique. This allows the context-reduction mechanism to use standard finite
168 maps to do their stuff.
171 instance Ord Inst where
174 instance Eq Inst where
175 (==) i1 i2 = case i1 `cmpInst` i2 of
179 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
180 cmpInst (Dict _ _ _) other = LT
182 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
183 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
184 cmpInst (Method _ _ _ _ _ _) other = LT
186 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
187 cmpInst (LitInst _ _ _ _) other = GT
189 -- and they can only have HsInt or HsFracs in them.
196 instToId :: Inst -> TcId
197 instToId (Dict id _ _) = id
198 instToId (Method id _ _ _ _ _) = id
199 instToId (LitInst id _ _ _) = id
201 instLoc (Dict _ _ loc) = loc
202 instLoc (Method _ _ _ _ _ loc) = loc
203 instLoc (LitInst _ _ _ loc) = loc
205 getDictClassTys (Dict _ (Class clas tys) _) = (clas, tys)
207 predsOfInsts :: [Inst] -> [PredType]
208 predsOfInsts insts = concatMap predsOfInst insts
210 predsOfInst (Dict _ pred _) = [pred]
211 predsOfInst (Method _ _ _ theta _ _) = theta
212 predsOfInst (LitInst _ _ _ _) = []
213 -- The last case is is really a big cheat
214 -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
215 -- But Num and Fractional have only one parameter and no functional
216 -- dependencies, so I think no caller of predsOfInst will care.
218 ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
220 getIPs inst = ipsOfPreds (predsOfInst inst)
222 tyVarsOfInst :: Inst -> TcTyVarSet
223 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
224 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
225 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
226 -- The id might have free type variables; in the case of
227 -- locally-overloaded class methods, for example
229 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
230 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
236 isDict :: Inst -> Bool
237 isDict (Dict _ _ _) = True
240 isClassDict :: Inst -> Bool
241 isClassDict (Dict _ (Class _ _) _) = True
242 isClassDict other = False
244 isMethod :: Inst -> Bool
245 isMethod (Method _ _ _ _ _ _) = True
246 isMethod other = False
248 isMethodFor :: TcIdSet -> Inst -> Bool
249 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
250 isMethodFor ids inst = False
252 instMentionsIPs :: Inst -> NameSet -> Bool
253 -- True if the Inst mentions any of the implicit
254 -- parameters in the supplied set of names
255 instMentionsIPs (Dict _ pred _) ip_names = pred `predMentionsIPs` ip_names
256 instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
257 instMentionsIPs other ip_names = False
259 isTyVarDict :: Inst -> Bool
260 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
261 isTyVarDict other = False
263 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
264 = isStandardClass clas && isTyVarTy ty
265 isStdClassTyVarDict other
269 Two predicates which deal with the case where class constraints don't
270 necessarily result in bindings. The first tells whether an @Inst@
271 must be witnessed by an actual binding; the second tells whether an
272 @Inst@ can be generalised over.
275 instBindingRequired :: Inst -> Bool
276 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
277 instBindingRequired (Dict _ (IParam _ _) _) = False
278 instBindingRequired other = True
280 instCanBeGeneralised :: Inst -> Bool
281 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
282 instCanBeGeneralised other = True
286 %************************************************************************
288 \subsection{Building dictionaries}
290 %************************************************************************
293 newDicts :: InstOrigin
297 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
298 newDictsAtLoc loc theta
300 newClassDicts :: InstOrigin
303 newClassDicts orig theta = newDicts orig (map (uncurry Class) theta)
305 newDictsFromOld :: Inst -> TcClassContext -> NF_TcM [Inst]
306 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc (map (uncurry Class) theta)
308 -- Local function, similar to newDicts,
309 -- but with slightly different interface
310 newDictsAtLoc :: InstLoc
313 newDictsAtLoc inst_loc@(_,loc,_) theta
314 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
315 returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
317 mk_dict uniq pred = Dict (mkVanillaId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc
319 mk_dict_name uniq (Class cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
320 mk_dict_name uniq (IParam name ty) = name
322 newIPDict orig name ty
323 = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
324 returnNF_Tc (Dict (mkVanillaId name ty) (IParam name ty) inst_loc)
328 %************************************************************************
330 \subsection{Building methods (calls of overloaded functions)}
332 %************************************************************************
334 tcInstId instantiates an occurrence of an Id.
335 The instantiate_it loop runs round instantiating the Id.
336 It has to be a loop because we are now prepared to entertain
338 f:: forall a. Eq a => forall b. Baz b => tau
339 We want to instantiate this to
340 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
342 The -fno-method-sharing flag controls what happens so far as the LIE
343 is concerned. The default case is that for an overloaded function we
344 generate a "method" Id, and add the Method Inst to the LIE. So you get
347 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
348 If you specify -fno-method-sharing, the dictionary application
349 isn't shared, so we get
351 f = /\a (d:Num a) (x:a) -> (+) a d x x
352 This gets a bit less sharing, but
353 a) it's better for RULEs involving overloaded functions
354 b) perhaps fewer separated lambdas
358 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
360 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
361 | otherwise = loop_share fun
363 orig = OccurrenceOf fun
364 loop_noshare fun fun_ty
365 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
367 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
369 if null theta then -- Is it overloaded?
370 returnNF_Tc (ty_app, emptyLIE, tau)
372 newDicts orig theta `thenNF_Tc` \ dicts ->
373 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
374 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
377 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
379 arg_tys = mkTyVarTys tyvars
381 if null theta then -- Is it overloaded?
382 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
384 -- Yes, it's overloaded
385 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
386 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
387 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
390 newMethod :: InstOrigin
394 newMethod orig id tys
395 = -- Get the Id type and instantiate it at the specified types
397 (tyvars, rho) = splitForAllTys (idType id)
398 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
399 (pred, tau) = splitMethodTy rho_ty
401 newMethodWithGivenTy orig id tys [pred] tau
403 newMethodWithGivenTy orig id tys theta tau
404 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
405 newMethodWith loc id tys theta tau
407 newMethodWith inst_loc@(_,loc,_) id tys theta tau
408 = tcGetUnique `thenNF_Tc` \ new_uniq ->
410 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
412 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
414 newMethodAtLoc :: InstLoc
416 -> NF_TcM (Inst, TcId)
417 newMethodAtLoc inst_loc real_id tys
418 -- This actually builds the Inst
419 = -- Get the Id type and instantiate it at the specified types
421 (tyvars,rho) = splitForAllTys (idType real_id)
422 rho_ty = ASSERT( length tyvars == length tys )
423 substTy (mkTopTyVarSubst tyvars tys) rho
424 (theta, tau) = splitRhoTy rho_ty
426 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
427 returnNF_Tc (meth_inst, instToId meth_inst)
430 In newOverloadedLit we convert directly to an Int or Integer if we
431 know that's what we want. This may save some time, by not
432 temporarily generating overloaded literals, but it won't catch all
433 cases (the rest are caught in lookupInst).
436 newOverloadedLit :: InstOrigin
439 -> NF_TcM (TcExpr, LIE)
440 newOverloadedLit orig (HsIntegral i) ty
441 | isIntTy ty && inIntRange i -- Short cut for Int
442 = returnNF_Tc (int_lit, emptyLIE)
444 | isIntegerTy ty -- Short cut for Integer
445 = returnNF_Tc (integer_lit, emptyLIE)
448 int_lit = HsLit (HsInt i)
449 integer_lit = HsLit (HsInteger i)
451 newOverloadedLit orig lit ty -- The general case
452 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
453 tcGetUnique `thenNF_Tc` \ new_uniq ->
455 lit_inst = LitInst lit_id lit ty loc
456 lit_id = mkSysLocal SLIT("lit") new_uniq ty
458 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
462 %************************************************************************
466 %************************************************************************
468 Zonking makes sure that the instance types are fully zonked,
469 but doesn't do the same for any of the Ids in an Inst. There's no
470 need, and it's a lot of extra work.
473 zonkPred :: TcPredType -> NF_TcM TcPredType
474 zonkPred (Class clas tys)
475 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
476 returnNF_Tc (Class clas new_tys)
477 zonkPred (IParam n ty)
478 = zonkTcType ty `thenNF_Tc` \ new_ty ->
479 returnNF_Tc (IParam n new_ty)
481 zonkInst :: Inst -> NF_TcM Inst
482 zonkInst (Dict id pred loc)
483 = zonkPred pred `thenNF_Tc` \ new_pred ->
484 returnNF_Tc (Dict id new_pred loc)
486 zonkInst (Method m id tys theta tau loc)
487 = zonkId id `thenNF_Tc` \ new_id ->
488 -- Essential to zonk the id in case it's a local variable
489 -- Can't use zonkIdOcc because the id might itself be
490 -- an InstId, in which case it won't be in scope
492 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
493 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
494 zonkTcType tau `thenNF_Tc` \ new_tau ->
495 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
497 zonkInst (LitInst id lit ty loc)
498 = zonkTcType ty `thenNF_Tc` \ new_ty ->
499 returnNF_Tc (LitInst id lit new_ty loc)
501 zonkInsts insts = mapNF_Tc zonkInst insts
505 %************************************************************************
507 \subsection{Printing}
509 %************************************************************************
511 ToDo: improve these pretty-printing things. The ``origin'' is really only
512 relevant in error messages.
515 instance Outputable Inst where
516 ppr inst = pprInst inst
518 pprInst (LitInst u lit ty loc)
519 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
521 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
523 pprInst m@(Method u id tys theta tau loc)
524 = hsep [ppr id, ptext SLIT("at"),
525 brackets (interppSP tys) {- ,
526 ptext SLIT("theta"), ppr theta,
527 ptext SLIT("tau"), ppr tau
531 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
532 tidyPred env (Class clas tys)
533 = (env', Class clas tys')
535 (env', tys') = tidyOpenTypes env tys
536 tidyPred env (IParam n ty)
537 = (env', IParam n ty')
539 (env', ty') = tidyOpenType env ty
541 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
542 tidyInst env (LitInst u lit ty loc)
543 = (env', LitInst u lit ty' loc)
545 (env', ty') = tidyOpenType env ty
547 tidyInst env (Dict u pred loc)
548 = (env', Dict u pred' loc)
550 (env', pred') = tidyPred env pred
552 tidyInst env (Method u id tys theta tau loc)
553 = (env', Method u id tys' theta tau loc)
554 -- Leave theta, tau alone cos we don't print them
556 (env', tys') = tidyOpenTypes env tys
558 tidyInsts env insts = mapAccumL tidyInst env insts
560 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
564 %************************************************************************
566 \subsection{Looking up Insts}
568 %************************************************************************
571 data LookupInstResult s
573 | SimpleInst TcExpr -- Just a variable, type application, or literal
574 | GenInst [Inst] TcExpr -- The expression and its needed insts
577 -> NF_TcM (LookupInstResult s)
581 lookupInst dict@(Dict _ (Class clas tys) loc)
582 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
583 case lookupInstEnv inst_env clas tys of
585 FoundInst tenv dfun_id
587 (tyvars, rho) = splitForAllTys (idType dfun_id)
588 mk_ty_arg tv = case lookupSubstEnv tenv tv of
589 Just (DoneTy ty) -> returnNF_Tc ty
590 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
591 returnTc (mkTyVarTy tc_tv)
593 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
595 subst = mkTyVarSubst tyvars ty_args
596 dfun_rho = substTy subst rho
597 (theta, _) = splitRhoTy dfun_rho
598 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
601 returnNF_Tc (SimpleInst ty_app)
603 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
605 rhs = mkHsDictApp ty_app (map instToId dicts)
607 returnNF_Tc (GenInst dicts rhs)
609 other -> returnNF_Tc NoInstance
611 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
615 lookupInst inst@(Method _ id tys theta _ loc)
616 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
617 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
621 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
622 | isIntTy ty && in_int_range -- Short cut for Int
623 = returnNF_Tc (GenInst [] int_lit)
624 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
626 | isIntegerTy ty -- Short cut for Integer
627 = returnNF_Tc (GenInst [] integer_lit)
629 | otherwise -- Alas, it is overloaded and a big literal!
630 = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer ->
631 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
632 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
634 in_int_range = inIntRange i
635 integer_lit = HsLit (HsInteger i)
636 int_lit = HsLit (HsInt i)
638 -- similar idea for overloaded floating point literals: if the literal is
639 -- *definitely* a float or a double, generate the real thing here.
640 -- This is essential (see nofib/spectral/nucleic).
642 lookupInst inst@(LitInst u (HsFractional f) ty loc)
643 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
644 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
647 = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational ->
648 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
650 rational_ty = funArgTy (idType method_id)
651 rational_lit = HsLit (HsRat f rational_ty)
653 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
656 floatprim_lit = HsLit (HsFloatPrim f)
657 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
658 doubleprim_lit = HsLit (HsDoublePrim f)
659 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
662 There is a second, simpler interface, when you want an instance of a
663 class at a given nullary type constructor. It just returns the
664 appropriate dictionary if it exists. It is used only when resolving
665 ambiguous dictionaries.
668 lookupSimpleInst :: Class
669 -> [Type] -- Look up (c,t)
670 -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
672 lookupSimpleInst clas tys
673 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
674 case lookupInstEnv inst_env clas tys of
676 -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
678 (_, theta, _) = splitSigmaTy (idType dfun)
679 theta' = classesOfPreds theta
681 other -> returnNF_Tc Nothing