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
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 )
39 import TcMonad hiding ( rnMtoTcM )
40 import TcEnv ( tcLookupGlobalValueByKey )
41 import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
42 tcInstType, zonkTcType )
44 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
45 import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv )
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, instantiateTy,
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 )
67 %************************************************************************
69 \subsection[Inst-collections]{LIE: a collection of Insts}
71 %************************************************************************
74 type LIE s = Bag (Inst s)
77 unitLIE inst = unitBag inst
78 plusLIE lie1 lie2 = lie1 `unionBags` lie2
79 consLIE inst lie = inst `consBag` lie
80 plusLIEs lies = unionManyBags lies
82 zonkLIE :: LIE s -> NF_TcM s (LIE s)
83 zonkLIE lie = mapBagNF_Tc zonkInst lie
86 %************************************************************************
88 \subsection[Inst-types]{@Inst@ types}
90 %************************************************************************
92 An @Inst@ is either a dictionary, an instance of an overloaded
93 literal, or an instance of an overloaded value. We call the latter a
94 ``method'' even though it may not correspond to a class operation.
95 For example, we might have an instance of the @double@ function at
96 type Int, represented by
98 Method 34 doubleId [Int] origin
104 Class -- The type of the dict is (c t), where
105 (TcType s) -- c is the class and t the type;
112 (TcIdOcc s) -- The overloaded function
113 -- This function will be a global, local, or ClassOpId;
114 -- inside instance decls (only) it can also be an InstId!
115 -- The id needn't be completely polymorphic.
116 -- You'll probably find its name (for documentation purposes)
117 -- inside the InstOrigin
119 [TcType s] -- The types to which its polymorphic tyvars
120 -- should be instantiated.
121 -- These types must saturate the Id's foralls.
123 (TcRhoType s) -- Cached: (type-of-id applied to inst_tys)
124 -- If this type is (theta => tau) then the type of the Method
125 -- is tau, and the method can be built by saying
127 -- where dicts are constructed from theta
135 (TcType s) -- The type at which the literal is used
136 (InstOrigin s) -- Always a literal; but more convenient to carry this around
140 = OverloadedIntegral Integer -- The number
141 | OverloadedFractional Rational -- The number
143 getInstOrigin (Dict u clas ty origin loc) = origin
144 getInstOrigin (Method u clas ty rho origin loc) = origin
145 getInstOrigin (LitInst u lit ty origin loc) = origin
152 newDicts :: InstOrigin s
153 -> [(Class, TcType s)]
154 -> NF_TcM s (LIE s, [TcIdOcc s])
156 = tcGetSrcLoc `thenNF_Tc` \ loc ->
157 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
159 mk_dict u (clas, ty) = Dict u clas ty orig loc
160 dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
162 returnNF_Tc (listToBag dicts, map instToId dicts)
164 newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
165 -- but with slightly different interface
166 = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
168 mk_dict u (clas, ty) = Dict u clas ty orig loc
169 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
171 returnNF_Tc (dicts, map instToId dicts)
173 newMethod :: InstOrigin s
176 -> NF_TcM s (LIE s, TcIdOcc s)
177 newMethod orig id tys
178 = -- Get the Id type and instantiate it at the specified types
180 RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
181 in tcInstType (zipEqual "newMethod" tyvars tys) rho
182 TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
183 in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
184 ) `thenNF_Tc` \ rho_ty ->
185 -- Our friend does the rest
186 newMethodWithGivenTy orig id tys rho_ty
189 newMethodWithGivenTy orig id tys rho_ty
190 = tcGetSrcLoc `thenNF_Tc` \ loc ->
191 tcGetUnique `thenNF_Tc` \ new_uniq ->
193 meth_inst = Method new_uniq id tys rho_ty orig loc
195 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
197 newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
198 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
199 -- slightly different interface
200 = -- Get the Id type and instantiate it at the specified types
202 (tyvars,rho) = splitForAllTy (idType real_id)
204 tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty ->
205 tcGetUnique `thenNF_Tc` \ new_uniq ->
207 meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
209 returnNF_Tc (meth_inst, instToId meth_inst)
211 newOverloadedLit :: InstOrigin s
214 -> NF_TcM s (LIE s, TcIdOcc s)
215 newOverloadedLit orig lit ty
216 = tcGetSrcLoc `thenNF_Tc` \ loc ->
217 tcGetUnique `thenNF_Tc` \ new_uniq ->
219 lit_inst = LitInst new_uniq lit ty orig loc
221 returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
226 instToId :: Inst s -> TcIdOcc s
227 instToId (Dict u clas ty orig loc)
228 = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
230 str = SLIT("d.") _APPEND_ (getLocalName clas)
231 instToId (Method u id tys rho_ty orig loc)
232 = TcId (mkInstId u tau_ty (mkLocalName u str loc))
234 (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
235 str = SLIT("m.") _APPEND_ (getLocalName id)
237 instToId (LitInst u list ty orig loc)
238 = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc))
242 instType :: Inst s -> TcType s
243 instType (Dict _ clas ty _ _) = mkDictTy clas ty
244 instType (LitInst _ _ ty _ _) = ty
245 instType (Method _ id tys ty _ _) = ty
251 Zonking makes sure that the instance types are fully zonked,
252 but doesn't do the same for the Id in a Method. There's no
253 need, and it's a lot of extra work.
256 zonkInst :: Inst s -> NF_TcM s (Inst s)
257 zonkInst (Dict u clas ty orig loc)
258 = zonkTcType ty `thenNF_Tc` \ new_ty ->
259 returnNF_Tc (Dict u clas new_ty orig loc)
261 zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id!
262 = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
263 zonkTcType rho `thenNF_Tc` \ new_rho ->
264 returnNF_Tc (Method u id new_tys new_rho orig loc)
266 zonkInst (LitInst u lit ty orig loc)
267 = zonkTcType ty `thenNF_Tc` \ new_ty ->
268 returnNF_Tc (LitInst u lit new_ty orig loc)
273 tyVarsOfInst :: Inst s -> TcTyVarSet s
274 tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
275 tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
276 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
279 @matchesInst@ checks when two @Inst@s are instances of the same
280 thing at the same type, even if their uniques differ.
283 matchesInst :: Inst s -> Inst s -> Bool
285 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
286 = clas1 == clas2 && ty1 `eqSimpleTy` ty2
288 matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
290 && and (zipWith eqSimpleTy tys1 tys2)
291 && length tys1 == length tys2
293 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
294 = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
296 (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2
297 (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
300 matchesInst other1 other2 = False
307 isDict :: Inst s -> Bool
308 isDict (Dict _ _ _ _ _) = True
311 isTyVarDict :: Inst s -> Bool
312 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
313 isTyVarDict other = False
316 Two predicates which deal with the case where class constraints don't
317 necessarily result in bindings. The first tells whether an @Inst@
318 must be witnessed by an actual binding; the second tells whether an
319 @Inst@ can be generalised over.
322 instBindingRequired :: Inst s -> Bool
323 instBindingRequired inst
324 = case getInstOrigin inst of
325 CCallOrigin _ _ -> False -- No binding required
326 LitLitOrigin _ -> False
327 OccurrenceOfCon _ -> False
330 instCanBeGeneralised :: Inst s -> Bool
331 instCanBeGeneralised inst
332 = case getInstOrigin inst of
333 CCallOrigin _ _ -> False -- Can't be generalised
334 LitLitOrigin _ -> False -- Can't be generalised
341 ToDo: improve these pretty-printing things. The ``origin'' is really only
342 relevant in error messages.
345 instance Outputable (Inst s) where
346 ppr sty (LitInst uniq lit ty orig loc)
348 OverloadedIntegral i -> ppInteger i
349 OverloadedFractional f -> ppRational f,
355 ppr sty (Dict uniq clas ty orig loc)
356 = ppSep [ppr sty clas,
362 ppr sty (Method uniq id tys rho orig loc)
369 show_uniq PprDebug uniq = ppr PprDebug uniq
370 show_uniq sty uniq = ppNil
374 Printing in error messages
377 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
380 %************************************************************************
382 \subsection[InstEnv-types]{Type declarations}
384 %************************************************************************
387 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
390 A @ClassInstEnv@ lives inside a class, and identifies all the instances
391 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
394 There is an important consistency constraint between the @MatchEnv@s
395 in and the dfun @Id@s inside them: the free type variables of the
396 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
397 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
398 contain the following entry:
400 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
402 The "a" in the pattern must be one of the forall'd variables in
408 (TcIdOcc s, TcExpr s)) -- The new binding
412 lookupInst dict@(Dict _ clas ty orig loc)
413 = case lookupMEnv matchTy (get_inst_env clas orig) ty of
414 Nothing -> tcAddSrcLoc loc $
415 tcAddErrCtxt (pprOrigin orig) $
416 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 lookupSimpleInst :: ClassInstEnv
475 -> Type -- Look up (c,t)
476 -> TcM s [(Class,Type)] -- Here are the needed (c,t)s
478 lookupSimpleInst class_inst_env clas ty
479 = case (lookupMEnv matchTy class_inst_env ty) of
480 Nothing -> failTc (noSimpleInst clas ty)
481 Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
483 (_, theta, _) = splitSigmaTy (idType dfun)
485 noSimpleInst clas ty sty
486 = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas),
487 ppStr "at type", ppQuote (ppr sty ty)]
491 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
492 It does it by filtering the class's @InstEnv@. All pretty shady stuff.
495 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
499 mkInstSpecEnv :: Class -- class
500 -> Type -- instance type
501 -> [TyVarTemplate] -- instance tyvars
502 -> ThetaType -- superclasses dicts
503 -> SpecEnv -- specenv for dfun of instance
505 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
506 = mkSpecEnv (catMaybes (map maybe_spec_info matches))
508 matches = matchMEnv matchTy (classInstEnv clas) inst_ty
510 maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
511 = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
512 maybe_spec_info (_, match_info, _)
519 :: ClassInstEnv -- Incoming envt
520 -> Type -- The instance type: inst_ty
521 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
522 -- be the same as the forall'd tyvars of the dfun id.
524 ClassInstEnv -- Success
525 (Type, Id) -- Offending overlap
527 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
532 %************************************************************************
534 \subsection[Inst-origin]{The @InstOrigin@ type}
536 %************************************************************************
538 The @InstOrigin@ type gives information about where a dictionary came from.
539 This is important for decent error message reporting because dictionaries
540 don't appear in the original source code. Doubtless this type will evolve...
544 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
545 | OccurrenceOfCon Id -- Occurrence of a data constructor
549 | DataDeclOrigin -- Typechecking a data declaration
551 | InstanceDeclOrigin -- Typechecking an instance decl
553 | LiteralOrigin HsLit -- Occurrence of a literal
555 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
557 | SignatureOrigin -- A dict created from a type signature
559 | DoOrigin -- The monad for a do expression
561 | ClassDeclOrigin -- Manufactured during a class decl
564 -- | DerivingOrigin InstanceMapper
568 -- During "deriving" operations we have an ever changing
569 -- mapping of classes to instances, so we record it inside the
570 -- origin information. This is a bit of a hack, but it works
571 -- fine. (Simon is to blame [WDP].)
573 | InstanceSpecOrigin InstanceMapper
574 Class -- in a SPECIALIZE instance pragma
577 -- When specialising instances the instance info attached to
578 -- each class is not yet ready, so we record it inside the
579 -- origin information. This is a bit of a hack, but it works
580 -- fine. (Patrick is to blame [WDP].)
582 -- | DefaultDeclOrigin -- Related to a `default' declaration
584 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
586 -- Argument or result of a ccall
587 -- Dictionaries with this origin aren't actually mentioned in the
588 -- translated term, and so need not be bound. Nor should they
589 -- be abstracted over.
591 | CCallOrigin String -- CCall label
592 (Maybe RenamedHsExpr) -- Nothing if it's the result
593 -- Just arg, for an argument
595 | LitLitOrigin String -- the litlit
597 | UnknownOrigin -- Help! I give up...
601 -- During deriving and instance specialisation operations
602 -- we can't get the instances of the class from inside the
603 -- class, because the latter ain't ready yet. Instead we
604 -- find a mapping from classes to envts inside the dict origin.
606 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
607 -- get_inst_env clas (DerivingOrigin inst_mapper _ _)
608 -- = fst (inst_mapper clas)
609 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
610 = fst (inst_mapper clas)
611 get_inst_env clas other_orig = classInstEnv clas
614 pprOrigin :: InstOrigin s -> PprStyle -> Pretty
616 pprOrigin (OccurrenceOf id) sty
617 = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
618 ppr sty id, ppChar '\'']
619 pprOrigin (OccurrenceOfCon id) sty
620 = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
621 ppr sty id, ppChar '\'']
622 pprOrigin (InstanceDeclOrigin) sty
623 = ppStr "in an instance declaration"
624 pprOrigin (LiteralOrigin lit) sty
625 = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
626 pprOrigin (ArithSeqOrigin seq) sty
627 = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
628 pprOrigin (SignatureOrigin) sty
629 = ppStr "in a type signature"
630 pprOrigin (DoOrigin) sty
631 = ppStr "in a do statement"
632 pprOrigin (ClassDeclOrigin) sty
633 = ppStr "in a class declaration"
634 -- pprOrigin (DerivingOrigin _ clas tycon) sty
635 -- = ppBesides [ppStr "in a `deriving' clause; class `",
637 -- ppStr "'; offending type `",
640 pprOrigin (InstanceSpecOrigin _ clas ty) sty
641 = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
642 ppr sty clas, ppStr "\" type: ", ppr sty ty]
643 -- pprOrigin (DefaultDeclOrigin) sty
644 -- = ppStr "in a `default' declaration"
645 pprOrigin (ValSpecOrigin name) sty
646 = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
647 ppr sty name, ppStr "'"]
648 pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty
649 = ppBesides [ppStr "in the result of the _ccall_ to `",
650 ppStr clabel, ppStr "'"]
651 pprOrigin (CCallOrigin clabel (Just arg_expr)) sty
652 = ppBesides [ppStr "in an argument in the _ccall_ to `",
653 ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
654 pprOrigin (LitLitOrigin s) sty
655 = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
656 pprOrigin UnknownOrigin sty
657 = ppStr "in... oops -- I don't know where the overloading came from!"