2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
8 LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE,
9 pprInsts, pprInstsInFull,
11 Inst, OverloadedLit(..), pprInst,
15 newDictFromOld, newDicts, newDictsAtLoc,
16 newMethod, newMethodWithGivenTy, newOverloadedLit,
18 tyVarsOfInst, instLoc, getDictClassTys,
20 lookupInst, lookupSimpleInst, LookupInstResult(..),
22 isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor,
23 instBindingRequired, instCanBeGeneralised,
27 InstOrigin(..), pprOrigin
30 #include "HsVersions.h"
32 import HsSyn ( HsLit(..), HsExpr(..), MonoBinds(..) )
33 import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr )
34 import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
35 TcDictBinds, TcMonoBinds,
36 mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
39 import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
40 import TcType ( TcThetaType,
41 TcType, TcRhoType, TcTauType, TcMaybe, TcTyVarSet,
42 tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy, tcSplitRhoTy,
45 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList,
46 listToBag, consBag, Bag )
47 import Class ( classInstEnv,
50 import Id ( idType, mkUserLocal, mkSysLocal, Id,
51 GenIdSet, elementOfIdSet
53 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
54 import Name ( OccName(..), Name, mkLocalName,
55 mkSysLocalName, occNameString, getOccName )
56 import PprType ( TyCon, pprConstraint )
57 import SpecEnv ( SpecEnv, matchSpecEnv, addToSpecEnv )
58 import SrcLoc ( SrcLoc )
59 import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy, matchTys,
60 isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
61 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
64 import TyVar ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets )
65 import TysPrim ( intPrimTy )
66 import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
67 import Unique ( fromRationalClassOpKey, rationalTyConKey,
68 fromIntClassOpKey, fromIntegerClassOpKey, Unique
70 import Maybes ( MaybeErr, expectJust )
71 import Util ( thenCmp, zipEqual, zipWithEqual, isIn )
75 %************************************************************************
77 \subsection[Inst-collections]{LIE: a collection of Insts}
79 %************************************************************************
82 type LIE s = Bag (Inst s)
85 unitLIE inst = unitBag inst
86 mkLIE insts = listToBag insts
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
94 pprInsts :: [Inst s] -> SDoc
95 pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
101 go inst = quotes (ppr inst) <+> pprOrigin inst
104 %************************************************************************
106 \subsection[Inst-types]{@Inst@ types}
108 %************************************************************************
110 An @Inst@ is either a dictionary, an instance of an overloaded
111 literal, or an instance of an overloaded value. We call the latter a
112 ``method'' even though it may not correspond to a class operation.
113 For example, we might have an instance of the @double@ function at
114 type Int, represented by
116 Method 34 doubleId [Int] origin
122 Class -- The type of the dict is (c ts), where
123 [TcType s] -- c is the class and ts the types;
130 (TcIdOcc s) -- The overloaded function
131 -- This function will be a global, local, or ClassOpId;
132 -- inside instance decls (only) it can also be an InstId!
133 -- The id needn't be completely polymorphic.
134 -- You'll probably find its name (for documentation purposes)
135 -- inside the InstOrigin
137 [TcType s] -- The types to which its polymorphic tyvars
138 -- should be instantiated.
139 -- These types must saturate the Id's foralls.
141 (TcThetaType s) -- The (types of the) dictionaries to which the function
142 -- must be applied to get the method
144 (TcTauType s) -- The type of the method
149 -- INVARIANT: in (Method u f tys theta tau loc)
150 -- type of (f tys dicts(from theta)) = tau
155 (TcType s) -- The type at which the literal is used
156 (InstOrigin s) -- Always a literal; but more convenient to carry this around
160 = OverloadedIntegral Integer -- The number
161 | OverloadedFractional Rational -- The number
166 @Insts@ are ordered by their class/type info, rather than by their
167 unique. This allows the context-reduction mechanism to use standard finite
168 maps to do their stuff.
171 instance Ord (Inst s) where
174 instance Eq (Inst s) where
175 (==) i1 i2 = case i1 `cmpInst` i2 of
179 cmpInst (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
180 = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
181 cmpInst (Dict _ _ _ _ _) other
185 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
187 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
188 = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
189 cmpInst (Method _ _ _ _ _ _ _) other
192 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
193 = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
194 cmpInst (LitInst _ _ _ _ _) other
197 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
198 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
199 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
200 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
207 instOrigin (Dict u clas tys origin loc) = origin
208 instOrigin (Method u clas ty _ _ origin loc) = origin
209 instOrigin (LitInst u lit ty origin loc) = origin
211 instLoc (Dict u clas tys origin loc) = loc
212 instLoc (Method u clas ty _ _ origin loc) = loc
213 instLoc (LitInst u lit ty origin loc) = loc
215 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
217 tyVarsOfInst :: Inst s -> TcTyVarSet s
218 tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys
219 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
220 -- The id might not be a RealId; in the case of
221 -- locally-overloaded class methods, for example
222 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
228 isDict :: Inst s -> Bool
229 isDict (Dict _ _ _ _ _) = True
232 isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool
233 isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
234 = id `elementOfIdSet` ids
238 isTyVarDict :: Inst s -> Bool
239 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
240 isTyVarDict other = False
242 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
243 isStdClassTyVarDict other = False
246 Two predicates which deal with the case where class constraints don't
247 necessarily result in bindings. The first tells whether an @Inst@
248 must be witnessed by an actual binding; the second tells whether an
249 @Inst@ can be generalised over.
252 instBindingRequired :: Inst s -> Bool
253 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
254 instBindingRequired other = True
256 instCanBeGeneralised :: Inst s -> Bool
257 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
258 instCanBeGeneralised other = True
266 newDicts :: InstOrigin s
268 -> NF_TcM s (LIE s, [TcIdOcc s])
270 = tcGetSrcLoc `thenNF_Tc` \ loc ->
271 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
272 returnNF_Tc (listToBag dicts, ids)
274 -- Local function, similar to newDicts,
275 -- but with slightly different interface
276 newDictsAtLoc :: InstOrigin s
279 -> NF_TcM s ([Inst s], [TcIdOcc s])
280 newDictsAtLoc orig loc theta =
281 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
283 mk_dict u (clas, tys) = Dict u clas tys orig loc
284 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
286 returnNF_Tc (dicts, map instToId dicts)
288 newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s)
289 newDictFromOld (Dict _ _ _ orig loc) clas tys
290 = tcGetUnique `thenNF_Tc` \ uniq ->
291 returnNF_Tc (Dict uniq clas tys orig loc)
294 newMethod :: InstOrigin s
297 -> NF_TcM s (LIE s, TcIdOcc s)
298 newMethod orig id tys
299 = -- Get the Id type and instantiate it at the specified types
301 RealId id -> let (tyvars, rho) = splitForAllTys (idType id)
303 ASSERT( length tyvars == length tys)
304 tcInstType (zipTyVarEnv tyvars tys) rho
306 TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) ->
307 returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho)
308 ) `thenNF_Tc` \ rho_ty ->
310 (theta, tau) = splitRhoTy rho_ty
312 -- Our friend does the rest
313 newMethodWithGivenTy orig id tys theta tau
316 newMethodWithGivenTy orig id tys theta tau
317 = tcGetSrcLoc `thenNF_Tc` \ loc ->
318 tcGetUnique `thenNF_Tc` \ new_uniq ->
320 meth_inst = Method new_uniq id tys theta tau orig loc
322 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
324 newMethodAtLoc :: InstOrigin s -> SrcLoc
326 -> NF_TcM s (Inst s, TcIdOcc s)
327 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
328 -- slightly different interface
329 = -- Get the Id type and instantiate it at the specified types
331 (tyvars,rho) = splitForAllTys (idType real_id)
333 tcInstType (zipTyVarEnv tyvars tys) rho `thenNF_Tc` \ rho_ty ->
334 tcGetUnique `thenNF_Tc` \ new_uniq ->
336 (theta, tau) = splitRhoTy rho_ty
337 meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
339 returnNF_Tc (meth_inst, instToId meth_inst)
341 newOverloadedLit :: InstOrigin s
344 -> NF_TcM s (TcExpr s, LIE s)
345 newOverloadedLit orig (OverloadedIntegral i) ty
346 | isIntTy ty && inIntRange i -- Short cut for Int
347 = returnNF_Tc (int_lit, emptyLIE)
349 | isIntegerTy ty -- Short cut for Integer
350 = returnNF_Tc (integer_lit, emptyLIE)
353 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
354 integer_lit = HsLitOut (HsInt i) integerTy
355 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
357 newOverloadedLit orig lit ty -- The general case
358 = tcGetSrcLoc `thenNF_Tc` \ loc ->
359 tcGetUnique `thenNF_Tc` \ new_uniq ->
361 lit_inst = LitInst new_uniq lit ty orig loc
363 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
368 instToId :: Inst s -> TcIdOcc s
369 instToId (Dict u clas ty orig loc)
370 = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
372 occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
374 instToId (Method u id tys theta tau orig loc)
375 = TcId (mkUserLocal (getOccName id) u tau loc)
377 instToId (LitInst u list ty orig loc)
378 = TcId (mkSysLocal SLIT("lit") u ty loc)
384 Zonking makes sure that the instance types are fully zonked,
385 but doesn't do the same for the Id in a Method. There's no
386 need, and it's a lot of extra work.
389 zonkInst :: Inst s -> NF_TcM s (Inst s)
390 zonkInst (Dict u clas tys orig loc)
391 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
392 returnNF_Tc (Dict u clas new_tys orig loc)
394 zonkInst (Method u id tys theta tau orig loc)
395 = zonkTcId id `thenNF_Tc` \ new_id ->
396 -- Essential to zonk the id in case it's a local variable
397 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
398 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
399 zonkTcType tau `thenNF_Tc` \ new_tau ->
400 returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
402 zonkInst (LitInst u lit ty orig loc)
403 = zonkTcType ty `thenNF_Tc` \ new_ty ->
404 returnNF_Tc (LitInst u lit new_ty orig loc)
410 ToDo: improve these pretty-printing things. The ``origin'' is really only
411 relevant in error messages.
414 instance Outputable (Inst s) where
415 ppr inst = pprInst inst
417 pprInst (LitInst u lit ty orig loc)
419 OverloadedIntegral i -> integer i
420 OverloadedFractional f -> rational f,
425 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
427 pprInst (Method u id tys _ _ orig loc)
428 = hsep [ppr id, ptext SLIT("at"),
432 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
436 %************************************************************************
438 \subsection[InstEnv-types]{Type declarations}
440 %************************************************************************
443 type InstanceMapper = Class -> ClassInstEnv
446 A @ClassInstEnv@ lives inside a class, and identifies all the instances
447 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
450 There is an important consistency constraint between the @MatchEnv@s
451 in and the dfun @Id@s inside them: the free type variables of the
452 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
453 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
454 contain the following entry:
456 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
458 The "a" in the pattern must be one of the forall'd variables in
462 data LookupInstResult s
464 | SimpleInst (TcExpr s) -- Just a variable, type application, or literal
465 | GenInst [Inst s] (TcExpr s) -- The expression and its needed insts
467 -> NF_TcM s (LookupInstResult s)
471 lookupInst dict@(Dict _ clas tys orig loc)
472 = case matchSpecEnv (classInstEnv clas) tys of
476 (tyvars, rho) = splitForAllTys (idType dfun_id)
477 ty_args = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars
478 -- tenv should bind all the tyvars
480 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
482 (theta, tau) = splitRhoTy dfun_rho
483 ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
486 returnNF_Tc (SimpleInst ty_app)
488 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
490 rhs = mkHsDictApp ty_app dict_ids
492 returnNF_Tc (GenInst dicts rhs)
494 Nothing -> returnNF_Tc NoInstance
498 lookupInst inst@(Method _ id tys theta _ orig loc)
499 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
500 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
504 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
505 | isIntTy ty && in_int_range -- Short cut for Int
506 = returnNF_Tc (GenInst [] int_lit)
507 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
509 | isIntegerTy ty -- Short cut for Integer
510 = returnNF_Tc (GenInst [] integer_lit)
512 | in_int_range -- It's overloaded but small enough to fit into an Int
513 = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
514 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
515 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
517 | otherwise -- Alas, it is overloaded and a big literal!
518 = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
519 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
520 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
522 in_int_range = inIntRange i
523 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
524 integer_lit = HsLitOut (HsInt i) integerTy
525 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
527 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
528 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
530 -- The type Rational isn't wired in so we have to conjure it up
531 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
533 rational_ty = mkSynTy rational_tycon []
534 rational_lit = HsLitOut (HsFrac f) rational_ty
536 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
537 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
540 There is a second, simpler interface, when you want an instance of a
541 class at a given nullary type constructor. It just returns the
542 appropriate dictionary if it exists. It is used only when resolving
543 ambiguous dictionaries.
546 lookupSimpleInst :: ClassInstEnv
548 -> [Type] -- Look up (c,t)
549 -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
551 lookupSimpleInst class_inst_env clas tys
552 = case matchSpecEnv class_inst_env tys of
553 Nothing -> returnNF_Tc Nothing
556 -> returnNF_Tc (Just (instantiateThetaTy tenv theta))
558 (_, theta, _) = splitSigmaTy (idType dfun)
564 :: ClassInstEnv -- Incoming envt
565 -> [Type] -- The instance types: inst_tys
566 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
567 -- be the same as the forall'd tyvars of the dfun id.
569 ClassInstEnv -- Success
570 ([Type], Id) -- Offending overlap
572 addClassInst inst_env inst_tys dfun_id = addToSpecEnv inst_env inst_tys dfun_id
577 %************************************************************************
579 \subsection[Inst-origin]{The @InstOrigin@ type}
581 %************************************************************************
583 The @InstOrigin@ type gives information about where a dictionary came from.
584 This is important for decent error message reporting because dictionaries
585 don't appear in the original source code. Doubtless this type will evolve...
589 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
590 | OccurrenceOfCon Id -- Occurrence of a data constructor
594 | DataDeclOrigin -- Typechecking a data declaration
596 | InstanceDeclOrigin -- Typechecking an instance decl
598 | LiteralOrigin HsLit -- Occurrence of a literal
600 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
602 | SignatureOrigin -- A dict created from a type signature
603 | Rank2Origin -- A dict created when typechecking the argument
604 -- of a rank-2 typed function
606 | DoOrigin -- The monad for a do expression
608 | ClassDeclOrigin -- Manufactured during a class decl
610 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
613 -- When specialising instances the instance info attached to
614 -- each class is not yet ready, so we record it inside the
615 -- origin information. This is a bit of a hack, but it works
616 -- fine. (Patrick is to blame [WDP].)
618 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
620 -- Argument or result of a ccall
621 -- Dictionaries with this origin aren't actually mentioned in the
622 -- translated term, and so need not be bound. Nor should they
623 -- be abstracted over.
625 | CCallOrigin String -- CCall label
626 (Maybe RenamedHsExpr) -- Nothing if it's the result
627 -- Just arg, for an argument
629 | LitLitOrigin String -- the litlit
631 | UnknownOrigin -- Help! I give up...
635 pprOrigin :: Inst s -> SDoc
637 = hsep [text "arising from", pp_orig orig <> comma, text "at", ppr locn]
639 (orig, locn) = case inst of
640 Dict _ _ _ orig loc -> (orig,loc)
641 Method _ _ _ _ _ orig loc -> (orig,loc)
642 LitInst _ _ _ orig loc -> (orig,loc)
644 pp_orig (OccurrenceOf id)
645 = hsep [ptext SLIT("use of"), quotes (ppr id)]
646 pp_orig (OccurrenceOfCon id)
647 = hsep [ptext SLIT("use of"), quotes (ppr id)]
648 pp_orig (LiteralOrigin lit)
649 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
650 pp_orig (InstanceDeclOrigin)
651 = ptext SLIT("an instance declaration")
652 pp_orig (ArithSeqOrigin seq)
653 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
654 pp_orig (SignatureOrigin)
655 = ptext SLIT("a type signature")
656 pp_orig (Rank2Origin)
657 = ptext SLIT("a function with an overloaded argument type")
659 = ptext SLIT("a do statement")
660 pp_orig (ClassDeclOrigin)
661 = ptext SLIT("a class declaration")
662 pp_orig (InstanceSpecOrigin clas ty)
663 = hsep [text "a SPECIALIZE instance pragma; class",
664 ppr clas, text "type:", ppr ty]
665 pp_orig (ValSpecOrigin name)
666 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr name]
667 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
668 = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel]
669 pp_orig (CCallOrigin clabel (Just arg_expr))
670 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
671 text "namely", quotes (ppr arg_expr)]
672 pp_orig (LitLitOrigin s)
673 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
674 pp_orig (UnknownOrigin)
675 = ptext SLIT("...oops -- I don't know where the overloading came from!")