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, tidyInsts,
14 newDictsFromOld, newDicts,
15 newMethod, newMethodWithGivenTy, newOverloadedLit,
18 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
20 predsOfInsts, predsOfInst,
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,
45 TcType, TcTauType, TcTyVarSet,
46 zonkTcType, zonkTcTypes, zonkTcPredType,
47 zonkTcThetaType, tcInstTyVar, tcInstType
49 import CoreFVs ( idFreeTyVars )
50 import Class ( Class )
51 import Id ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId )
52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
53 import Name ( mkMethodOcc, getOccName )
54 import NameSet ( NameSet )
55 import PprType ( pprPred )
56 import Type ( Type, PredType(..), ThetaType,
57 isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
58 splitForAllTys, splitSigmaTy, funArgTy,
59 splitMethodTy, splitRhoTy,
60 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
61 predMentionsIPs, isClassPred, isTyVarClassPred,
62 getClassPredTys, getClassPredTys_maybe, mkPredName,
63 tidyType, tidyTypes, tidyFreeTyVars
65 import Subst ( emptyInScopeSet, mkSubst,
66 substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
68 import Literal ( inIntRange )
69 import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
70 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
71 import TysWiredIn ( isIntTy,
72 floatDataCon, isFloatTy,
73 doubleDataCon, isDoubleTy,
76 import PrelNames( fromIntegerName, fromRationalName )
77 import Util ( thenCmp, zipWithEqual )
82 %************************************************************************
84 \subsection[Inst-collections]{LIE: a collection of Insts}
86 %************************************************************************
91 isEmptyLIE = isEmptyBag
93 unitLIE inst = unitBag inst
94 mkLIE insts = listToBag insts
95 plusLIE lie1 lie2 = lie1 `unionBags` lie2
96 consLIE inst lie = inst `consBag` lie
97 plusLIEs lies = unionManyBags lies
101 zonkLIE :: LIE -> NF_TcM LIE
102 zonkLIE lie = mapBagNF_Tc zonkInst lie
104 pprInsts :: [Inst] -> SDoc
105 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
109 = vcat (map go insts)
111 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
114 %************************************************************************
116 \subsection[Inst-types]{@Inst@ types}
118 %************************************************************************
120 An @Inst@ is either a dictionary, an instance of an overloaded
121 literal, or an instance of an overloaded value. We call the latter a
122 ``method'' even though it may not correspond to a class operation.
123 For example, we might have an instance of the @double@ function at
124 type Int, represented by
126 Method 34 doubleId [Int] origin
138 TcId -- The overloaded function
139 -- This function will be a global, local, or ClassOpId;
140 -- inside instance decls (only) it can also be an InstId!
141 -- The id needn't be completely polymorphic.
142 -- You'll probably find its name (for documentation purposes)
143 -- inside the InstOrigin
145 [TcType] -- The types to which its polymorphic tyvars
146 -- should be instantiated.
147 -- These types must saturate the Id's foralls.
149 TcThetaType -- The (types of the) dictionaries to which the function
150 -- must be applied to get the method
152 TcTauType -- The type of the method
156 -- INVARIANT: in (Method u f tys theta tau loc)
157 -- type of (f tys dicts(from theta)) = tau
161 HsOverLit -- The literal from the occurrence site
162 TcType -- The type at which the literal is used
168 @Insts@ are ordered by their class/type info, rather than by their
169 unique. This allows the context-reduction mechanism to use standard finite
170 maps to do their stuff.
173 instance Ord Inst where
176 instance Eq Inst where
177 (==) i1 i2 = case i1 `cmpInst` i2 of
181 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
182 cmpInst (Dict _ _ _) other = LT
184 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
185 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
186 cmpInst (Method _ _ _ _ _ _) other = LT
188 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
189 cmpInst (LitInst _ _ _ _) other = GT
191 -- and they can only have HsInt or HsFracs in them.
198 instToId :: Inst -> TcId
199 instToId (Dict id _ _) = id
200 instToId (Method id _ _ _ _ _) = id
201 instToId (LitInst id _ _ _) = id
203 instLoc (Dict _ _ loc) = loc
204 instLoc (Method _ _ _ _ _ loc) = loc
205 instLoc (LitInst _ _ _ loc) = loc
207 getDictClassTys (Dict _ pred _) = getClassPredTys pred
209 predsOfInsts :: [Inst] -> [PredType]
210 predsOfInsts insts = concatMap predsOfInst insts
212 predsOfInst (Dict _ pred _) = [pred]
213 predsOfInst (Method _ _ _ theta _ _) = theta
214 predsOfInst (LitInst _ _ _ _) = []
215 -- The last case is is really a big cheat
216 -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
217 -- But Num and Fractional have only one parameter and no functional
218 -- dependencies, so I think no caller of predsOfInst will care.
220 ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
222 getIPs inst = ipsOfPreds (predsOfInst inst)
224 tyVarsOfInst :: Inst -> TcTyVarSet
225 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
226 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
227 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
228 -- The id might have free type variables; in the case of
229 -- locally-overloaded class methods, for example
231 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
232 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
238 isDict :: Inst -> Bool
239 isDict (Dict _ _ _) = True
242 isClassDict :: Inst -> Bool
243 isClassDict (Dict _ pred _) = isClassPred pred
244 isClassDict other = False
246 isTyVarDict :: Inst -> Bool
247 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
248 isTyVarDict other = False
250 isMethod :: Inst -> Bool
251 isMethod (Method _ _ _ _ _ _) = True
252 isMethod other = False
254 isMethodFor :: TcIdSet -> Inst -> Bool
255 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
256 isMethodFor ids inst = False
258 instMentionsIPs :: Inst -> NameSet -> Bool
259 -- True if the Inst mentions any of the implicit
260 -- parameters in the supplied set of names
261 instMentionsIPs (Dict _ pred _) ip_names = pred `predMentionsIPs` ip_names
262 instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
263 instMentionsIPs other ip_names = False
265 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
266 Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty
270 Two predicates which deal with the case where class constraints don't
271 necessarily result in bindings. The first tells whether an @Inst@
272 must be witnessed by an actual binding; the second tells whether an
273 @Inst@ can be generalised over.
276 instBindingRequired :: Inst -> Bool
277 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
278 instBindingRequired (Dict _ (IParam _ _) _) = False
279 instBindingRequired other = True
281 instCanBeGeneralised :: Inst -> Bool
282 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
283 instCanBeGeneralised other = True
287 %************************************************************************
289 \subsection{Building dictionaries}
291 %************************************************************************
294 newDicts :: InstOrigin
298 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
299 newDictsAtLoc loc theta
301 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
302 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
304 -- Local function, similar to newDicts,
305 -- but with slightly different interface
306 newDictsAtLoc :: InstLoc
309 newDictsAtLoc inst_loc@(_,loc,_) theta
310 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
311 returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
313 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
315 newIPDict orig name ty
316 = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
317 returnNF_Tc (Dict (mkLocalId name ty) (IParam name ty) inst_loc)
321 %************************************************************************
323 \subsection{Building methods (calls of overloaded functions)}
325 %************************************************************************
327 tcInstId instantiates an occurrence of an Id.
328 The instantiate_it loop runs round instantiating the Id.
329 It has to be a loop because we are now prepared to entertain
331 f:: forall a. Eq a => forall b. Baz b => tau
332 We want to instantiate this to
333 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
335 The -fno-method-sharing flag controls what happens so far as the LIE
336 is concerned. The default case is that for an overloaded function we
337 generate a "method" Id, and add the Method Inst to the LIE. So you get
340 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
341 If you specify -fno-method-sharing, the dictionary application
342 isn't shared, so we get
344 f = /\a (d:Num a) (x:a) -> (+) a d x x
345 This gets a bit less sharing, but
346 a) it's better for RULEs involving overloaded functions
347 b) perhaps fewer separated lambdas
351 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
353 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
354 | otherwise = loop_share fun
356 orig = OccurrenceOf fun
357 loop_noshare fun fun_ty
358 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
360 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
362 if null theta then -- Is it overloaded?
363 returnNF_Tc (ty_app, emptyLIE, tau)
365 newDicts orig theta `thenNF_Tc` \ dicts ->
366 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
367 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
370 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
372 arg_tys = mkTyVarTys tyvars
374 if null theta then -- Is it overloaded?
375 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
377 -- Yes, it's overloaded
378 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
379 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
380 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
383 newMethod :: InstOrigin
387 newMethod orig id tys
388 = -- Get the Id type and instantiate it at the specified types
390 (tyvars, rho) = splitForAllTys (idType id)
391 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
392 (pred, tau) = splitMethodTy rho_ty
394 newMethodWithGivenTy orig id tys [pred] tau
396 newMethodWithGivenTy orig id tys theta tau
397 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
398 newMethodWith loc id tys theta tau
400 newMethodWith inst_loc@(_,loc,_) id tys theta tau
401 = tcGetUnique `thenNF_Tc` \ new_uniq ->
403 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
405 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
407 newMethodAtLoc :: InstLoc
409 -> NF_TcM (Inst, TcId)
410 newMethodAtLoc inst_loc real_id tys
411 -- This actually builds the Inst
412 = -- Get the Id type and instantiate it at the specified types
414 (tyvars,rho) = splitForAllTys (idType real_id)
415 rho_ty = ASSERT( length tyvars == length tys )
416 substTy (mkTopTyVarSubst tyvars tys) rho
417 (theta, tau) = splitRhoTy rho_ty
419 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
420 returnNF_Tc (meth_inst, instToId meth_inst)
423 In newOverloadedLit we convert directly to an Int or Integer if we
424 know that's what we want. This may save some time, by not
425 temporarily generating overloaded literals, but it won't catch all
426 cases (the rest are caught in lookupInst).
429 newOverloadedLit :: InstOrigin
432 -> NF_TcM (TcExpr, LIE)
433 newOverloadedLit orig (HsIntegral i) ty
434 | isIntTy ty && inIntRange i -- Short cut for Int
435 = returnNF_Tc (int_lit, emptyLIE)
437 | isIntegerTy ty -- Short cut for Integer
438 = returnNF_Tc (integer_lit, emptyLIE)
441 int_lit = HsLit (HsInt i)
442 integer_lit = HsLit (HsInteger i)
444 newOverloadedLit orig lit ty -- The general case
445 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
446 tcGetUnique `thenNF_Tc` \ new_uniq ->
448 lit_inst = LitInst lit_id lit ty loc
449 lit_id = mkSysLocal SLIT("lit") new_uniq ty
451 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
455 %************************************************************************
459 %************************************************************************
461 Zonking makes sure that the instance types are fully zonked,
462 but doesn't do the same for any of the Ids in an Inst. There's no
463 need, and it's a lot of extra work.
466 zonkInst :: Inst -> NF_TcM Inst
467 zonkInst (Dict id pred loc)
468 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
469 returnNF_Tc (Dict id new_pred loc)
471 zonkInst (Method m id tys theta tau loc)
472 = zonkId id `thenNF_Tc` \ new_id ->
473 -- Essential to zonk the id in case it's a local variable
474 -- Can't use zonkIdOcc because the id might itself be
475 -- an InstId, in which case it won't be in scope
477 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
478 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
479 zonkTcType tau `thenNF_Tc` \ new_tau ->
480 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
482 zonkInst (LitInst id lit ty loc)
483 = zonkTcType ty `thenNF_Tc` \ new_ty ->
484 returnNF_Tc (LitInst id lit new_ty loc)
486 zonkInsts insts = mapNF_Tc zonkInst insts
490 %************************************************************************
492 \subsection{Printing}
494 %************************************************************************
496 ToDo: improve these pretty-printing things. The ``origin'' is really only
497 relevant in error messages.
500 instance Outputable Inst where
501 ppr inst = pprInst inst
503 pprInst (LitInst u lit ty loc)
504 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
506 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
508 pprInst m@(Method u id tys theta tau loc)
509 = hsep [ppr id, ptext SLIT("at"),
510 brackets (interppSP tys) {- ,
511 ptext SLIT("theta"), ppr theta,
512 ptext SLIT("tau"), ppr tau
516 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
518 tidyInst :: TidyEnv -> Inst -> Inst
519 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
520 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
521 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
523 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
524 -- This function doesn't assume that the tyvars are in scope
525 -- so it works like tidyOpenType, returning a TidyEnv
527 = (env, map (tidyInst env) insts)
529 env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
533 %************************************************************************
535 \subsection{Looking up Insts}
537 %************************************************************************
540 data LookupInstResult s
542 | SimpleInst TcExpr -- Just a variable, type application, or literal
543 | GenInst [Inst] TcExpr -- The expression and its needed insts
546 -> NF_TcM (LookupInstResult s)
550 lookupInst dict@(Dict _ (ClassP clas tys) loc)
551 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
552 case lookupInstEnv inst_env clas tys of
554 FoundInst tenv dfun_id
556 (tyvars, rho) = splitForAllTys (idType dfun_id)
557 mk_ty_arg tv = case lookupSubstEnv tenv tv of
558 Just (DoneTy ty) -> returnNF_Tc ty
559 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
560 returnTc (mkTyVarTy tc_tv)
562 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
564 subst = mkTyVarSubst tyvars ty_args
565 dfun_rho = substTy subst rho
566 (theta, _) = splitRhoTy dfun_rho
567 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
570 returnNF_Tc (SimpleInst ty_app)
572 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
574 rhs = mkHsDictApp ty_app (map instToId dicts)
576 returnNF_Tc (GenInst dicts rhs)
578 other -> returnNF_Tc NoInstance
580 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
584 lookupInst inst@(Method _ id tys theta _ loc)
585 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
586 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
590 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
591 | isIntTy ty && in_int_range -- Short cut for Int
592 = returnNF_Tc (GenInst [] int_lit)
593 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
595 | isIntegerTy ty -- Short cut for Integer
596 = returnNF_Tc (GenInst [] integer_lit)
598 | otherwise -- Alas, it is overloaded and a big literal!
599 = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer ->
600 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
601 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
603 in_int_range = inIntRange i
604 integer_lit = HsLit (HsInteger i)
605 int_lit = HsLit (HsInt i)
607 -- similar idea for overloaded floating point literals: if the literal is
608 -- *definitely* a float or a double, generate the real thing here.
609 -- This is essential (see nofib/spectral/nucleic).
611 lookupInst inst@(LitInst u (HsFractional f) ty loc)
612 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
613 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
616 = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational ->
617 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
619 rational_ty = funArgTy (idType method_id)
620 rational_lit = HsLit (HsRat f rational_ty)
622 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
625 floatprim_lit = HsLit (HsFloatPrim f)
626 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
627 doubleprim_lit = HsLit (HsDoublePrim f)
628 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
631 There is a second, simpler interface, when you want an instance of a
632 class at a given nullary type constructor. It just returns the
633 appropriate dictionary if it exists. It is used only when resolving
634 ambiguous dictionaries.
637 lookupSimpleInst :: Class
638 -> [Type] -- Look up (c,t)
639 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
641 lookupSimpleInst clas tys
642 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
643 case lookupInstEnv inst_env clas tys of
645 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
647 (_, theta, _) = splitSigmaTy (idType dfun)
649 other -> returnNF_Tc Nothing