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
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 PprType ( pprPred )
65 import Subst ( emptyInScopeSet, mkSubst,
66 substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
68 import Literal ( inIntRange )
69 import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
70 import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
71 import TysWiredIn ( floatDataCon, doubleDataCon )
72 import PrelNames( fromIntegerName, fromRationalName )
73 import Util ( thenCmp, equalLength )
78 %************************************************************************
80 \subsection[Inst-collections]{LIE: a collection of Insts}
82 %************************************************************************
87 isEmptyLIE = isEmptyBag
89 unitLIE inst = unitBag inst
90 mkLIE insts = listToBag insts
91 plusLIE lie1 lie2 = lie1 `unionBags` lie2
92 consLIE inst lie = inst `consBag` lie
93 plusLIEs lies = unionManyBags lies
97 zonkLIE :: LIE -> NF_TcM LIE
98 zonkLIE lie = mapBagNF_Tc zonkInst lie
100 pprInsts :: [Inst] -> SDoc
101 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
105 = vcat (map go insts)
107 go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
110 %************************************************************************
112 \subsection[Inst-types]{@Inst@ types}
114 %************************************************************************
116 An @Inst@ is either a dictionary, an instance of an overloaded
117 literal, or an instance of an overloaded value. We call the latter a
118 ``method'' even though it may not correspond to a class operation.
119 For example, we might have an instance of the @double@ function at
120 type Int, represented by
122 Method 34 doubleId [Int] origin
134 TcId -- The overloaded function
135 -- This function will be a global, local, or ClassOpId;
136 -- inside instance decls (only) it can also be an InstId!
137 -- The id needn't be completely polymorphic.
138 -- You'll probably find its name (for documentation purposes)
139 -- inside the InstOrigin
141 [TcType] -- The types to which its polymorphic tyvars
142 -- should be instantiated.
143 -- These types must saturate the Id's foralls.
145 TcThetaType -- The (types of the) dictionaries to which the function
146 -- must be applied to get the method
148 TcTauType -- The type of the method
152 -- INVARIANT: in (Method u f tys theta tau loc)
153 -- type of (f tys dicts(from theta)) = tau
157 HsOverLit -- The literal from the occurrence site
158 TcType -- The type at which the literal is used
164 @Insts@ are ordered by their class/type info, rather than by their
165 unique. This allows the context-reduction mechanism to use standard finite
166 maps to do their stuff.
169 instance Ord Inst where
172 instance Eq Inst where
173 (==) i1 i2 = case i1 `cmpInst` i2 of
177 cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
178 cmpInst (Dict _ _ _) other = LT
180 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
181 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
182 cmpInst (Method _ _ _ _ _ _) other = LT
184 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
185 cmpInst (LitInst _ _ _ _) other = GT
187 -- and they can only have HsInt or HsFracs in them.
194 instName :: Inst -> Name
195 instName inst = idName (instToId inst)
197 instToId :: Inst -> TcId
198 instToId (Dict id _ _) = id
199 instToId (Method id _ _ _ _ _) = id
200 instToId (LitInst id _ _ _) = id
202 instLoc (Dict _ _ loc) = loc
203 instLoc (Method _ _ _ _ _ loc) = loc
204 instLoc (LitInst _ _ _ loc) = loc
206 getDictClassTys (Dict _ pred _) = getClassPredTys pred
208 predsOfInsts :: [Inst] -> [PredType]
209 predsOfInsts insts = concatMap predsOfInst insts
211 predsOfInst (Dict _ pred _) = [pred]
212 predsOfInst (Method _ _ _ theta _ _) = theta
213 predsOfInst (LitInst _ _ _ _) = []
214 -- The last case is is really a big cheat
215 -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
216 -- But Num and Fractional have only one parameter and no functional
217 -- dependencies, so I think no caller of predsOfInst will care.
219 ipNamesOfInsts :: [Inst] -> [Name]
220 ipNamesOfInst :: Inst -> [Name]
221 -- Get the implicit parameters mentioned by these Insts
223 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
225 ipNamesOfInst (Dict _ (IParam n _) _) = [n]
226 ipNamesOfInst (Method _ _ _ theta _ _) = [n | IParam n _ <- theta]
227 ipNamesOfInst other = []
229 tyVarsOfInst :: Inst -> TcTyVarSet
230 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
231 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
232 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
233 -- The id might have free type variables; in the case of
234 -- locally-overloaded class methods, for example
236 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
237 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
243 isDict :: Inst -> Bool
244 isDict (Dict _ _ _) = True
247 isClassDict :: Inst -> Bool
248 isClassDict (Dict _ pred _) = isClassPred pred
249 isClassDict other = False
251 isTyVarDict :: Inst -> Bool
252 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
253 isTyVarDict other = False
255 isMethod :: Inst -> Bool
256 isMethod (Method _ _ _ _ _ _) = True
257 isMethod other = False
259 isMethodFor :: TcIdSet -> Inst -> Bool
260 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
261 isMethodFor ids inst = False
263 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
264 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
268 Two predicates which deal with the case where class constraints don't
269 necessarily result in bindings. The first tells whether an @Inst@
270 must be witnessed by an actual binding; the second tells whether an
271 @Inst@ can be generalised over.
274 instBindingRequired :: Inst -> Bool
275 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
276 instBindingRequired (Dict _ (IParam _ _) _) = False
277 instBindingRequired other = True
279 instCanBeGeneralised :: Inst -> Bool
280 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
281 instCanBeGeneralised other = True
285 %************************************************************************
287 \subsection{Building dictionaries}
289 %************************************************************************
292 newDicts :: InstOrigin
296 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
297 newDictsAtLoc loc theta
299 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
300 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
302 -- Local function, similar to newDicts,
303 -- but with slightly different interface
304 newDictsAtLoc :: InstLoc
307 newDictsAtLoc inst_loc@(_,loc,_) theta
308 = tcGetUniques `thenNF_Tc` \ new_uniqs ->
309 returnNF_Tc (zipWith mk_dict new_uniqs theta)
311 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
313 -- For implicit parameters, since there is only one in scope
314 -- at any time, we use the name of the implicit parameter itself
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) = tcSplitForAllTys (idType id)
392 rho_ty = substTyWith tyvars tys rho
393 (pred, tau) = tcSplitMethodTy 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) = tcSplitForAllTys (idType real_id)
416 rho_ty = ASSERT( equalLength tyvars tys )
417 substTy (mkTopTyVarSubst tyvars tys) rho
418 (theta, tau) = tcSplitRhoTy 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 lit ty
435 | Just expr <- shortCutLit lit ty
436 = returnNF_Tc (expr, emptyLIE)
439 = tcGetInstLoc orig `thenNF_Tc` \ loc ->
440 tcGetUnique `thenNF_Tc` \ new_uniq ->
442 lit_inst = LitInst lit_id lit ty loc
443 lit_id = mkSysLocal SLIT("lit") new_uniq ty
445 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
447 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
448 shortCutLit (HsIntegral i fi) ty
449 | isIntTy ty && inIntRange i && fi == fromIntegerName -- Short cut for Int
450 = Just (HsLit (HsInt i))
451 | isIntegerTy ty && fi == fromIntegerName -- Short cut for Integer
452 = Just (HsLit (HsInteger i))
454 shortCutLit (HsFractional f fr) ty
455 | isFloatTy ty && fr == fromRationalName
456 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
457 | isDoubleTy ty && fr == fromRationalName
458 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
465 %************************************************************************
469 %************************************************************************
471 Zonking makes sure that the instance types are fully zonked,
472 but doesn't do the same for any of the Ids in an Inst. There's no
473 need, and it's a lot of extra work.
476 zonkInst :: Inst -> NF_TcM Inst
477 zonkInst (Dict id pred loc)
478 = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
479 returnNF_Tc (Dict id new_pred loc)
481 zonkInst (Method m id tys theta tau loc)
482 = zonkId id `thenNF_Tc` \ new_id ->
483 -- Essential to zonk the id in case it's a local variable
484 -- Can't use zonkIdOcc because the id might itself be
485 -- an InstId, in which case it won't be in scope
487 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
488 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
489 zonkTcType tau `thenNF_Tc` \ new_tau ->
490 returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
492 zonkInst (LitInst id lit ty loc)
493 = zonkTcType ty `thenNF_Tc` \ new_ty ->
494 returnNF_Tc (LitInst id lit new_ty loc)
496 zonkInsts insts = mapNF_Tc zonkInst insts
500 %************************************************************************
502 \subsection{Printing}
504 %************************************************************************
506 ToDo: improve these pretty-printing things. The ``origin'' is really only
507 relevant in error messages.
510 instance Outputable Inst where
511 ppr inst = pprInst inst
513 pprInst (LitInst u lit ty loc)
514 = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
516 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
518 pprInst m@(Method u id tys theta tau loc)
519 = hsep [ppr id, ptext SLIT("at"),
520 brackets (interppSP tys) {- ,
521 ptext SLIT("theta"), ppr theta,
522 ptext SLIT("tau"), ppr tau
526 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
528 tidyInst :: TidyEnv -> Inst -> Inst
529 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
530 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
531 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
533 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
534 -- This function doesn't assume that the tyvars are in scope
535 -- so it works like tidyOpenType, returning a TidyEnv
536 tidyMoreInsts env insts
537 = (env', map (tidyInst env') insts)
539 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
541 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
542 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
546 %************************************************************************
548 \subsection{Looking up Insts}
550 %************************************************************************
553 data LookupInstResult s
555 | SimpleInst TcExpr -- Just a variable, type application, or literal
556 | GenInst [Inst] TcExpr -- The expression and its needed insts
559 -> NF_TcM (LookupInstResult s)
563 lookupInst dict@(Dict _ (ClassP clas tys) loc)
564 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
565 case lookupInstEnv inst_env clas tys of
567 FoundInst tenv dfun_id
569 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
570 mk_ty_arg tv = case lookupSubstEnv tenv tv of
571 Just (DoneTy ty) -> returnNF_Tc ty
572 Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
573 returnTc (mkTyVarTy tc_tv)
575 mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
577 subst = mkTyVarSubst tyvars ty_args
578 dfun_rho = substTy subst rho
579 (theta, _) = tcSplitRhoTy dfun_rho
580 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
583 returnNF_Tc (SimpleInst ty_app)
585 newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
587 rhs = mkHsDictApp ty_app (map instToId dicts)
589 returnNF_Tc (GenInst dicts rhs)
591 other -> returnNF_Tc NoInstance
593 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
597 lookupInst inst@(Method _ id tys theta _ loc)
598 = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
599 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
603 -- Look for short cuts first: if the literal is *definitely* a
604 -- int, integer, float or a double, generate the real thing here.
605 -- This is essential (see nofib/spectral/nucleic).
606 -- [Same shortcut as in newOverloadedLit, but we
607 -- may have done some unification by now]
609 lookupInst inst@(LitInst u lit ty loc)
610 | Just expr <- shortCutLit lit ty
611 = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because
612 -- expr may be a constructor application
614 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
615 = tcLookupId from_integer_name `thenNF_Tc` \ from_integer ->
616 newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
617 returnNF_Tc (GenInst [method_inst]
618 (HsApp (HsVar method_id) (HsLit (HsInteger i))))
621 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
622 = tcLookupId from_rat_name `thenNF_Tc` \ from_rational ->
623 newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
625 rational_ty = tcFunArgTy (idType method_id)
626 rational_lit = HsLit (HsRat f rational_ty)
628 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
631 There is a second, simpler interface, when you want an instance of a
632 class at a given nullary type constructor. It just returns the
633 appropriate dictionary if it exists. It is used only when resolving
634 ambiguous dictionaries.
637 lookupSimpleInst :: Class
638 -> [Type] -- Look up (c,t)
639 -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
641 lookupSimpleInst clas tys
642 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
643 case lookupInstEnv inst_env clas tys of
645 -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
647 (_, rho) = tcSplitForAllTys (idType dfun)
648 (theta,_) = tcSplitRhoTy rho
650 other -> returnNF_Tc Nothing