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 (mkPredTy pred)) pred inst_loc)
318 where pred = IParam name ty
322 %************************************************************************
324 \subsection{Building methods (calls of overloaded functions)}
326 %************************************************************************
328 tcInstId instantiates an occurrence of an Id.
329 The instantiate_it loop runs round instantiating the Id.
330 It has to be a loop because we are now prepared to entertain
332 f:: forall a. Eq a => forall b. Baz b => tau
333 We want to instantiate this to
334 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
336 The -fno-method-sharing flag controls what happens so far as the LIE
337 is concerned. The default case is that for an overloaded function we
338 generate a "method" Id, and add the Method Inst to the LIE. So you get
341 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
342 If you specify -fno-method-sharing, the dictionary application
343 isn't shared, so we get
345 f = /\a (d:Num a) (x:a) -> (+) a d x x
346 This gets a bit less sharing, but
347 a) it's better for RULEs involving overloaded functions
348 b) perhaps fewer separated lambdas
352 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
354 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
355 | otherwise = loop_share fun
357 orig = OccurrenceOf fun
358 loop_noshare fun fun_ty
359 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
361 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
363 if null theta then -- Is it overloaded?
364 returnNF_Tc (ty_app, emptyLIE, tau)
366 newDicts orig theta `thenNF_Tc` \ dicts ->
367 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
368 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
371 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
373 arg_tys = mkTyVarTys tyvars
375 if null theta then -- Is it overloaded?
376 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
378 -- Yes, it's overloaded
379 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
380 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
381 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
384 newMethod :: InstOrigin
388 newMethod orig id tys
389 = -- Get the Id type and instantiate it at the specified types
391 (tyvars, rho) = splitForAllTys (idType id)
392 rho_ty = substTy (mkTyVarSubst tyvars tys) rho
393 (pred, tau) = splitMethodTy rho_ty
395 newMethodWithGivenTy orig id tys [pred] tau
397 newMethodWithGivenTy orig id tys theta tau
398 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
399 newMethodWith loc id tys theta tau
401 newMethodWith inst_loc@(_,loc,_) id tys theta tau
402 = tcGetUnique `thenNF_Tc` \ new_uniq ->
404 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
406 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
408 newMethodAtLoc :: InstLoc
410 -> NF_TcM (Inst, TcId)
411 newMethodAtLoc inst_loc real_id tys
412 -- This actually builds the Inst
413 = -- Get the Id type and instantiate it at the specified types
415 (tyvars,rho) = splitForAllTys (idType real_id)
416 rho_ty = ASSERT( length tyvars == length tys )
417 substTy (mkTopTyVarSubst tyvars tys) rho
418 (theta, tau) = splitRhoTy rho_ty
420 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
421 returnNF_Tc (meth_inst, instToId meth_inst)
424 In newOverloadedLit we convert directly to an Int or Integer if we
425 know that's what we want. This may save some time, by not
426 temporarily generating overloaded literals, but it won't catch all
427 cases (the rest are caught in lookupInst).
430 newOverloadedLit :: InstOrigin
433 -> NF_TcM (TcExpr, LIE)
434 newOverloadedLit orig (HsIntegral i) ty
435 | isIntTy ty && inIntRange i -- Short cut for Int
436 = returnNF_Tc (int_lit, emptyLIE)
438 | isIntegerTy ty -- Short cut for Integer
439 = returnNF_Tc (integer_lit, emptyLIE)
442 int_lit = HsLit (HsInt i)
443 integer_lit = HsLit (HsInteger i)
445 newOverloadedLit orig lit ty -- The general case
446 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
447 tcGetUnique `thenNF_Tc` \ new_uniq ->
449 lit_inst = LitInst lit_id lit ty loc
450 lit_id = mkSysLocal SLIT("lit") new_uniq ty
452 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
456 %************************************************************************
460 %************************************************************************
462 Zonking makes sure that the instance types are fully zonked,
463 but doesn't do the same for any of the Ids in an Inst. There's no
464 need, and it's a lot of extra work.
467 zonkInst :: Inst -> NF_TcM Inst
468 zonkInst (Dict id pred loc)
469 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
470 returnNF_Tc (Dict id new_pred loc)
472 zonkInst (Method m id tys theta tau loc)
473 = zonkId id `thenNF_Tc` \ new_id ->
474 -- Essential to zonk the id in case it's a local variable
475 -- Can't use zonkIdOcc because the id might itself be
476 -- an InstId, in which case it won't be in scope
478 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
479 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
480 zonkTcType tau `thenNF_Tc` \ new_tau ->
481 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
483 zonkInst (LitInst id lit ty loc)
484 = zonkTcType ty `thenNF_Tc` \ new_ty ->
485 returnNF_Tc (LitInst id lit new_ty loc)
487 zonkInsts insts = mapNF_Tc zonkInst insts
491 %************************************************************************
493 \subsection{Printing}
495 %************************************************************************
497 ToDo: improve these pretty-printing things. The ``origin'' is really only
498 relevant in error messages.
501 instance Outputable Inst where
502 ppr inst = pprInst inst
504 pprInst (LitInst u lit ty loc)
505 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
507 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
509 pprInst m@(Method u id tys theta tau loc)
510 = hsep [ppr id, ptext SLIT("at"),
511 brackets (interppSP tys) {- ,
512 ptext SLIT("theta"), ppr theta,
513 ptext SLIT("tau"), ppr tau
517 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
519 tidyInst :: TidyEnv -> Inst -> Inst
520 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
521 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
522 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
524 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
525 -- This function doesn't assume that the tyvars are in scope
526 -- so it works like tidyOpenType, returning a TidyEnv
528 = (env, map (tidyInst env) insts)
530 env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
534 %************************************************************************
536 \subsection{Looking up Insts}
538 %************************************************************************
541 data LookupInstResult s
543 | SimpleInst TcExpr -- Just a variable, type application, or literal
544 | GenInst [Inst] TcExpr -- The expression and its needed insts
547 -> NF_TcM (LookupInstResult s)
551 lookupInst dict@(Dict _ (ClassP clas tys) loc)
552 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
553 case lookupInstEnv inst_env clas tys of
555 FoundInst tenv dfun_id
557 (tyvars, rho) = splitForAllTys (idType dfun_id)
558 mk_ty_arg tv = case lookupSubstEnv tenv tv of
559 Just (DoneTy ty) -> returnNF_Tc ty
560 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
561 returnTc (mkTyVarTy tc_tv)
563 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
565 subst = mkTyVarSubst tyvars ty_args
566 dfun_rho = substTy subst rho
567 (theta, _) = splitRhoTy dfun_rho
568 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
571 returnNF_Tc (SimpleInst ty_app)
573 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
575 rhs = mkHsDictApp ty_app (map instToId dicts)
577 returnNF_Tc (GenInst dicts rhs)
579 other -> returnNF_Tc NoInstance
581 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
585 lookupInst inst@(Method _ id tys theta _ loc)
586 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
587 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
591 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
592 | isIntTy ty && in_int_range -- Short cut for Int
593 = returnNF_Tc (GenInst [] int_lit)
594 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
596 | isIntegerTy ty -- Short cut for Integer
597 = returnNF_Tc (GenInst [] integer_lit)
599 | otherwise -- Alas, it is overloaded and a big literal!
600 = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer ->
601 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
602 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
604 in_int_range = inIntRange i
605 integer_lit = HsLit (HsInteger i)
606 int_lit = HsLit (HsInt i)
608 -- similar idea for overloaded floating point literals: if the literal is
609 -- *definitely* a float or a double, generate the real thing here.
610 -- This is essential (see nofib/spectral/nucleic).
612 lookupInst inst@(LitInst u (HsFractional f) ty loc)
613 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
614 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
617 = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational ->
618 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
620 rational_ty = funArgTy (idType method_id)
621 rational_lit = HsLit (HsRat f rational_ty)
623 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
626 floatprim_lit = HsLit (HsFloatPrim f)
627 float_lit = mkHsConApp floatDataCon [] [floatprim_lit]
628 doubleprim_lit = HsLit (HsDoublePrim f)
629 double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit]
632 There is a second, simpler interface, when you want an instance of a
633 class at a given nullary type constructor. It just returns the
634 appropriate dictionary if it exists. It is used only when resolving
635 ambiguous dictionaries.
638 lookupSimpleInst :: Class
639 -> [Type] -- Look up (c,t)
640 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
642 lookupSimpleInst clas tys
643 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
644 case lookupInstEnv inst_env clas tys of
646 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
648 (_, theta, _) = splitSigmaTy (idType dfun)
650 other -> returnNF_Tc Nothing