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, tidyMoreInsts,
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, tcLookupId )
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, substTyWith, 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 = substTyWith 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 lit ty
437 | Just expr <- shortCutLit lit ty
438 = returnNF_Tc (expr, emptyLIE)
441 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
442 tcGetUnique `thenNF_Tc` \ new_uniq ->
444 lit_inst = LitInst lit_id lit ty loc
445 lit_id = mkSysLocal SLIT("lit") new_uniq ty
447 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
449 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
450 shortCutLit (HsIntegral i fi) ty
451 | isIntTy ty && inIntRange i && fi == fromIntegerName -- Short cut for Int
452 = Just (HsLit (HsInt i))
453 | isIntegerTy ty && fi == fromIntegerName -- Short cut for Integer
454 = Just (HsLit (HsInteger i))
456 shortCutLit (HsFractional f fr) ty
457 | isFloatTy ty && fr == fromRationalName
458 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
459 | isDoubleTy ty && fr == fromRationalName
460 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
467 %************************************************************************
471 %************************************************************************
473 Zonking makes sure that the instance types are fully zonked,
474 but doesn't do the same for any of the Ids in an Inst. There's no
475 need, and it's a lot of extra work.
478 zonkInst :: Inst -> NF_TcM Inst
479 zonkInst (Dict id pred loc)
480 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
481 returnNF_Tc (Dict id new_pred loc)
483 zonkInst (Method m id tys theta tau loc)
484 = zonkId id `thenNF_Tc` \ new_id ->
485 -- Essential to zonk the id in case it's a local variable
486 -- Can't use zonkIdOcc because the id might itself be
487 -- an InstId, in which case it won't be in scope
489 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
490 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
491 zonkTcType tau `thenNF_Tc` \ new_tau ->
492 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
494 zonkInst (LitInst id lit ty loc)
495 = zonkTcType ty `thenNF_Tc` \ new_ty ->
496 returnNF_Tc (LitInst id lit new_ty loc)
498 zonkInsts insts = mapNF_Tc zonkInst insts
502 %************************************************************************
504 \subsection{Printing}
506 %************************************************************************
508 ToDo: improve these pretty-printing things. The ``origin'' is really only
509 relevant in error messages.
512 instance Outputable Inst where
513 ppr inst = pprInst inst
515 pprInst (LitInst u lit ty loc)
516 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
518 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
520 pprInst m@(Method u id tys theta tau loc)
521 = hsep [ppr id, ptext SLIT("at"),
522 brackets (interppSP tys) {- ,
523 ptext SLIT("theta"), ppr theta,
524 ptext SLIT("tau"), ppr tau
528 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
530 tidyInst :: TidyEnv -> Inst -> Inst
531 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
532 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
533 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
535 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
536 -- This function doesn't assume that the tyvars are in scope
537 -- so it works like tidyOpenType, returning a TidyEnv
538 tidyMoreInsts env insts
539 = (env', map (tidyInst env') insts)
541 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
543 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
544 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
548 %************************************************************************
550 \subsection{Looking up Insts}
552 %************************************************************************
555 data LookupInstResult s
557 | SimpleInst TcExpr -- Just a variable, type application, or literal
558 | GenInst [Inst] TcExpr -- The expression and its needed insts
561 -> NF_TcM (LookupInstResult s)
565 lookupInst dict@(Dict _ (ClassP clas tys) loc)
566 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
567 case lookupInstEnv inst_env clas tys of
569 FoundInst tenv dfun_id
571 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
572 mk_ty_arg tv = case lookupSubstEnv tenv tv of
573 Just (DoneTy ty) -> returnNF_Tc ty
574 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
575 returnTc (mkTyVarTy tc_tv)
577 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
579 subst = mkTyVarSubst tyvars ty_args
580 dfun_rho = substTy subst rho
581 (theta, _) = tcSplitRhoTy dfun_rho
582 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
585 returnNF_Tc (SimpleInst ty_app)
587 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
589 rhs = mkHsDictApp ty_app (map instToId dicts)
591 returnNF_Tc (GenInst dicts rhs)
593 other -> returnNF_Tc NoInstance
595 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
599 lookupInst inst@(Method _ id tys theta _ loc)
600 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
601 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
605 -- Look for short cuts first: if the literal is *definitely* a
606 -- int, integer, float or a double, generate the real thing here.
607 -- This is essential (see nofib/spectral/nucleic).
608 -- [Same shortcut as in newOverloadedLit, but we
609 -- may have done some unification by now]
611 lookupInst inst@(LitInst u lit ty loc)
612 | Just expr <- shortCutLit lit ty
613 = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because
614 -- expr may be a constructor application
616 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
617 = tcLookupId from_integer_name `thenNF_Tc` \ from_integer ->
618 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
619 returnNF_Tc (GenInst [method_inst]
620 (HsApp (HsVar method_id) (HsLit (HsInteger i))))
623 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
624 = tcLookupId from_rat_name `thenNF_Tc` \ from_rational ->
625 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
627 rational_ty = tcFunArgTy (idType method_id)
628 rational_lit = HsLit (HsRat f rational_ty)
630 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
633 There is a second, simpler interface, when you want an instance of a
634 class at a given nullary type constructor. It just returns the
635 appropriate dictionary if it exists. It is used only when resolving
636 ambiguous dictionaries.
639 lookupSimpleInst :: Class
640 -> [Type] -- Look up (c,t)
641 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
643 lookupSimpleInst clas tys
644 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
645 case lookupInstEnv inst_env clas tys of
647 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
649 (_, rho) = tcSplitForAllTys (idType dfun)
650 (theta,_) = tcSplitRhoTy rho
652 other -> returnNF_Tc Nothing