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, lookupSimpleInst,
26 instBindingRequired, instCanBeGeneralised,
33 import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
34 InPat, OutPat, Stmt, Qualifier, Match,
35 ArithSeqInfo, PolyType, Fake )
36 import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
37 import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
38 mkHsTyApp, mkHsDictApp, tcIdTyVars )
40 import TcMonad hiding ( rnMtoTcM )
41 import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
42 import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
43 tcInstType, zonkTcType )
45 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
46 import Class ( isCcallishClass, isNoDictClass, classInstEnv,
47 Class(..), GenClass, ClassInstEnv(..)
49 import ErrUtils ( addErrLoc, Error(..) )
50 import Id ( GenId, idType, mkInstId )
51 import MatchEnv ( lookupMEnv, insertMEnv )
52 import Name ( mkLocalName, getLocalName, Name )
54 import PprType ( GenClass, TyCon, GenType, GenTyVar )
55 import PprStyle ( PprStyle(..) )
57 import RnHsSyn ( RnName{-instance NamedThing-} )
58 import SpecEnv ( SpecEnv(..) )
59 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
60 import Type ( GenType, eqSimpleTy, instantiateTy,
61 isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
62 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
65 import TyVar ( unionTyVarSets, GenTyVar )
66 import TysPrim ( intPrimTy )
67 import TysWiredIn ( intDataCon, integerTy )
68 import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey,
69 fromIntClassOpKey, fromIntegerClassOpKey, Unique
71 import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
74 %************************************************************************
76 \subsection[Inst-collections]{LIE: a collection of Insts}
78 %************************************************************************
81 type LIE s = Bag (Inst s)
84 unitLIE inst = unitBag inst
85 plusLIE lie1 lie2 = lie1 `unionBags` lie2
86 consLIE inst lie = inst `consBag` lie
87 plusLIEs lies = unionManyBags lies
89 zonkLIE :: LIE s -> NF_TcM s (LIE s)
90 zonkLIE lie = mapBagNF_Tc zonkInst lie
93 %************************************************************************
95 \subsection[Inst-types]{@Inst@ types}
97 %************************************************************************
99 An @Inst@ is either a dictionary, an instance of an overloaded
100 literal, or an instance of an overloaded value. We call the latter a
101 ``method'' even though it may not correspond to a class operation.
102 For example, we might have an instance of the @double@ function at
103 type Int, represented by
105 Method 34 doubleId [Int] origin
111 Class -- The type of the dict is (c t), where
112 (TcType s) -- c is the class and t the type;
119 (TcIdOcc s) -- The overloaded function
120 -- This function will be a global, local, or ClassOpId;
121 -- inside instance decls (only) it can also be an InstId!
122 -- The id needn't be completely polymorphic.
123 -- You'll probably find its name (for documentation purposes)
124 -- inside the InstOrigin
126 [TcType s] -- The types to which its polymorphic tyvars
127 -- should be instantiated.
128 -- These types must saturate the Id's foralls.
130 (TcRhoType s) -- Cached: (type-of-id applied to inst_tys)
131 -- If this type is (theta => tau) then the type of the Method
132 -- is tau, and the method can be built by saying
134 -- where dicts are constructed from theta
142 (TcType s) -- The type at which the literal is used
143 (InstOrigin s) -- Always a literal; but more convenient to carry this around
147 = OverloadedIntegral Integer -- The number
148 | OverloadedFractional Rational -- The number
150 getInstOrigin (Dict u clas ty origin loc) = origin
151 getInstOrigin (Method u clas ty rho origin loc) = origin
152 getInstOrigin (LitInst u lit ty origin loc) = origin
159 newDicts :: InstOrigin s
160 -> [(Class, TcType s)]
161 -> NF_TcM s (LIE s, [TcIdOcc s])
163 = tcGetSrcLoc `thenNF_Tc` \ loc ->
164 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
166 mk_dict u (clas, ty) = Dict u clas ty orig loc
167 dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
169 returnNF_Tc (listToBag dicts, map instToId dicts)
171 newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
172 -- but with slightly different interface
173 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
175 mk_dict u (clas, ty) = Dict u clas ty orig loc
176 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
178 returnNF_Tc (dicts, map instToId dicts)
180 newMethod :: InstOrigin s
183 -> NF_TcM s (LIE s, TcIdOcc s)
184 newMethod orig id tys
185 = -- Get the Id type and instantiate it at the specified types
187 RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
189 (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
190 tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
191 TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
192 in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
193 ) `thenNF_Tc` \ rho_ty ->
194 -- Our friend does the rest
195 newMethodWithGivenTy orig id tys rho_ty
198 newMethodWithGivenTy orig id tys rho_ty
199 = tcGetSrcLoc `thenNF_Tc` \ loc ->
200 tcGetUnique `thenNF_Tc` \ new_uniq ->
202 meth_inst = Method new_uniq id tys rho_ty orig loc
204 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
206 newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
207 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
208 -- slightly different interface
209 = -- Get the Id type and instantiate it at the specified types
211 (tyvars,rho) = splitForAllTy (idType real_id)
213 tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty ->
214 tcGetUnique `thenNF_Tc` \ new_uniq ->
216 meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
218 returnNF_Tc (meth_inst, instToId meth_inst)
220 newOverloadedLit :: InstOrigin s
223 -> NF_TcM s (LIE s, TcIdOcc s)
224 newOverloadedLit orig lit ty
225 = tcGetSrcLoc `thenNF_Tc` \ loc ->
226 tcGetUnique `thenNF_Tc` \ new_uniq ->
228 lit_inst = LitInst new_uniq lit ty orig loc
230 returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
235 instToId :: Inst s -> TcIdOcc s
236 instToId (Dict u clas ty orig loc)
237 = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str False{-emph name-} loc))
239 str = SLIT("d.") _APPEND_ (getLocalName clas)
240 instToId (Method u id tys rho_ty orig loc)
241 = TcId (mkInstId u tau_ty (mkLocalName u str False{-emph name-} loc))
243 (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
244 str = SLIT("m.") _APPEND_ (getLocalName id)
246 instToId (LitInst u list ty orig loc)
247 = TcId (mkInstId u ty (mkLocalName u SLIT("lit") True{-emph uniq-} loc))
251 instType :: Inst s -> TcType s
252 instType (Dict _ clas ty _ _) = mkDictTy clas ty
253 instType (LitInst _ _ ty _ _) = ty
254 instType (Method _ id tys ty _ _) = ty
260 Zonking makes sure that the instance types are fully zonked,
261 but doesn't do the same for the Id in a Method. There's no
262 need, and it's a lot of extra work.
265 zonkInst :: Inst s -> NF_TcM s (Inst s)
266 zonkInst (Dict u clas ty orig loc)
267 = zonkTcType ty `thenNF_Tc` \ new_ty ->
268 returnNF_Tc (Dict u clas new_ty orig loc)
270 zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id!
271 = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
272 zonkTcType rho `thenNF_Tc` \ new_rho ->
273 returnNF_Tc (Method u id new_tys new_rho orig loc)
275 zonkInst (LitInst u lit ty orig loc)
276 = zonkTcType ty `thenNF_Tc` \ new_ty ->
277 returnNF_Tc (LitInst u lit new_ty orig loc)
282 tyVarsOfInst :: Inst s -> TcTyVarSet s
283 tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
284 tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
285 -- The id might not be a RealId; in the case of
286 -- locally-overloaded class methods, for example
287 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
290 @matchesInst@ checks when two @Inst@s are instances of the same
291 thing at the same type, even if their uniques differ.
294 matchesInst :: Inst s -> Inst s -> Bool
296 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
297 = clas1 == clas2 && ty1 `eqSimpleTy` ty2
299 matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
301 && and (zipWith eqSimpleTy tys1 tys2)
302 && length tys1 == length tys2
304 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
305 = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
307 (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2
308 (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
311 matchesInst other1 other2 = False
318 isDict :: Inst s -> Bool
319 isDict (Dict _ _ _ _ _) = True
322 isTyVarDict :: Inst s -> Bool
323 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
324 isTyVarDict other = False
327 Two predicates which deal with the case where class constraints don't
328 necessarily result in bindings. The first tells whether an @Inst@
329 must be witnessed by an actual binding; the second tells whether an
330 @Inst@ can be generalised over.
333 instBindingRequired :: Inst s -> Bool
334 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
335 instBindingRequired other = True
337 instCanBeGeneralised :: Inst s -> Bool
338 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
339 instCanBeGeneralised other = True
345 ToDo: improve these pretty-printing things. The ``origin'' is really only
346 relevant in error messages.
349 instance Outputable (Inst s) where
350 ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst
352 pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
354 ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
355 = ppHang (ppr_orig orig loc)
356 4 (ppCat [case lit of
357 OverloadedIntegral i -> ppInteger i
358 OverloadedFractional f -> ppRational f,
363 ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
364 = ppHang (ppr_orig orig loc)
365 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
367 ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
368 = ppHang (ppr_orig orig loc)
369 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u])
371 show_uniq PprDebug u = ppr PprDebug u
372 show_uniq sty u = ppNil
375 Printing in error messages
378 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
381 %************************************************************************
383 \subsection[InstEnv-types]{Type declarations}
385 %************************************************************************
388 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
391 A @ClassInstEnv@ lives inside a class, and identifies all the instances
392 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
395 There is an important consistency constraint between the @MatchEnv@s
396 in and the dfun @Id@s inside them: the free type variables of the
397 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
398 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
399 contain the following entry:
401 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
403 The "a" in the pattern must be one of the forall'd variables in
409 (TcIdOcc s, TcExpr s)) -- The new binding
413 lookupInst dict@(Dict _ clas ty orig loc)
414 = case lookupMEnv matchTy (get_inst_env clas orig) ty of
415 Nothing -> tcAddSrcLoc loc $
416 tcAddErrCtxt (pprOrigin ""{-hdr-} orig loc) $
417 failTc (noInstanceErr dict)
421 (tyvars, rho) = splitForAllTy (idType dfun_id)
422 ty_args = map (assoc "lookupInst" tenv) tyvars
423 -- tenv should bind all the tyvars
425 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
427 (theta, tau) = splitRhoTy dfun_rho
429 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
431 rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
433 returnTc (dicts, (instToId dict, rhs))
438 lookupInst inst@(Method _ id tys rho orig loc)
439 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
440 returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
442 (theta,_) = splitRhoTy rho
446 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
447 | i >= toInteger minInt && i <= toInteger maxInt
448 = -- It's overloaded but small enough to fit into an Int
449 tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
450 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
451 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
454 = -- Alas, it is overloaded and a big literal!
455 tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
456 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
457 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
459 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
460 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
462 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
463 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
465 -- The type Rational isn't wired in so we have to conjure it up
466 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
468 rational_ty = mkSynTy rational_tycon []
469 rational_lit = HsLitOut (HsFrac f) rational_ty
471 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
472 returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) rational_lit))
475 There is a second, simpler interface, when you want an instance of a
476 class at a given nullary type constructor. It just returns the
477 appropriate dictionary if it exists. It is used only when resolving
478 ambiguous dictionaries.
481 lookupSimpleInst :: ClassInstEnv
483 -> Type -- Look up (c,t)
484 -> TcM s [(Class,Type)] -- Here are the needed (c,t)s
486 lookupSimpleInst class_inst_env clas ty
487 = case (lookupMEnv matchTy class_inst_env ty) of
488 Nothing -> failTc (noSimpleInst clas ty)
489 Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
491 (_, theta, _) = splitSigmaTy (idType dfun)
493 noSimpleInst clas ty sty
494 = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas),
495 ppStr "at type", ppQuote (ppr sty ty)]
499 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
500 It does it by filtering the class's @InstEnv@. All pretty shady stuff.
503 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
507 mkInstSpecEnv :: Class -- class
508 -> Type -- instance type
509 -> [TyVarTemplate] -- instance tyvars
510 -> ThetaType -- superclasses dicts
511 -> SpecEnv -- specenv for dfun of instance
513 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
514 = mkSpecEnv (catMaybes (map maybe_spec_info matches))
516 matches = matchMEnv matchTy (classInstEnv clas) inst_ty
518 maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
519 = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
520 maybe_spec_info (_, match_info, _)
527 :: ClassInstEnv -- Incoming envt
528 -> Type -- The instance type: inst_ty
529 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
530 -- be the same as the forall'd tyvars of the dfun id.
532 ClassInstEnv -- Success
533 (Type, Id) -- Offending overlap
535 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
540 %************************************************************************
542 \subsection[Inst-origin]{The @InstOrigin@ type}
544 %************************************************************************
546 The @InstOrigin@ type gives information about where a dictionary came from.
547 This is important for decent error message reporting because dictionaries
548 don't appear in the original source code. Doubtless this type will evolve...
552 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
553 | OccurrenceOfCon Id -- Occurrence of a data constructor
557 | DataDeclOrigin -- Typechecking a data declaration
559 | InstanceDeclOrigin -- Typechecking an instance decl
561 | LiteralOrigin HsLit -- Occurrence of a literal
563 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
565 | SignatureOrigin -- A dict created from a type signature
567 | DoOrigin -- The monad for a do expression
569 | ClassDeclOrigin -- Manufactured during a class decl
572 -- | DerivingOrigin InstanceMapper
576 -- During "deriving" operations we have an ever changing
577 -- mapping of classes to instances, so we record it inside the
578 -- origin information. This is a bit of a hack, but it works
579 -- fine. (Simon is to blame [WDP].)
581 | InstanceSpecOrigin InstanceMapper
582 Class -- in a SPECIALIZE instance pragma
585 -- When specialising instances the instance info attached to
586 -- each class is not yet ready, so we record it inside the
587 -- origin information. This is a bit of a hack, but it works
588 -- fine. (Patrick is to blame [WDP].)
590 -- | DefaultDeclOrigin -- Related to a `default' declaration
592 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
594 -- Argument or result of a ccall
595 -- Dictionaries with this origin aren't actually mentioned in the
596 -- translated term, and so need not be bound. Nor should they
597 -- be abstracted over.
599 | CCallOrigin String -- CCall label
600 (Maybe RenamedHsExpr) -- Nothing if it's the result
601 -- Just arg, for an argument
603 | LitLitOrigin String -- the litlit
605 | UnknownOrigin -- Help! I give up...
609 -- During deriving and instance specialisation operations
610 -- we can't get the instances of the class from inside the
611 -- class, because the latter ain't ready yet. Instead we
612 -- find a mapping from classes to envts inside the dict origin.
614 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
615 -- get_inst_env clas (DerivingOrigin inst_mapper _ _)
616 -- = fst (inst_mapper clas)
617 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
618 = fst (inst_mapper clas)
619 get_inst_env clas other_orig = classInstEnv clas
622 pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error
624 pprOrigin hdr orig locn
625 = addErrLoc locn hdr $ \ sty ->
628 ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
629 ppr sty id, ppChar '\'']
630 OccurrenceOfCon id ->
631 ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
632 ppr sty id, ppChar '\'']
633 InstanceDeclOrigin ->
634 ppStr "in an instance declaration"
636 ppCat [ppStr "at an overloaded literal:", ppr sty lit]
637 ArithSeqOrigin seq ->
638 ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
640 ppStr "in a type signature"
642 ppStr "in a do statement"
644 ppStr "in a class declaration"
645 InstanceSpecOrigin _ clas ty ->
646 ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
647 ppr sty clas, ppStr "\" type: ", ppr sty ty]
648 ValSpecOrigin name ->
649 ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
650 ppr sty name, ppStr "'"]
651 CCallOrigin clabel Nothing{-ccall result-} ->
652 ppBesides [ppStr "in the result of the _ccall_ to `",
653 ppStr clabel, ppStr "'"]
654 CCallOrigin clabel (Just arg_expr) ->
655 ppBesides [ppStr "in an argument in the _ccall_ to `",
656 ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
658 ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
660 ppStr "in... oops -- I don't know where the overloading came from!"