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 TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
45 zonkTcThetaType, tcInstTyVar, tcInstType,
48 SourceType(..), PredType, ThetaType,
49 tcSplitForAllTys, tcSplitForAllTys,
50 tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy,
51 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
52 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
53 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
54 predMentionsIPs, isClassPred, isTyVarClassPred,
55 getClassPredTys, getClassPredTys_maybe, mkPredName,
56 tidyType, tidyTypes, tidyFreeTyVars,
57 tcCmpType, tcCmpTypes, tcCmpPred
59 import CoreFVs ( idFreeTyVars )
60 import Class ( Class )
61 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
62 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
63 import Name ( Name, mkMethodOcc, getOccName )
64 import NameSet ( NameSet )
65 import PprType ( pprPred )
66 import Subst ( emptyInScopeSet, mkSubst,
67 substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
69 import Literal ( inIntRange )
70 import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
71 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
72 import TysWiredIn ( floatDataCon, doubleDataCon )
73 import PrelNames( fromIntegerName, fromRationalName )
74 import Util ( thenCmp )
79 %************************************************************************
81 \subsection[Inst-collections]{LIE: a collection of Insts}
83 %************************************************************************
88 isEmptyLIE = isEmptyBag
90 unitLIE inst = unitBag inst
91 mkLIE insts = listToBag insts
92 plusLIE lie1 lie2 = lie1 `unionBags` lie2
93 consLIE inst lie = inst `consBag` lie
94 plusLIEs lies = unionManyBags lies
98 zonkLIE :: LIE -> NF_TcM LIE
99 zonkLIE lie = mapBagNF_Tc zonkInst lie
101 pprInsts :: [Inst] -> SDoc
102 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
106 = vcat (map go insts)
108 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
111 %************************************************************************
113 \subsection[Inst-types]{@Inst@ types}
115 %************************************************************************
117 An @Inst@ is either a dictionary, an instance of an overloaded
118 literal, or an instance of an overloaded value. We call the latter a
119 ``method'' even though it may not correspond to a class operation.
120 For example, we might have an instance of the @double@ function at
121 type Int, represented by
123 Method 34 doubleId [Int] origin
135 TcId -- The overloaded function
136 -- This function will be a global, local, or ClassOpId;
137 -- inside instance decls (only) it can also be an InstId!
138 -- The id needn't be completely polymorphic.
139 -- You'll probably find its name (for documentation purposes)
140 -- inside the InstOrigin
142 [TcType] -- The types to which its polymorphic tyvars
143 -- should be instantiated.
144 -- These types must saturate the Id's foralls.
146 TcThetaType -- The (types of the) dictionaries to which the function
147 -- must be applied to get the method
149 TcTauType -- The type of the method
153 -- INVARIANT: in (Method u f tys theta tau loc)
154 -- type of (f tys dicts(from theta)) = tau
158 HsOverLit -- The literal from the occurrence site
159 TcType -- The type at which the literal is used
165 @Insts@ are ordered by their class/type info, rather than by their
166 unique. This allows the context-reduction mechanism to use standard finite
167 maps to do their stuff.
170 instance Ord Inst where
173 instance Eq Inst where
174 (==) i1 i2 = case i1 `cmpInst` i2 of
178 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
179 cmpInst (Dict _ _ _) other = LT
181 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
182 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
183 cmpInst (Method _ _ _ _ _ _) other = LT
185 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
186 cmpInst (LitInst _ _ _ _) other = GT
188 -- and they can only have HsInt or HsFracs in them.
195 instName :: Inst -> Name
196 instName inst = idName (instToId inst)
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 && tcIsTyVarTy 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 `thenNF_Tc` \ new_uniqs ->
311 returnNF_Tc (zipWith mk_dict new_uniqs theta)
313 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
315 -- For implicit parameters, since there is only one in scope
316 -- at any time, we use the name of the implicit parameter itself
317 newIPDict orig name ty
318 = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
319 returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
320 where pred = IParam name ty
324 %************************************************************************
326 \subsection{Building methods (calls of overloaded functions)}
328 %************************************************************************
330 tcInstId instantiates an occurrence of an Id.
331 The instantiate_it loop runs round instantiating the Id.
332 It has to be a loop because we are now prepared to entertain
334 f:: forall a. Eq a => forall b. Baz b => tau
335 We want to instantiate this to
336 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
338 The -fno-method-sharing flag controls what happens so far as the LIE
339 is concerned. The default case is that for an overloaded function we
340 generate a "method" Id, and add the Method Inst to the LIE. So you get
343 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
344 If you specify -fno-method-sharing, the dictionary application
345 isn't shared, so we get
347 f = /\a (d:Num a) (x:a) -> (+) a d x x
348 This gets a bit less sharing, but
349 a) it's better for RULEs involving overloaded functions
350 b) perhaps fewer separated lambdas
354 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
356 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
357 | otherwise = loop_share fun
359 orig = OccurrenceOf fun
360 loop_noshare fun fun_ty
361 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
363 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
365 if null theta then -- Is it overloaded?
366 returnNF_Tc (ty_app, emptyLIE, tau)
368 newDicts orig theta `thenNF_Tc` \ dicts ->
369 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
370 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
373 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
375 arg_tys = mkTyVarTys tyvars
377 if null theta then -- Is it overloaded?
378 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
380 -- Yes, it's overloaded
381 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
382 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
383 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
386 newMethod :: InstOrigin
390 newMethod orig id tys
391 = -- Get the Id type and instantiate it at the specified types
393 (tyvars, rho) = tcSplitForAllTys (idType id)
394 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
395 (pred, tau) = tcSplitMethodTy rho_ty
397 newMethodWithGivenTy orig id tys [pred] tau
399 newMethodWithGivenTy orig id tys theta tau
400 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
401 newMethodWith loc id tys theta tau
403 newMethodWith inst_loc@(_,loc,_) id tys theta tau
404 = tcGetUnique `thenNF_Tc` \ new_uniq ->
406 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
408 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
410 newMethodAtLoc :: InstLoc
412 -> NF_TcM (Inst, TcId)
413 newMethodAtLoc inst_loc real_id tys
414 -- This actually builds the Inst
415 = -- Get the Id type and instantiate it at the specified types
417 (tyvars,rho) = tcSplitForAllTys (idType real_id)
418 rho_ty = ASSERT( length tyvars == length tys )
419 substTy (mkTopTyVarSubst tyvars tys) rho
420 (theta, tau) = tcSplitRhoTy rho_ty
422 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
423 returnNF_Tc (meth_inst, instToId meth_inst)
426 In newOverloadedLit we convert directly to an Int or Integer if we
427 know that's what we want. This may save some time, by not
428 temporarily generating overloaded literals, but it won't catch all
429 cases (the rest are caught in lookupInst).
432 newOverloadedLit :: InstOrigin
435 -> NF_TcM (TcExpr, LIE)
436 newOverloadedLit orig (HsIntegral i) ty
437 | isIntTy ty && inIntRange i -- Short cut for Int
438 = returnNF_Tc (int_lit, emptyLIE)
440 | isIntegerTy ty -- Short cut for Integer
441 = returnNF_Tc (integer_lit, emptyLIE)
444 int_lit = HsLit (HsInt i)
445 integer_lit = HsLit (HsInteger i)
447 newOverloadedLit orig lit ty -- The general case
448 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
449 tcGetUnique `thenNF_Tc` \ new_uniq ->
451 lit_inst = LitInst lit_id lit ty loc
452 lit_id = mkSysLocal SLIT("lit") new_uniq ty
454 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
458 %************************************************************************
462 %************************************************************************
464 Zonking makes sure that the instance types are fully zonked,
465 but doesn't do the same for any of the Ids in an Inst. There's no
466 need, and it's a lot of extra work.
469 zonkInst :: Inst -> NF_TcM Inst
470 zonkInst (Dict id pred loc)
471 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
472 returnNF_Tc (Dict id new_pred loc)
474 zonkInst (Method m id tys theta tau loc)
475 = zonkId id `thenNF_Tc` \ new_id ->
476 -- Essential to zonk the id in case it's a local variable
477 -- Can't use zonkIdOcc because the id might itself be
478 -- an InstId, in which case it won't be in scope
480 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
481 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
482 zonkTcType tau `thenNF_Tc` \ new_tau ->
483 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
485 zonkInst (LitInst id lit ty loc)
486 = zonkTcType ty `thenNF_Tc` \ new_ty ->
487 returnNF_Tc (LitInst id lit new_ty loc)
489 zonkInsts insts = mapNF_Tc zonkInst insts
493 %************************************************************************
495 \subsection{Printing}
497 %************************************************************************
499 ToDo: improve these pretty-printing things. The ``origin'' is really only
500 relevant in error messages.
503 instance Outputable Inst where
504 ppr inst = pprInst inst
506 pprInst (LitInst u lit ty loc)
507 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
509 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
511 pprInst m@(Method u id tys theta tau loc)
512 = hsep [ppr id, ptext SLIT("at"),
513 brackets (interppSP tys) {- ,
514 ptext SLIT("theta"), ppr theta,
515 ptext SLIT("tau"), ppr tau
519 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
521 tidyInst :: TidyEnv -> Inst -> Inst
522 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
523 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
524 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
526 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
527 -- This function doesn't assume that the tyvars are in scope
528 -- so it works like tidyOpenType, returning a TidyEnv
530 = (env, map (tidyInst env) insts)
532 env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
536 %************************************************************************
538 \subsection{Looking up Insts}
540 %************************************************************************
543 data LookupInstResult s
545 | SimpleInst TcExpr -- Just a variable, type application, or literal
546 | GenInst [Inst] TcExpr -- The expression and its needed insts
549 -> NF_TcM (LookupInstResult s)
553 lookupInst dict@(Dict _ (ClassP clas tys) loc)
554 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
555 case lookupInstEnv inst_env clas tys of
557 FoundInst tenv dfun_id
559 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
560 mk_ty_arg tv = case lookupSubstEnv tenv tv of
561 Just (DoneTy ty) -> returnNF_Tc ty
562 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
563 returnTc (mkTyVarTy tc_tv)
565 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
567 subst = mkTyVarSubst tyvars ty_args
568 dfun_rho = substTy subst rho
569 (theta, _) = tcSplitRhoTy dfun_rho
570 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
573 returnNF_Tc (SimpleInst ty_app)
575 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
577 rhs = mkHsDictApp ty_app (map instToId dicts)
579 returnNF_Tc (GenInst dicts rhs)
581 other -> returnNF_Tc NoInstance
583 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
587 lookupInst inst@(Method _ id tys theta _ loc)
588 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
589 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
593 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
594 | isIntTy ty && in_int_range -- Short cut for Int
595 = returnNF_Tc (GenInst [] int_lit)
596 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
598 | isIntegerTy ty -- Short cut for Integer
599 = returnNF_Tc (GenInst [] integer_lit)
601 | otherwise -- Alas, it is overloaded and a big literal!
602 = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer ->
603 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
604 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
606 in_int_range = inIntRange i
607 integer_lit = HsLit (HsInteger i)
608 int_lit = HsLit (HsInt i)
610 -- similar idea for overloaded floating point literals: if the literal is
611 -- *definitely* a float or a double, generate the real thing here.
612 -- This is essential (see nofib/spectral/nucleic).
614 lookupInst inst@(LitInst u (HsFractional f) ty loc)
615 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
616 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
619 = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational ->
620 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
622 rational_ty = tcFunArgTy (idType method_id)
623 rational_lit = HsLit (HsRat f rational_ty)
625 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
628 floatprim_lit = HsLit (HsFloatPrim f)
629 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
630 doubleprim_lit = HsLit (HsDoublePrim f)
631 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
634 There is a second, simpler interface, when you want an instance of a
635 class at a given nullary type constructor. It just returns the
636 appropriate dictionary if it exists. It is used only when resolving
637 ambiguous dictionaries.
640 lookupSimpleInst :: Class
641 -> [Type] -- Look up (c,t)
642 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
644 lookupSimpleInst clas tys
645 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
646 case lookupInstEnv inst_env clas tys of
648 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
650 (_, rho) = tcSplitForAllTys (idType dfun)
651 (theta,_) = tcSplitRhoTy rho
653 other -> returnNF_Tc Nothing