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,
47 import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
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,
58 IPName, mapIPName, ipNameName
60 import CoreFVs ( idFreeTyVars )
61 import Class ( Class )
62 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
63 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
64 import Name ( Name, mkMethodOcc, getOccName )
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
223 -- NB: ?x and %x get different Names
225 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
227 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
228 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
229 ipNamesOfInst other = []
231 tyVarsOfInst :: Inst -> TcTyVarSet
232 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
233 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
234 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
235 -- The id might have free type variables; in the case of
236 -- locally-overloaded class methods, for example
238 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
239 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
245 isDict :: Inst -> Bool
246 isDict (Dict _ _ _) = True
249 isClassDict :: Inst -> Bool
250 isClassDict (Dict _ pred _) = isClassPred pred
251 isClassDict other = False
253 isTyVarDict :: Inst -> Bool
254 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
255 isTyVarDict other = False
257 isMethod :: Inst -> Bool
258 isMethod (Method _ _ _ _ _ _) = True
259 isMethod other = False
261 isMethodFor :: TcIdSet -> Inst -> Bool
262 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
263 isMethodFor ids inst = 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 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 vanilla implicit parameters, there is only one in scope
315 -- at any time, so we used to use the name of the implicit parameter itself
316 -- But with splittable implicit parameters there may be many in
317 -- scope, so we make up a new name.
318 newIPDict :: InstOrigin -> IPName Name -> Type
319 -> NF_TcM (IPName Id, Inst)
320 newIPDict orig ip_name ty
321 = tcGetInstLoc orig `thenNF_Tc` \ inst_loc@(_,loc,_) ->
322 tcGetUnique `thenNF_Tc` \ uniq ->
324 pred = IParam ip_name ty
325 id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
327 returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
331 %************************************************************************
333 \subsection{Building methods (calls of overloaded functions)}
335 %************************************************************************
337 tcInstId instantiates an occurrence of an Id.
338 The instantiate_it loop runs round instantiating the Id.
339 It has to be a loop because we are now prepared to entertain
341 f:: forall a. Eq a => forall b. Baz b => tau
342 We want to instantiate this to
343 f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
345 The -fno-method-sharing flag controls what happens so far as the LIE
346 is concerned. The default case is that for an overloaded function we
347 generate a "method" Id, and add the Method Inst to the LIE. So you get
350 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
351 If you specify -fno-method-sharing, the dictionary application
352 isn't shared, so we get
354 f = /\a (d:Num a) (x:a) -> (+) a d x x
355 This gets a bit less sharing, but
356 a) it's better for RULEs involving overloaded functions
357 b) perhaps fewer separated lambdas
361 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
363 | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
364 | otherwise = loop_share fun
366 orig = OccurrenceOf fun
367 loop_noshare fun fun_ty
368 = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
370 ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
372 if null theta then -- Is it overloaded?
373 returnNF_Tc (ty_app, emptyLIE, tau)
375 newDicts orig theta `thenNF_Tc` \ dicts ->
376 loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
377 returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
380 = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
382 arg_tys = mkTyVarTys tyvars
384 if null theta then -- Is it overloaded?
385 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
387 -- Yes, it's overloaded
388 newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
389 loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
390 returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
393 newMethod :: InstOrigin
397 newMethod orig id tys
398 = -- Get the Id type and instantiate it at the specified types
400 (tyvars, rho) = tcSplitForAllTys (idType id)
401 rho_ty = substTyWith tyvars tys rho
402 (pred, tau) = tcSplitMethodTy rho_ty
404 newMethodWithGivenTy orig id tys [pred] tau
406 newMethodWithGivenTy orig id tys theta tau
407 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
408 newMethodWith loc id tys theta tau
410 newMethodWith inst_loc@(_,loc,_) id tys theta tau
411 = tcGetUnique `thenNF_Tc` \ new_uniq ->
413 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
415 returnNF_Tc (Method meth_id id tys theta tau inst_loc)
417 newMethodAtLoc :: InstLoc
419 -> NF_TcM (Inst, TcId)
420 newMethodAtLoc inst_loc real_id tys
421 -- This actually builds the Inst
422 = -- Get the Id type and instantiate it at the specified types
424 (tyvars,rho) = tcSplitForAllTys (idType real_id)
425 rho_ty = ASSERT( equalLength tyvars tys )
426 substTy (mkTopTyVarSubst tyvars tys) rho
427 (theta, tau) = tcSplitRhoTy rho_ty
429 newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
430 returnNF_Tc (meth_inst, instToId meth_inst)
433 In newOverloadedLit we convert directly to an Int or Integer if we
434 know that's what we want. This may save some time, by not
435 temporarily generating overloaded literals, but it won't catch all
436 cases (the rest are caught in lookupInst).
439 newOverloadedLit :: InstOrigin
442 -> NF_TcM (TcExpr, LIE)
443 newOverloadedLit orig lit ty
444 | Just expr <- shortCutLit lit ty
445 = returnNF_Tc (expr, emptyLIE)
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)
456 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
457 shortCutLit (HsIntegral i fi) ty
458 | isIntTy ty && inIntRange i && fi == fromIntegerName -- Short cut for Int
459 = Just (HsLit (HsInt i))
460 | isIntegerTy ty && fi == fromIntegerName -- Short cut for Integer
461 = Just (HsLit (HsInteger i))
463 shortCutLit (HsFractional f fr) ty
464 | isFloatTy ty && fr == fromRationalName
465 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
466 | isDoubleTy ty && fr == fromRationalName
467 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
474 %************************************************************************
478 %************************************************************************
480 Zonking makes sure that the instance types are fully zonked,
481 but doesn't do the same for any of the Ids in an Inst. There's no
482 need, and it's a lot of extra work.
485 zonkInst :: Inst -> NF_TcM Inst
486 zonkInst (Dict id pred loc)
487 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
488 returnNF_Tc (Dict id new_pred loc)
490 zonkInst (Method m id tys theta tau loc)
491 = zonkId id `thenNF_Tc` \ new_id ->
492 -- Essential to zonk the id in case it's a local variable
493 -- Can't use zonkIdOcc because the id might itself be
494 -- an InstId, in which case it won't be in scope
496 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
497 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
498 zonkTcType tau `thenNF_Tc` \ new_tau ->
499 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
501 zonkInst (LitInst id lit ty loc)
502 = zonkTcType ty `thenNF_Tc` \ new_ty ->
503 returnNF_Tc (LitInst id lit new_ty loc)
505 zonkInsts insts = mapNF_Tc zonkInst insts
509 %************************************************************************
511 \subsection{Printing}
513 %************************************************************************
515 ToDo: improve these pretty-printing things. The ``origin'' is really only
516 relevant in error messages.
519 instance Outputable Inst where
520 ppr inst = pprInst inst
522 pprInst (LitInst u lit ty loc)
523 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
525 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
527 pprInst m@(Method u id tys theta tau loc)
528 = hsep [ppr id, ptext SLIT("at"),
529 brackets (interppSP tys) {- ,
530 ptext SLIT("theta"), ppr theta,
531 ptext SLIT("tau"), ppr tau
535 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
537 tidyInst :: TidyEnv -> Inst -> Inst
538 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
539 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
540 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
542 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
543 -- This function doesn't assume that the tyvars are in scope
544 -- so it works like tidyOpenType, returning a TidyEnv
545 tidyMoreInsts env insts
546 = (env', map (tidyInst env') insts)
548 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
550 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
551 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
555 %************************************************************************
557 \subsection{Looking up Insts}
559 %************************************************************************
562 data LookupInstResult s
564 | SimpleInst TcExpr -- Just a variable, type application, or literal
565 | GenInst [Inst] TcExpr -- The expression and its needed insts
568 -> NF_TcM (LookupInstResult s)
572 lookupInst dict@(Dict _ (ClassP clas tys) loc)
573 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
574 case lookupInstEnv inst_env clas tys of
576 FoundInst tenv dfun_id
578 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
579 mk_ty_arg tv = case lookupSubstEnv tenv tv of
580 Just (DoneTy ty) -> returnNF_Tc ty
581 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
582 returnTc (mkTyVarTy tc_tv)
584 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
586 subst = mkTyVarSubst tyvars ty_args
587 dfun_rho = substTy subst rho
588 (theta, _) = tcSplitRhoTy dfun_rho
589 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
592 returnNF_Tc (SimpleInst ty_app)
594 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
596 rhs = mkHsDictApp ty_app (map instToId dicts)
598 returnNF_Tc (GenInst dicts rhs)
600 other -> returnNF_Tc NoInstance
602 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
606 lookupInst inst@(Method _ id tys theta _ loc)
607 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
608 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
612 -- Look for short cuts first: if the literal is *definitely* a
613 -- int, integer, float or a double, generate the real thing here.
614 -- This is essential (see nofib/spectral/nucleic).
615 -- [Same shortcut as in newOverloadedLit, but we
616 -- may have done some unification by now]
618 lookupInst inst@(LitInst u lit ty loc)
619 | Just expr <- shortCutLit lit ty
620 = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because
621 -- expr may be a constructor application
623 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
624 = tcLookupId from_integer_name `thenNF_Tc` \ from_integer ->
625 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
626 returnNF_Tc (GenInst [method_inst]
627 (HsApp (HsVar method_id) (HsLit (HsInteger i))))
630 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
631 = tcLookupId from_rat_name `thenNF_Tc` \ from_rational ->
632 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
634 rational_ty = tcFunArgTy (idType method_id)
635 rational_lit = HsLit (HsRat f rational_ty)
637 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
640 There is a second, simpler interface, when you want an instance of a
641 class at a given nullary type constructor. It just returns the
642 appropriate dictionary if it exists. It is used only when resolving
643 ambiguous dictionaries.
646 lookupSimpleInst :: Class
647 -> [Type] -- Look up (c,t)
648 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
650 lookupSimpleInst clas tys
651 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
652 case lookupInstEnv inst_env clas tys of
654 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
656 (_, rho) = tcSplitForAllTys (idType dfun)
657 (theta,_) = tcSplitRhoTy rho
659 other -> returnNF_Tc Nothing