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,
19 ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
20 instLoc, getDictClassTys,
22 lookupInst, lookupSimpleInst, LookupInstResult(..),
24 isDict, isClassDict, isMethod,
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 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, equalLength )
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 ipNamesOfInsts :: [Inst] -> [Name]
221 ipNamesOfInst :: Inst -> [Name]
222 -- Get the implicit parameters mentioned by these Insts
224 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
226 ipNamesOfInst (Dict _ (IParam n _) _) = [n]
227 ipNamesOfInst (Method _ _ _ theta _ _) = [n | IParam n _ <- theta]
228 ipNamesOfInst other = []
230 tyVarsOfInst :: Inst -> TcTyVarSet
231 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
232 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
233 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
234 -- The id might have free type variables; in the case of
235 -- locally-overloaded class methods, for example
237 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
238 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
244 isDict :: Inst -> Bool
245 isDict (Dict _ _ _) = True
248 isClassDict :: Inst -> Bool
249 isClassDict (Dict _ pred _) = isClassPred pred
250 isClassDict other = False
252 isTyVarDict :: Inst -> Bool
253 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
254 isTyVarDict other = False
256 isMethod :: Inst -> Bool
257 isMethod (Method _ _ _ _ _ _) = True
258 isMethod other = False
260 isMethodFor :: TcIdSet -> Inst -> Bool
261 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
262 isMethodFor ids inst = False
264 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
265 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
269 Two predicates which deal with the case where class constraints don't
270 necessarily result in bindings. The first tells whether an @Inst@
271 must be witnessed by an actual binding; the second tells whether an
272 @Inst@ can be generalised over.
275 instBindingRequired :: Inst -> Bool
276 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
277 instBindingRequired (Dict _ (IParam _ _) _) = False
278 instBindingRequired other = True
280 instCanBeGeneralised :: Inst -> Bool
281 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
282 instCanBeGeneralised other = True
286 %************************************************************************
288 \subsection{Building dictionaries}
290 %************************************************************************
293 newDicts :: InstOrigin
297 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
298 newDictsAtLoc loc theta
300 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
301 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
303 -- Local function, similar to newDicts,
304 -- but with slightly different interface
305 newDictsAtLoc :: InstLoc
308 newDictsAtLoc inst_loc@(_,loc,_) theta
309 = tcGetUniques `thenNF_Tc` \ new_uniqs ->
310 returnNF_Tc (zipWith mk_dict new_uniqs theta)
312 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
314 -- For implicit parameters, since there is only one in scope
315 -- at any time, we use the name of the implicit parameter itself
316 newIPDict orig name ty
317 = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
318 returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
319 where pred = IParam name ty
323 %************************************************************************
325 \subsection{Building methods (calls of overloaded functions)}
327 %************************************************************************
329 tcInstId instantiates an occurrence of an Id.
330 The instantiate_it loop runs round instantiating the Id.
331 It has to be a loop because we are now prepared to entertain
333 f:: forall a. Eq a => forall b. Baz b => tau
334 We want to instantiate this to
335 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
337 The -fno-method-sharing flag controls what happens so far as the LIE
338 is concerned. The default case is that for an overloaded function we
339 generate a "method" Id, and add the Method Inst to the LIE. So you get
342 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
343 If you specify -fno-method-sharing, the dictionary application
344 isn't shared, so we get
346 f = /\a (d:Num a) (x:a) -> (+) a d x x
347 This gets a bit less sharing, but
348 a) it's better for RULEs involving overloaded functions
349 b) perhaps fewer separated lambdas
353 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
355 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
356 | otherwise = loop_share fun
358 orig = OccurrenceOf fun
359 loop_noshare fun fun_ty
360 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
362 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
364 if null theta then -- Is it overloaded?
365 returnNF_Tc (ty_app, emptyLIE, tau)
367 newDicts orig theta `thenNF_Tc` \ dicts ->
368 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
369 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
372 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
374 arg_tys = mkTyVarTys tyvars
376 if null theta then -- Is it overloaded?
377 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
379 -- Yes, it's overloaded
380 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
381 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
382 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
385 newMethod :: InstOrigin
389 newMethod orig id tys
390 = -- Get the Id type and instantiate it at the specified types
392 (tyvars, rho) = tcSplitForAllTys (idType id)
393 rho_ty = substTyWith tyvars tys rho
394 (pred, tau) = tcSplitMethodTy rho_ty
396 newMethodWithGivenTy orig id tys [pred] tau
398 newMethodWithGivenTy orig id tys theta tau
399 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
400 newMethodWith loc id tys theta tau
402 newMethodWith inst_loc@(_,loc,_) id tys theta tau
403 = tcGetUnique `thenNF_Tc` \ new_uniq ->
405 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
407 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
409 newMethodAtLoc :: InstLoc
411 -> NF_TcM (Inst, TcId)
412 newMethodAtLoc inst_loc real_id tys
413 -- This actually builds the Inst
414 = -- Get the Id type and instantiate it at the specified types
416 (tyvars,rho) = tcSplitForAllTys (idType real_id)
417 rho_ty = ASSERT( equalLength tyvars tys )
418 substTy (mkTopTyVarSubst tyvars tys) rho
419 (theta, tau) = tcSplitRhoTy rho_ty
421 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
422 returnNF_Tc (meth_inst, instToId meth_inst)
425 In newOverloadedLit we convert directly to an Int or Integer if we
426 know that's what we want. This may save some time, by not
427 temporarily generating overloaded literals, but it won't catch all
428 cases (the rest are caught in lookupInst).
431 newOverloadedLit :: InstOrigin
434 -> NF_TcM (TcExpr, LIE)
435 newOverloadedLit orig lit ty
436 | Just expr <- shortCutLit lit ty
437 = returnNF_Tc (expr, emptyLIE)
440 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
441 tcGetUnique `thenNF_Tc` \ new_uniq ->
443 lit_inst = LitInst lit_id lit ty loc
444 lit_id = mkSysLocal SLIT("lit") new_uniq ty
446 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
448 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
449 shortCutLit (HsIntegral i fi) ty
450 | isIntTy ty && inIntRange i && fi == fromIntegerName -- Short cut for Int
451 = Just (HsLit (HsInt i))
452 | isIntegerTy ty && fi == fromIntegerName -- Short cut for Integer
453 = Just (HsLit (HsInteger i))
455 shortCutLit (HsFractional f fr) ty
456 | isFloatTy ty && fr == fromRationalName
457 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
458 | isDoubleTy ty && fr == fromRationalName
459 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
466 %************************************************************************
470 %************************************************************************
472 Zonking makes sure that the instance types are fully zonked,
473 but doesn't do the same for any of the Ids in an Inst. There's no
474 need, and it's a lot of extra work.
477 zonkInst :: Inst -> NF_TcM Inst
478 zonkInst (Dict id pred loc)
479 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
480 returnNF_Tc (Dict id new_pred loc)
482 zonkInst (Method m id tys theta tau loc)
483 = zonkId id `thenNF_Tc` \ new_id ->
484 -- Essential to zonk the id in case it's a local variable
485 -- Can't use zonkIdOcc because the id might itself be
486 -- an InstId, in which case it won't be in scope
488 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
489 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
490 zonkTcType tau `thenNF_Tc` \ new_tau ->
491 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
493 zonkInst (LitInst id lit ty loc)
494 = zonkTcType ty `thenNF_Tc` \ new_ty ->
495 returnNF_Tc (LitInst id lit new_ty loc)
497 zonkInsts insts = mapNF_Tc zonkInst insts
501 %************************************************************************
503 \subsection{Printing}
505 %************************************************************************
507 ToDo: improve these pretty-printing things. The ``origin'' is really only
508 relevant in error messages.
511 instance Outputable Inst where
512 ppr inst = pprInst inst
514 pprInst (LitInst u lit ty loc)
515 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
517 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
519 pprInst m@(Method u id tys theta tau loc)
520 = hsep [ppr id, ptext SLIT("at"),
521 brackets (interppSP tys) {- ,
522 ptext SLIT("theta"), ppr theta,
523 ptext SLIT("tau"), ppr tau
527 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
529 tidyInst :: TidyEnv -> Inst -> Inst
530 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
531 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
532 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
534 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
535 -- This function doesn't assume that the tyvars are in scope
536 -- so it works like tidyOpenType, returning a TidyEnv
537 tidyMoreInsts env insts
538 = (env', map (tidyInst env') insts)
540 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
542 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
543 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
547 %************************************************************************
549 \subsection{Looking up Insts}
551 %************************************************************************
554 data LookupInstResult s
556 | SimpleInst TcExpr -- Just a variable, type application, or literal
557 | GenInst [Inst] TcExpr -- The expression and its needed insts
560 -> NF_TcM (LookupInstResult s)
564 lookupInst dict@(Dict _ (ClassP clas tys) loc)
565 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
566 case lookupInstEnv inst_env clas tys of
568 FoundInst tenv dfun_id
570 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
571 mk_ty_arg tv = case lookupSubstEnv tenv tv of
572 Just (DoneTy ty) -> returnNF_Tc ty
573 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
574 returnTc (mkTyVarTy tc_tv)
576 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
578 subst = mkTyVarSubst tyvars ty_args
579 dfun_rho = substTy subst rho
580 (theta, _) = tcSplitRhoTy dfun_rho
581 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
584 returnNF_Tc (SimpleInst ty_app)
586 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
588 rhs = mkHsDictApp ty_app (map instToId dicts)
590 returnNF_Tc (GenInst dicts rhs)
592 other -> returnNF_Tc NoInstance
594 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
598 lookupInst inst@(Method _ id tys theta _ loc)
599 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
600 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
604 -- Look for short cuts first: if the literal is *definitely* a
605 -- int, integer, float or a double, generate the real thing here.
606 -- This is essential (see nofib/spectral/nucleic).
607 -- [Same shortcut as in newOverloadedLit, but we
608 -- may have done some unification by now]
610 lookupInst inst@(LitInst u lit ty loc)
611 | Just expr <- shortCutLit lit ty
612 = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because
613 -- expr may be a constructor application
615 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
616 = tcLookupId from_integer_name `thenNF_Tc` \ from_integer ->
617 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
618 returnNF_Tc (GenInst [method_inst]
619 (HsApp (HsVar method_id) (HsLit (HsInteger i))))
622 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
623 = tcLookupId from_rat_name `thenNF_Tc` \ from_rational ->
624 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
626 rational_ty = tcFunArgTy (idType method_id)
627 rational_lit = HsLit (HsRat f rational_ty)
629 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_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 (_, rho) = tcSplitForAllTys (idType dfun)
649 (theta,_) = tcSplitRhoTy rho
651 other -> returnNF_Tc Nothing