2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
7 #include "HsVersions.h"
10 Inst(..), -- Visible only to TcSimplify
12 InstOrigin(..), OverloadedLit(..),
13 LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
17 newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
19 instType, tyVarsOfInst, lookupInst,
26 instBindingRequired, instCanBeGeneralised
32 import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
33 InPat, OutPat, Stmt, Qual, Match,
34 ArithSeqInfo, PolyType, Fake )
35 import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
36 import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
37 mkHsTyApp, mkHsDictApp )
40 import TcEnv ( tcLookupGlobalValueByKey )
41 import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
42 tcInstType, tcInstTcType, zonkTcType )
44 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
45 import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
46 import Id ( GenId, idType, mkInstId )
47 import MatchEnv ( lookupMEnv, insertMEnv )
48 import Name ( mkLocalName, getLocalName, Name )
50 import PprType ( GenClass, TyCon, GenType, GenTyVar )
51 import PprStyle ( PprStyle(..) )
53 import RnHsSyn ( RnName{-instance NamedThing-} )
54 import SpecEnv ( SpecEnv(..) )
55 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
56 import Type ( GenType, eqSimpleTy,
57 isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
58 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes )
59 import TyVar ( GenTyVar )
60 import TysPrim ( intPrimTy )
61 import TysWiredIn ( intDataCon )
62 import Unique ( Unique, showUnique,
63 fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey )
64 import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic )
68 %************************************************************************
70 \subsection[Inst-collections]{LIE: a collection of Insts}
72 %************************************************************************
75 type LIE s = Bag (Inst s)
78 unitLIE inst = unitBag inst
79 plusLIE lie1 lie2 = lie1 `unionBags` lie2
80 consLIE inst lie = inst `consBag` lie
81 plusLIEs lies = unionManyBags lies
83 zonkLIE :: LIE s -> NF_TcM s (LIE s)
84 zonkLIE lie = mapBagNF_Tc zonkInst lie
87 %************************************************************************
89 \subsection[Inst-types]{@Inst@ types}
91 %************************************************************************
93 An @Inst@ is either a dictionary, an instance of an overloaded
94 literal, or an instance of an overloaded value. We call the latter a
95 ``method'' even though it may not correspond to a class operation.
96 For example, we might have an instance of the @double@ function at
97 type Int, represented by
99 Method 34 doubleId [Int] origin
105 Class -- The type of the dict is (c t), where
106 (TcType s) -- c is the class and t the type;
113 (TcIdOcc s) -- The overloaded function
114 -- This function will be a global, local, or ClassOpId;
115 -- inside instance decls (only) it can also be an InstId!
116 -- The id needn't be completely polymorphic.
117 -- You'll probably find its name (for documentation purposes)
118 -- inside the InstOrigin
120 [TcType s] -- The types to which its polymorphic tyvars
121 -- should be instantiated.
122 -- These types must saturate the Id's foralls.
124 (TcRhoType s) -- Cached: (type-of-id applied to inst_tys)
125 -- If this type is (theta => tau) then the type of the Method
126 -- is tau, and the method can be built by saying
128 -- where dicts are constructed from theta
136 (TcType s) -- The type at which the literal is used
137 (InstOrigin s) -- Always a literal; but more convenient to carry this around
141 = OverloadedIntegral Integer -- The number
142 | OverloadedFractional Rational -- The number
144 getInstOrigin (Dict u clas ty origin loc) = origin
145 getInstOrigin (Method u clas ty rho origin loc) = origin
146 getInstOrigin (LitInst u lit ty origin loc) = origin
153 newDicts :: InstOrigin s
154 -> [(Class, TcType s)]
155 -> NF_TcM s (LIE s, [TcIdOcc s])
157 = tcGetSrcLoc `thenNF_Tc` \ loc ->
158 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
160 mk_dict u (clas, ty) = Dict u clas ty orig loc
161 dicts = zipWithEqual mk_dict new_uniqs theta
163 returnNF_Tc (listToBag dicts, map instToId dicts)
165 newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
166 -- but with slightly different interface
167 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
169 mk_dict u (clas, ty) = Dict u clas ty orig loc
170 dicts = zipWithEqual mk_dict new_uniqs theta
172 returnNF_Tc (dicts, map instToId dicts)
174 newMethod :: InstOrigin s
177 -> NF_TcM s (LIE s, TcIdOcc s)
178 newMethod orig id tys
179 = -- Get the Id type and instantiate it at the specified types
181 RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
182 in tcInstType (tyvars `zipEqual` tys) rho
183 TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
184 in tcInstTcType (tyvars `zipEqual` tys) rho
185 ) `thenNF_Tc` \ rho_ty ->
187 -- Our friend does the rest
188 newMethodWithGivenTy orig id tys rho_ty
191 newMethodWithGivenTy orig id tys rho_ty
192 = tcGetSrcLoc `thenNF_Tc` \ loc ->
193 tcGetUnique `thenNF_Tc` \ new_uniq ->
195 meth_inst = Method new_uniq id tys rho_ty orig loc
197 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
199 newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
200 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
201 -- slightly different interface
202 = -- Get the Id type and instantiate it at the specified types
204 (tyvars,rho) = splitForAllTy (idType real_id)
206 tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty ->
207 tcGetUnique `thenNF_Tc` \ new_uniq ->
209 meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
211 returnNF_Tc (meth_inst, instToId meth_inst)
213 newOverloadedLit :: InstOrigin s
216 -> NF_TcM s (LIE s, TcIdOcc s)
217 newOverloadedLit orig lit ty
218 = tcGetSrcLoc `thenNF_Tc` \ loc ->
219 tcGetUnique `thenNF_Tc` \ new_uniq ->
221 lit_inst = LitInst new_uniq lit ty orig loc
223 returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
228 instToId :: Inst s -> TcIdOcc s
229 instToId (Dict u clas ty orig loc)
230 = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u SLIT("dict") loc))
231 instToId (Method u id tys rho_ty orig loc)
232 = TcId (mkInstId u tau_ty (mkLocalName u (getLocalName id) loc))
234 (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
235 instToId (LitInst u list ty orig loc)
236 = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc))
240 instType :: Inst s -> TcType s
241 instType (Dict _ clas ty _ _) = mkDictTy clas ty
242 instType (LitInst _ _ ty _ _) = ty
243 instType (Method _ id tys ty _ _) = ty
249 Zonking makes sure that the instance types are fully zonked,
250 but doesn't do the same for the Id in a Method. There's no
251 need, and it's a lot of extra work.
254 zonkInst :: Inst s -> NF_TcM s (Inst s)
255 zonkInst (Dict u clas ty orig loc)
256 = zonkTcType ty `thenNF_Tc` \ new_ty ->
257 returnNF_Tc (Dict u clas new_ty orig loc)
259 zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id!
260 = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
261 zonkTcType rho `thenNF_Tc` \ new_rho ->
262 returnNF_Tc (Method u id new_tys new_rho orig loc)
264 zonkInst (LitInst u lit ty orig loc)
265 = zonkTcType ty `thenNF_Tc` \ new_ty ->
266 returnNF_Tc (LitInst u lit new_ty orig loc)
271 tyVarsOfInst :: Inst s -> TcTyVarSet s
272 tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
273 tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
274 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
277 @matchesInst@ checks when two @Inst@s are instances of the same
278 thing at the same type, even if their uniques differ.
281 matchesInst :: Inst s -> Inst s -> Bool
283 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
284 = clas1 == clas2 && ty1 `eqSimpleTy` ty2
286 matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
288 && and (zipWith eqSimpleTy tys1 tys2)
289 && length tys1 == length tys2
291 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
292 = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
294 (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2
295 (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
298 matchesInst other1 other2 = False
305 isDict :: Inst s -> Bool
306 isDict (Dict _ _ _ _ _) = True
309 isTyVarDict :: Inst s -> Bool
310 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
311 isTyVarDict other = False
314 Two predicates which deal with the case where class constraints don't
315 necessarily result in bindings. The first tells whether an @Inst@
316 must be witnessed by an actual binding; the second tells whether an
317 @Inst@ can be generalised over.
320 instBindingRequired :: Inst s -> Bool
321 instBindingRequired inst
322 = case getInstOrigin inst of
323 CCallOrigin _ _ -> False -- No binding required
324 LitLitOrigin _ -> False
325 OccurrenceOfCon _ -> False
328 instCanBeGeneralised :: Inst s -> Bool
329 instCanBeGeneralised inst
330 = case getInstOrigin inst of
331 CCallOrigin _ _ -> False -- Can't be generalised
332 LitLitOrigin _ -> False -- Can't be generalised
339 ToDo: improve these pretty-printing things. The ``origin'' is really only
340 relevant in error messages.
343 instance Outputable (Inst s) where
344 ppr sty (LitInst uniq lit ty orig loc)
345 = ppHang (ppSep [case lit of
346 OverloadedIntegral i -> ppInteger i
347 OverloadedFractional f -> ppRational f,
352 4 (show_origin sty orig)
354 ppr sty (Dict uniq clas ty orig loc)
355 = ppHang (ppSep [ppr sty clas,
360 4 (show_origin sty orig)
362 ppr sty (Method uniq id tys rho orig loc)
363 = ppHang (ppSep [ppr sty id,
368 4 (show_origin sty orig)
370 show_uniq PprDebug uniq = ppr PprDebug uniq
371 show_uniq sty uniq = ppNil
373 show_origin sty orig = ppBesides [ppLparen, pprOrigin sty orig, ppRparen]
376 Printing in error messages
379 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
382 %************************************************************************
384 \subsection[InstEnv-types]{Type declarations}
386 %************************************************************************
389 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
392 A @ClassInstEnv@ lives inside a class, and identifies all the instances
393 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
396 There is an important consistency constraint between the @MatchEnv@s
397 in and the dfun @Id@s inside them: the free type variables of the
398 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
399 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
400 contain the following entry:
402 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
404 The "a" in the pattern must be one of the forall'd variables in
410 (TcIdOcc s, TcExpr s)) -- The new binding
414 lookupInst dict@(Dict _ clas ty orig loc)
415 = case lookupMEnv matchTy (get_inst_env clas orig) ty of
416 Nothing -> failTc (noInstanceErr dict)
420 (tyvars, rho) = splitForAllTy (idType dfun_id)
421 ty_args = map (assoc "lookupInst" tenv) tyvars
422 -- tenv should bind all the tyvars
424 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
426 (theta, tau) = splitRhoTy dfun_rho
428 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
430 rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
432 returnTc (dicts, (instToId dict, rhs))
437 lookupInst inst@(Method _ id tys rho orig loc)
438 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
439 returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
441 (theta,_) = splitRhoTy rho
445 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
446 | i >= toInteger minInt && i <= toInteger maxInt
447 = -- It's overloaded but small enough to fit into an Int
448 tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
449 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
450 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
453 = -- Alas, it is overloaded and a big literal!
454 tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
455 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
456 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty)))
458 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
459 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
461 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
462 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
463 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
464 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty)))
467 There is a second, simpler interface, when you want an instance of a
468 class at a given nullary type constructor. It just returns the
469 appropriate dictionary if it exists. It is used only when resolving
470 ambiguous dictionaries.
473 lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id
475 lookupClassInstAtSimpleType clas ty
476 = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
478 Just (dfun,_) -> ASSERT( null tyvars && null theta )
481 (tyvars, theta, _) = splitSigmaTy (idType dfun)
485 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
486 It does it by filtering the class's @InstEnv@. All pretty shady stuff.
489 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
493 mkInstSpecEnv :: Class -- class
494 -> Type -- instance type
495 -> [TyVarTemplate] -- instance tyvars
496 -> ThetaType -- superclasses dicts
497 -> SpecEnv -- specenv for dfun of instance
499 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
500 = mkSpecEnv (catMaybes (map maybe_spec_info matches))
502 matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
504 maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
505 = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
506 maybe_spec_info (_, match_info, _)
513 :: ClassInstEnv -- Incoming envt
514 -> Type -- The instance type: inst_ty
515 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
516 -- be the same as the forall'd tyvars of the dfun id.
518 ClassInstEnv -- Success
519 (Type, Id) -- Offending overlap
521 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
526 %************************************************************************
528 \subsection[Inst-origin]{The @InstOrigin@ type}
530 %************************************************************************
532 The @InstOrigin@ type gives information about where a dictionary came from.
533 This is important for decent error message reporting because dictionaries
534 don't appear in the original source code. Doubtless this type will evolve...
538 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
539 | OccurrenceOfCon Id -- Occurrence of a data constructor
543 | DataDeclOrigin -- Typechecking a data declaration
545 | InstanceDeclOrigin -- Typechecking an instance decl
547 | LiteralOrigin HsLit -- Occurrence of a literal
549 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
551 | SignatureOrigin -- A dict created from a type signature
553 | DoOrigin -- The monad for a do expression
555 | ClassDeclOrigin -- Manufactured during a class decl
557 | DerivingOrigin InstanceMapper
561 -- During "deriving" operations we have an ever changing
562 -- mapping of classes to instances, so we record it inside the
563 -- origin information. This is a bit of a hack, but it works
564 -- fine. (Simon is to blame [WDP].)
566 | InstanceSpecOrigin InstanceMapper
567 Class -- in a SPECIALIZE instance pragma
570 -- When specialising instances the instance info attached to
571 -- each class is not yet ready, so we record it inside the
572 -- origin information. This is a bit of a hack, but it works
573 -- fine. (Patrick is to blame [WDP].)
575 | DefaultDeclOrigin -- Related to a `default' declaration
577 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
579 -- Argument or result of a ccall
580 -- Dictionaries with this origin aren't actually mentioned in the
581 -- translated term, and so need not be bound. Nor should they
582 -- be abstracted over.
584 | CCallOrigin String -- CCall label
585 (Maybe RenamedHsExpr) -- Nothing if it's the result
586 -- Just arg, for an argument
588 | LitLitOrigin String -- the litlit
590 | UnknownOrigin -- Help! I give up...
594 -- During deriving and instance specialisation operations
595 -- we can't get the instances of the class from inside the
596 -- class, because the latter ain't ready yet. Instead we
597 -- find a mapping from classes to envts inside the dict origin.
599 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
600 get_inst_env clas (DerivingOrigin inst_mapper _ _)
601 = fst (inst_mapper clas)
602 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
603 = fst (inst_mapper clas)
604 get_inst_env clas other_orig = getClassInstEnv clas
607 pprOrigin :: PprStyle -> InstOrigin s -> Pretty
609 pprOrigin sty (OccurrenceOf id)
610 = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
611 ppr sty id, ppChar '\'']
612 pprOrigin sty (OccurrenceOfCon id)
613 = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
614 ppr sty id, ppChar '\'']
615 pprOrigin sty (InstanceDeclOrigin)
616 = ppStr "in an instance declaration"
617 pprOrigin sty (LiteralOrigin lit)
618 = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
619 pprOrigin sty (ArithSeqOrigin seq)
620 = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
621 pprOrigin sty (SignatureOrigin)
622 = ppStr "in a type signature"
623 pprOrigin sty (DoOrigin)
624 = ppStr "in a do statement"
625 pprOrigin sty (ClassDeclOrigin)
626 = ppStr "in a class declaration"
627 pprOrigin sty (DerivingOrigin _ clas tycon)
628 = ppBesides [ppStr "in a `deriving' clause; class `",
630 ppStr "'; offending type `",
633 pprOrigin sty (InstanceSpecOrigin _ clas ty)
634 = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
635 ppr sty clas, ppStr "\" type: ", ppr sty ty]
636 pprOrigin sty (DefaultDeclOrigin)
637 = ppStr "in a `default' declaration"
638 pprOrigin sty (ValSpecOrigin name)
639 = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
640 ppr sty name, ppStr "'"]
641 pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-})
642 = ppBesides [ppStr "in the result of the _ccall_ to `",
643 ppStr clabel, ppStr "'"]
644 pprOrigin sty (CCallOrigin clabel (Just arg_expr))
645 = ppBesides [ppStr "in an argument in the _ccall_ to `",
646 ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
647 pprOrigin sty (LitLitOrigin s)
648 = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
649 pprOrigin sty UnknownOrigin
650 = ppStr "in... oops -- I don't know where the overloading came from!"