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, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
53 import Name ( 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 instName :: Inst -> Name
199 instName inst = idName (instToId inst)
201 instToId :: Inst -> TcId
202 instToId (Dict id _ _) = id
203 instToId (Method id _ _ _ _ _) = id
204 instToId (LitInst id _ _ _) = id
206 instLoc (Dict _ _ loc) = loc
207 instLoc (Method _ _ _ _ _ loc) = loc
208 instLoc (LitInst _ _ _ loc) = loc
210 getDictClassTys (Dict _ pred _) = getClassPredTys pred
212 predsOfInsts :: [Inst] -> [PredType]
213 predsOfInsts insts = concatMap predsOfInst insts
215 predsOfInst (Dict _ pred _) = [pred]
216 predsOfInst (Method _ _ _ theta _ _) = theta
217 predsOfInst (LitInst _ _ _ _) = []
218 -- The last case is is really a big cheat
219 -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
220 -- But Num and Fractional have only one parameter and no functional
221 -- dependencies, so I think no caller of predsOfInst will care.
223 ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
225 getIPs inst = ipsOfPreds (predsOfInst inst)
227 tyVarsOfInst :: Inst -> TcTyVarSet
228 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
229 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
230 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
231 -- The id might have free type variables; in the case of
232 -- locally-overloaded class methods, for example
234 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
235 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
241 isDict :: Inst -> Bool
242 isDict (Dict _ _ _) = True
245 isClassDict :: Inst -> Bool
246 isClassDict (Dict _ pred _) = isClassPred pred
247 isClassDict other = False
249 isTyVarDict :: Inst -> Bool
250 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
251 isTyVarDict other = False
253 isMethod :: Inst -> Bool
254 isMethod (Method _ _ _ _ _ _) = True
255 isMethod other = False
257 isMethodFor :: TcIdSet -> Inst -> Bool
258 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
259 isMethodFor ids inst = False
261 instMentionsIPs :: Inst -> NameSet -> Bool
262 -- True if the Inst mentions any of the implicit
263 -- parameters in the supplied set of names
264 instMentionsIPs (Dict _ pred _) ip_names = pred `predMentionsIPs` ip_names
265 instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
266 instMentionsIPs other ip_names = False
268 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
269 Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty
273 Two predicates which deal with the case where class constraints don't
274 necessarily result in bindings. The first tells whether an @Inst@
275 must be witnessed by an actual binding; the second tells whether an
276 @Inst@ can be generalised over.
279 instBindingRequired :: Inst -> Bool
280 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
281 instBindingRequired (Dict _ (IParam _ _) _) = False
282 instBindingRequired other = True
284 instCanBeGeneralised :: Inst -> Bool
285 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
286 instCanBeGeneralised other = True
290 %************************************************************************
292 \subsection{Building dictionaries}
294 %************************************************************************
297 newDicts :: InstOrigin
301 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
302 newDictsAtLoc loc theta
304 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
305 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
307 -- Local function, similar to newDicts,
308 -- but with slightly different interface
309 newDictsAtLoc :: InstLoc
312 newDictsAtLoc inst_loc@(_,loc,_) theta
313 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
314 returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
316 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
318 -- For implicit parameters, since there is only one in scope
319 -- at any time, we use the name of the implicit parameter itself
320 newIPDict orig name ty
321 = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
322 returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
323 where pred = IParam name ty
327 %************************************************************************
329 \subsection{Building methods (calls of overloaded functions)}
331 %************************************************************************
333 tcInstId instantiates an occurrence of an Id.
334 The instantiate_it loop runs round instantiating the Id.
335 It has to be a loop because we are now prepared to entertain
337 f:: forall a. Eq a => forall b. Baz b => tau
338 We want to instantiate this to
339 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
341 The -fno-method-sharing flag controls what happens so far as the LIE
342 is concerned. The default case is that for an overloaded function we
343 generate a "method" Id, and add the Method Inst to the LIE. So you get
346 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
347 If you specify -fno-method-sharing, the dictionary application
348 isn't shared, so we get
350 f = /\a (d:Num a) (x:a) -> (+) a d x x
351 This gets a bit less sharing, but
352 a) it's better for RULEs involving overloaded functions
353 b) perhaps fewer separated lambdas
357 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
359 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
360 | otherwise = loop_share fun
362 orig = OccurrenceOf fun
363 loop_noshare fun fun_ty
364 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
366 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
368 if null theta then -- Is it overloaded?
369 returnNF_Tc (ty_app, emptyLIE, tau)
371 newDicts orig theta `thenNF_Tc` \ dicts ->
372 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
373 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
376 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
378 arg_tys = mkTyVarTys tyvars
380 if null theta then -- Is it overloaded?
381 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
383 -- Yes, it's overloaded
384 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
385 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
386 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
389 newMethod :: InstOrigin
393 newMethod orig id tys
394 = -- Get the Id type and instantiate it at the specified types
396 (tyvars, rho) = splitForAllTys (idType id)
397 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
398 (pred, tau) = splitMethodTy rho_ty
400 newMethodWithGivenTy orig id tys [pred] tau
402 newMethodWithGivenTy orig id tys theta tau
403 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
404 newMethodWith loc id tys theta tau
406 newMethodWith inst_loc@(_,loc,_) id tys theta tau
407 = tcGetUnique `thenNF_Tc` \ new_uniq ->
409 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
411 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
413 newMethodAtLoc :: InstLoc
415 -> NF_TcM (Inst, TcId)
416 newMethodAtLoc inst_loc real_id tys
417 -- This actually builds the Inst
418 = -- Get the Id type and instantiate it at the specified types
420 (tyvars,rho) = splitForAllTys (idType real_id)
421 rho_ty = ASSERT( length tyvars == length tys )
422 substTy (mkTopTyVarSubst tyvars tys) rho
423 (theta, tau) = splitRhoTy rho_ty
425 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
426 returnNF_Tc (meth_inst, instToId meth_inst)
429 In newOverloadedLit we convert directly to an Int or Integer if we
430 know that's what we want. This may save some time, by not
431 temporarily generating overloaded literals, but it won't catch all
432 cases (the rest are caught in lookupInst).
435 newOverloadedLit :: InstOrigin
438 -> NF_TcM (TcExpr, LIE)
439 newOverloadedLit orig (HsIntegral i) ty
440 | isIntTy ty && inIntRange i -- Short cut for Int
441 = returnNF_Tc (int_lit, emptyLIE)
443 | isIntegerTy ty -- Short cut for Integer
444 = returnNF_Tc (integer_lit, emptyLIE)
447 int_lit = HsLit (HsInt i)
448 integer_lit = HsLit (HsInteger i)
450 newOverloadedLit orig lit ty -- The general case
451 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
452 tcGetUnique `thenNF_Tc` \ new_uniq ->
454 lit_inst = LitInst lit_id lit ty loc
455 lit_id = mkSysLocal SLIT("lit") new_uniq ty
457 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
461 %************************************************************************
465 %************************************************************************
467 Zonking makes sure that the instance types are fully zonked,
468 but doesn't do the same for any of the Ids in an Inst. There's no
469 need, and it's a lot of extra work.
472 zonkInst :: Inst -> NF_TcM Inst
473 zonkInst (Dict id pred loc)
474 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
475 returnNF_Tc (Dict id new_pred loc)
477 zonkInst (Method m id tys theta tau loc)
478 = zonkId id `thenNF_Tc` \ new_id ->
479 -- Essential to zonk the id in case it's a local variable
480 -- Can't use zonkIdOcc because the id might itself be
481 -- an InstId, in which case it won't be in scope
483 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
484 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
485 zonkTcType tau `thenNF_Tc` \ new_tau ->
486 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
488 zonkInst (LitInst id lit ty loc)
489 = zonkTcType ty `thenNF_Tc` \ new_ty ->
490 returnNF_Tc (LitInst id lit new_ty loc)
492 zonkInsts insts = mapNF_Tc zonkInst insts
496 %************************************************************************
498 \subsection{Printing}
500 %************************************************************************
502 ToDo: improve these pretty-printing things. The ``origin'' is really only
503 relevant in error messages.
506 instance Outputable Inst where
507 ppr inst = pprInst inst
509 pprInst (LitInst u lit ty loc)
510 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
512 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
514 pprInst m@(Method u id tys theta tau loc)
515 = hsep [ppr id, ptext SLIT("at"),
516 brackets (interppSP tys) {- ,
517 ptext SLIT("theta"), ppr theta,
518 ptext SLIT("tau"), ppr tau
522 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
524 tidyInst :: TidyEnv -> Inst -> Inst
525 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
526 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
527 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
529 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
530 -- This function doesn't assume that the tyvars are in scope
531 -- so it works like tidyOpenType, returning a TidyEnv
533 = (env, map (tidyInst env) insts)
535 env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
539 %************************************************************************
541 \subsection{Looking up Insts}
543 %************************************************************************
546 data LookupInstResult s
548 | SimpleInst TcExpr -- Just a variable, type application, or literal
549 | GenInst [Inst] TcExpr -- The expression and its needed insts
552 -> NF_TcM (LookupInstResult s)
556 lookupInst dict@(Dict _ (ClassP clas tys) loc)
557 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
558 case lookupInstEnv inst_env clas tys of
560 FoundInst tenv dfun_id
562 (tyvars, rho) = splitForAllTys (idType dfun_id)
563 mk_ty_arg tv = case lookupSubstEnv tenv tv of
564 Just (DoneTy ty) -> returnNF_Tc ty
565 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
566 returnTc (mkTyVarTy tc_tv)
568 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
570 subst = mkTyVarSubst tyvars ty_args
571 dfun_rho = substTy subst rho
572 (theta, _) = splitRhoTy dfun_rho
573 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
576 returnNF_Tc (SimpleInst ty_app)
578 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
580 rhs = mkHsDictApp ty_app (map instToId dicts)
582 returnNF_Tc (GenInst dicts rhs)
584 other -> returnNF_Tc NoInstance
586 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
590 lookupInst inst@(Method _ id tys theta _ loc)
591 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
592 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
596 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
597 | isIntTy ty && in_int_range -- Short cut for Int
598 = returnNF_Tc (GenInst [] int_lit)
599 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
601 | isIntegerTy ty -- Short cut for Integer
602 = returnNF_Tc (GenInst [] integer_lit)
604 | otherwise -- Alas, it is overloaded and a big literal!
605 = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer ->
606 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
607 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
609 in_int_range = inIntRange i
610 integer_lit = HsLit (HsInteger i)
611 int_lit = HsLit (HsInt i)
613 -- similar idea for overloaded floating point literals: if the literal is
614 -- *definitely* a float or a double, generate the real thing here.
615 -- This is essential (see nofib/spectral/nucleic).
617 lookupInst inst@(LitInst u (HsFractional f) ty loc)
618 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
619 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
622 = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational ->
623 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
625 rational_ty = funArgTy (idType method_id)
626 rational_lit = HsLit (HsRat f rational_ty)
628 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
631 floatprim_lit = HsLit (HsFloatPrim f)
632 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
633 doubleprim_lit = HsLit (HsDoublePrim f)
634 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
637 There is a second, simpler interface, when you want an instance of a
638 class at a given nullary type constructor. It just returns the
639 appropriate dictionary if it exists. It is used only when resolving
640 ambiguous dictionaries.
643 lookupSimpleInst :: Class
644 -> [Type] -- Look up (c,t)
645 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
647 lookupSimpleInst clas tys
648 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
649 case lookupInstEnv inst_env clas tys of
651 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
653 (_, theta, _) = splitSigmaTy (idType dfun)
655 other -> returnNF_Tc Nothing