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 SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
15 SYN_IE(InstanceMapper),
17 newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
19 instType, tyVarsOfInst, lookupInst, lookupSimpleInst,
26 instBindingRequired, instCanBeGeneralised,
32 IMPORT_1_3(Ratio(Rational))
34 import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
35 InPat, OutPat, Stmt, Qualifier, Match,
36 ArithSeqInfo, PolyType, Fake )
37 import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr),
38 RnName{-instance NamedThing-}
40 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
41 mkHsTyApp, mkHsDictApp, tcIdTyVars )
43 import TcMonad hiding ( rnMtoTcM )
44 import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
45 import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
46 tcInstType, zonkTcType )
48 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
49 import Class ( isCcallishClass, isNoDictClass, classInstEnv,
50 SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
52 import ErrUtils ( addErrLoc, SYN_IE(Error) )
53 import Id ( GenId, idType, mkInstId )
54 import MatchEnv ( lookupMEnv, insertMEnv )
55 import Name ( mkLocalName, getLocalName, Name )
57 import PprType ( GenClass, TyCon, GenType, GenTyVar )
58 import PprStyle ( PprStyle(..) )
60 import SpecEnv ( SYN_IE(SpecEnv) )
61 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
62 import Type ( GenType, eqSimpleTy, instantiateTy,
63 isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
64 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
67 import TyVar ( unionTyVarSets, GenTyVar )
68 import TysPrim ( intPrimTy )
69 import TysWiredIn ( intDataCon, integerTy )
70 import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey,
71 fromIntClassOpKey, fromIntegerClassOpKey, Unique
73 import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
76 %************************************************************************
78 \subsection[Inst-collections]{LIE: a collection of Insts}
80 %************************************************************************
83 type LIE s = Bag (Inst s)
86 unitLIE inst = unitBag inst
87 plusLIE lie1 lie2 = lie1 `unionBags` lie2
88 consLIE inst lie = inst `consBag` lie
89 plusLIEs lies = unionManyBags lies
91 zonkLIE :: LIE s -> NF_TcM s (LIE s)
92 zonkLIE lie = mapBagNF_Tc zonkInst lie
95 %************************************************************************
97 \subsection[Inst-types]{@Inst@ types}
99 %************************************************************************
101 An @Inst@ is either a dictionary, an instance of an overloaded
102 literal, or an instance of an overloaded value. We call the latter a
103 ``method'' even though it may not correspond to a class operation.
104 For example, we might have an instance of the @double@ function at
105 type Int, represented by
107 Method 34 doubleId [Int] origin
113 Class -- The type of the dict is (c t), where
114 (TcType s) -- c is the class and t the type;
121 (TcIdOcc s) -- The overloaded function
122 -- This function will be a global, local, or ClassOpId;
123 -- inside instance decls (only) it can also be an InstId!
124 -- The id needn't be completely polymorphic.
125 -- You'll probably find its name (for documentation purposes)
126 -- inside the InstOrigin
128 [TcType s] -- The types to which its polymorphic tyvars
129 -- should be instantiated.
130 -- These types must saturate the Id's foralls.
132 (TcRhoType s) -- Cached: (type-of-id applied to inst_tys)
133 -- If this type is (theta => tau) then the type of the Method
134 -- is tau, and the method can be built by saying
136 -- where dicts are constructed from theta
144 (TcType s) -- The type at which the literal is used
145 (InstOrigin s) -- Always a literal; but more convenient to carry this around
149 = OverloadedIntegral Integer -- The number
150 | OverloadedFractional Rational -- The number
152 getInstOrigin (Dict u clas ty origin loc) = origin
153 getInstOrigin (Method u clas ty rho origin loc) = origin
154 getInstOrigin (LitInst u lit ty origin loc) = origin
161 newDicts :: InstOrigin s
162 -> [(Class, TcType s)]
163 -> NF_TcM s (LIE s, [TcIdOcc s])
165 = tcGetSrcLoc `thenNF_Tc` \ loc ->
166 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
168 mk_dict u (clas, ty) = Dict u clas ty orig loc
169 dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
171 returnNF_Tc (listToBag dicts, map instToId dicts)
173 newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
174 -- but with slightly different interface
175 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
177 mk_dict u (clas, ty) = Dict u clas ty orig loc
178 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
180 returnNF_Tc (dicts, map instToId dicts)
182 newMethod :: InstOrigin s
185 -> NF_TcM s (LIE s, TcIdOcc s)
186 newMethod orig id tys
187 = -- Get the Id type and instantiate it at the specified types
189 RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
191 (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
192 tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
193 TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
194 in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
195 ) `thenNF_Tc` \ rho_ty ->
196 -- Our friend does the rest
197 newMethodWithGivenTy orig id tys rho_ty
200 newMethodWithGivenTy orig id tys rho_ty
201 = tcGetSrcLoc `thenNF_Tc` \ loc ->
202 tcGetUnique `thenNF_Tc` \ new_uniq ->
204 meth_inst = Method new_uniq id tys rho_ty orig loc
206 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
208 newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
209 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
210 -- slightly different interface
211 = -- Get the Id type and instantiate it at the specified types
213 (tyvars,rho) = splitForAllTy (idType real_id)
215 tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty ->
216 tcGetUnique `thenNF_Tc` \ new_uniq ->
218 meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
220 returnNF_Tc (meth_inst, instToId meth_inst)
222 newOverloadedLit :: InstOrigin s
225 -> NF_TcM s (LIE s, TcIdOcc s)
226 newOverloadedLit orig lit ty
227 = tcGetSrcLoc `thenNF_Tc` \ loc ->
228 tcGetUnique `thenNF_Tc` \ new_uniq ->
230 lit_inst = LitInst new_uniq lit ty orig loc
232 returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
237 instToId :: Inst s -> TcIdOcc s
238 instToId (Dict u clas ty orig loc)
239 = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str False{-emph name-} loc))
241 str = SLIT("d.") _APPEND_ (getLocalName clas)
242 instToId (Method u id tys rho_ty orig loc)
243 = TcId (mkInstId u tau_ty (mkLocalName u str False{-emph name-} loc))
245 (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
246 str = SLIT("m.") _APPEND_ (getLocalName id)
248 instToId (LitInst u list ty orig loc)
249 = TcId (mkInstId u ty (mkLocalName u SLIT("lit") True{-emph uniq-} loc))
253 instType :: Inst s -> TcType s
254 instType (Dict _ clas ty _ _) = mkDictTy clas ty
255 instType (LitInst _ _ ty _ _) = ty
256 instType (Method _ id tys ty _ _) = ty
262 Zonking makes sure that the instance types are fully zonked,
263 but doesn't do the same for the Id in a Method. There's no
264 need, and it's a lot of extra work.
267 zonkInst :: Inst s -> NF_TcM s (Inst s)
268 zonkInst (Dict u clas ty orig loc)
269 = zonkTcType ty `thenNF_Tc` \ new_ty ->
270 returnNF_Tc (Dict u clas new_ty orig loc)
272 zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id!
273 = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
274 zonkTcType rho `thenNF_Tc` \ new_rho ->
275 returnNF_Tc (Method u id new_tys new_rho orig loc)
277 zonkInst (LitInst u lit ty orig loc)
278 = zonkTcType ty `thenNF_Tc` \ new_ty ->
279 returnNF_Tc (LitInst u lit new_ty orig loc)
284 tyVarsOfInst :: Inst s -> TcTyVarSet s
285 tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
286 tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
287 -- The id might not be a RealId; in the case of
288 -- locally-overloaded class methods, for example
289 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
292 @matchesInst@ checks when two @Inst@s are instances of the same
293 thing at the same type, even if their uniques differ.
296 matchesInst :: Inst s -> Inst s -> Bool
298 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
299 = clas1 == clas2 && ty1 `eqSimpleTy` ty2
301 matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
303 && and (zipWith eqSimpleTy tys1 tys2)
304 && length tys1 == length tys2
306 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
307 = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
309 (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2
310 (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
313 matchesInst other1 other2 = False
320 isDict :: Inst s -> Bool
321 isDict (Dict _ _ _ _ _) = True
324 isTyVarDict :: Inst s -> Bool
325 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
326 isTyVarDict other = False
329 Two predicates which deal with the case where class constraints don't
330 necessarily result in bindings. The first tells whether an @Inst@
331 must be witnessed by an actual binding; the second tells whether an
332 @Inst@ can be generalised over.
335 instBindingRequired :: Inst s -> Bool
336 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
337 instBindingRequired other = True
339 instCanBeGeneralised :: Inst s -> Bool
340 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
341 instCanBeGeneralised other = True
347 ToDo: improve these pretty-printing things. The ``origin'' is really only
348 relevant in error messages.
351 instance Outputable (Inst s) where
352 ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst
354 pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
356 ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
357 = ppHang (ppr_orig orig loc)
358 4 (ppCat [case lit of
359 OverloadedIntegral i -> ppInteger i
360 OverloadedFractional f -> ppRational f,
365 ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
366 = ppHang (ppr_orig orig loc)
367 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
369 ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
370 = ppHang (ppr_orig orig loc)
371 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u])
373 show_uniq PprDebug u = ppr PprDebug u
374 show_uniq sty u = ppNil
377 Printing in error messages
380 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
383 %************************************************************************
385 \subsection[InstEnv-types]{Type declarations}
387 %************************************************************************
390 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
393 A @ClassInstEnv@ lives inside a class, and identifies all the instances
394 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
397 There is an important consistency constraint between the @MatchEnv@s
398 in and the dfun @Id@s inside them: the free type variables of the
399 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
400 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
401 contain the following entry:
403 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
405 The "a" in the pattern must be one of the forall'd variables in
411 (TcIdOcc s, TcExpr s)) -- The new binding
415 lookupInst dict@(Dict _ clas ty orig loc)
416 = case lookupMEnv matchTy (get_inst_env clas orig) ty of
417 Nothing -> tcAddSrcLoc loc $
418 tcAddErrCtxt (pprOrigin ""{-hdr-} orig loc) $
419 failTc (noInstanceErr dict)
423 (tyvars, rho) = splitForAllTy (idType dfun_id)
424 ty_args = map (assoc "lookupInst" tenv) tyvars
425 -- tenv should bind all the tyvars
427 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
429 (theta, tau) = splitRhoTy dfun_rho
431 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
433 rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
435 returnTc (dicts, (instToId dict, rhs))
440 lookupInst inst@(Method _ id tys rho orig loc)
441 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
442 returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
444 (theta,_) = splitRhoTy rho
448 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
449 | i >= toInteger minInt && i <= toInteger maxInt
450 = -- It's overloaded but small enough to fit into an Int
451 tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
452 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
453 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
456 = -- Alas, it is overloaded and a big literal!
457 tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
458 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
459 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
461 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
462 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
464 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
465 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
467 -- The type Rational isn't wired in so we have to conjure it up
468 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
470 rational_ty = mkSynTy rational_tycon []
471 rational_lit = HsLitOut (HsFrac f) rational_ty
473 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
474 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) rational_lit))
477 There is a second, simpler interface, when you want an instance of a
478 class at a given nullary type constructor. It just returns the
479 appropriate dictionary if it exists. It is used only when resolving
480 ambiguous dictionaries.
483 lookupSimpleInst :: ClassInstEnv
485 -> Type -- Look up (c,t)
486 -> TcM s [(Class,Type)] -- Here are the needed (c,t)s
488 lookupSimpleInst class_inst_env clas ty
489 = case (lookupMEnv matchTy class_inst_env ty) of
490 Nothing -> failTc (noSimpleInst clas ty)
491 Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
493 (_, theta, _) = splitSigmaTy (idType dfun)
495 noSimpleInst clas ty sty
496 = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas),
497 ppStr "at type", ppQuote (ppr sty ty)]
501 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
502 It does it by filtering the class's @InstEnv@. All pretty shady stuff.
505 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
509 mkInstSpecEnv :: Class -- class
510 -> Type -- instance type
511 -> [TyVarTemplate] -- instance tyvars
512 -> ThetaType -- superclasses dicts
513 -> SpecEnv -- specenv for dfun of instance
515 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
516 = mkSpecEnv (catMaybes (map maybe_spec_info matches))
518 matches = matchMEnv matchTy (classInstEnv clas) inst_ty
520 maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
521 = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
522 maybe_spec_info (_, match_info, _)
529 :: ClassInstEnv -- Incoming envt
530 -> Type -- The instance type: inst_ty
531 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
532 -- be the same as the forall'd tyvars of the dfun id.
534 ClassInstEnv -- Success
535 (Type, Id) -- Offending overlap
537 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
542 %************************************************************************
544 \subsection[Inst-origin]{The @InstOrigin@ type}
546 %************************************************************************
548 The @InstOrigin@ type gives information about where a dictionary came from.
549 This is important for decent error message reporting because dictionaries
550 don't appear in the original source code. Doubtless this type will evolve...
554 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
555 | OccurrenceOfCon Id -- Occurrence of a data constructor
559 | DataDeclOrigin -- Typechecking a data declaration
561 | InstanceDeclOrigin -- Typechecking an instance decl
563 | LiteralOrigin HsLit -- Occurrence of a literal
565 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
567 | SignatureOrigin -- A dict created from a type signature
569 | DoOrigin -- The monad for a do expression
571 | ClassDeclOrigin -- Manufactured during a class decl
574 -- | DerivingOrigin InstanceMapper
578 -- During "deriving" operations we have an ever changing
579 -- mapping of classes to instances, so we record it inside the
580 -- origin information. This is a bit of a hack, but it works
581 -- fine. (Simon is to blame [WDP].)
583 | InstanceSpecOrigin InstanceMapper
584 Class -- in a SPECIALIZE instance pragma
587 -- When specialising instances the instance info attached to
588 -- each class is not yet ready, so we record it inside the
589 -- origin information. This is a bit of a hack, but it works
590 -- fine. (Patrick is to blame [WDP].)
592 -- | DefaultDeclOrigin -- Related to a `default' declaration
594 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
596 -- Argument or result of a ccall
597 -- Dictionaries with this origin aren't actually mentioned in the
598 -- translated term, and so need not be bound. Nor should they
599 -- be abstracted over.
601 | CCallOrigin String -- CCall label
602 (Maybe RenamedHsExpr) -- Nothing if it's the result
603 -- Just arg, for an argument
605 | LitLitOrigin String -- the litlit
607 | UnknownOrigin -- Help! I give up...
611 -- During deriving and instance specialisation operations
612 -- we can't get the instances of the class from inside the
613 -- class, because the latter ain't ready yet. Instead we
614 -- find a mapping from classes to envts inside the dict origin.
616 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
617 -- get_inst_env clas (DerivingOrigin inst_mapper _ _)
618 -- = fst (inst_mapper clas)
619 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
620 = fst (inst_mapper clas)
621 get_inst_env clas other_orig = classInstEnv clas
624 pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error
626 pprOrigin hdr orig locn
627 = addErrLoc locn hdr $ \ sty ->
630 ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
631 ppr sty id, ppChar '\'']
632 OccurrenceOfCon id ->
633 ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
634 ppr sty id, ppChar '\'']
635 InstanceDeclOrigin ->
636 ppStr "in an instance declaration"
638 ppCat [ppStr "at an overloaded literal:", ppr sty lit]
639 ArithSeqOrigin seq ->
640 ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
642 ppStr "in a type signature"
644 ppStr "in a do statement"
646 ppStr "in a class declaration"
647 InstanceSpecOrigin _ clas ty ->
648 ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
649 ppr sty clas, ppStr "\" type: ", ppr sty ty]
650 ValSpecOrigin name ->
651 ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
652 ppr sty name, ppStr "'"]
653 CCallOrigin clabel Nothing{-ccall result-} ->
654 ppBesides [ppStr "in the result of the _ccall_ to `",
655 ppStr clabel, ppStr "'"]
656 CCallOrigin clabel (Just arg_expr) ->
657 ppBesides [ppStr "in an argument in the _ccall_ to `",
658 ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
660 ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
662 ppStr "in... oops -- I don't know where the overloading came from!"