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 mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
38 import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
39 import TcType ( TcThetaType,
40 TcType, TcTauType, TcMaybe, TcTyVarSet,
41 tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy,
44 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
45 listToBag, consBag, Bag )
46 import Class ( classInstEnv,
49 import Id ( idType, mkUserLocal, mkSysLocal, Id,
50 GenIdSet, elementOfIdSet
52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
53 import Name ( OccName(..), Name, occNameString, getOccName )
54 import PprType ( TyCon, pprConstraint )
55 import SpecEnv ( SpecEnv, matchSpecEnv, addToSpecEnv )
56 import SrcLoc ( SrcLoc )
57 import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy, matchTys,
58 isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
59 splitRhoTy, tyVarsOfType, tyVarsOfTypes,
62 import TyVar ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets )
63 import TysPrim ( intPrimTy )
64 import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
65 import Unique ( fromRationalClassOpKey, rationalTyConKey,
66 fromIntClassOpKey, fromIntegerClassOpKey, Unique
68 import Maybes ( MaybeErr, expectJust )
69 import Util ( thenCmp, zipWithEqual )
73 %************************************************************************
75 \subsection[Inst-collections]{LIE: a collection of Insts}
77 %************************************************************************
80 type LIE s = Bag (Inst s)
83 unitLIE inst = unitBag inst
84 mkLIE insts = listToBag insts
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
92 pprInsts :: [Inst s] -> SDoc
93 pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
99 go inst = quotes (ppr inst) <+> pprOrigin inst
102 %************************************************************************
104 \subsection[Inst-types]{@Inst@ types}
106 %************************************************************************
108 An @Inst@ is either a dictionary, an instance of an overloaded
109 literal, or an instance of an overloaded value. We call the latter a
110 ``method'' even though it may not correspond to a class operation.
111 For example, we might have an instance of the @double@ function at
112 type Int, represented by
114 Method 34 doubleId [Int] origin
120 Class -- The type of the dict is (c ts), where
121 [TcType s] -- c is the class and ts the types;
128 (TcIdOcc s) -- The overloaded function
129 -- This function will be a global, local, or ClassOpId;
130 -- inside instance decls (only) it can also be an InstId!
131 -- The id needn't be completely polymorphic.
132 -- You'll probably find its name (for documentation purposes)
133 -- inside the InstOrigin
135 [TcType s] -- The types to which its polymorphic tyvars
136 -- should be instantiated.
137 -- These types must saturate the Id's foralls.
139 (TcThetaType s) -- The (types of the) dictionaries to which the function
140 -- must be applied to get the method
142 (TcTauType s) -- The type of the method
147 -- INVARIANT: in (Method u f tys theta tau loc)
148 -- type of (f tys dicts(from theta)) = tau
153 (TcType s) -- The type at which the literal is used
154 (InstOrigin s) -- Always a literal; but more convenient to carry this around
158 = OverloadedIntegral Integer -- The number
159 | OverloadedFractional Rational -- The number
164 @Insts@ are ordered by their class/type info, rather than by their
165 unique. This allows the context-reduction mechanism to use standard finite
166 maps to do their stuff.
169 instance Ord (Inst s) where
172 instance Eq (Inst s) where
173 (==) i1 i2 = case i1 `cmpInst` i2 of
177 cmpInst (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
178 = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
179 cmpInst (Dict _ _ _ _ _) other
183 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
185 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
186 = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
187 cmpInst (Method _ _ _ _ _ _ _) other
190 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
191 = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
192 cmpInst (LitInst _ _ _ _ _) other
195 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
196 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
197 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
198 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
205 instOrigin (Dict u clas tys origin loc) = origin
206 instOrigin (Method u clas ty _ _ origin loc) = origin
207 instOrigin (LitInst u lit ty origin loc) = origin
209 instLoc (Dict u clas tys origin loc) = loc
210 instLoc (Method u clas ty _ _ origin loc) = loc
211 instLoc (LitInst u lit ty origin loc) = loc
213 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
215 tyVarsOfInst :: Inst s -> TcTyVarSet s
216 tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys
217 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
218 -- The id might not be a RealId; in the case of
219 -- locally-overloaded class methods, for example
220 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
226 isDict :: Inst s -> Bool
227 isDict (Dict _ _ _ _ _) = True
230 isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool
231 isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
232 = id `elementOfIdSet` ids
236 isTyVarDict :: Inst s -> Bool
237 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
238 isTyVarDict other = False
240 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
241 isStdClassTyVarDict other = False
244 Two predicates which deal with the case where class constraints don't
245 necessarily result in bindings. The first tells whether an @Inst@
246 must be witnessed by an actual binding; the second tells whether an
247 @Inst@ can be generalised over.
250 instBindingRequired :: Inst s -> Bool
251 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
252 instBindingRequired other = True
254 instCanBeGeneralised :: Inst s -> Bool
255 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
256 instCanBeGeneralised other = True
264 newDicts :: InstOrigin s
266 -> NF_TcM s (LIE s, [TcIdOcc s])
268 = tcGetSrcLoc `thenNF_Tc` \ loc ->
269 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
270 returnNF_Tc (listToBag dicts, ids)
272 -- Local function, similar to newDicts,
273 -- but with slightly different interface
274 newDictsAtLoc :: InstOrigin s
277 -> NF_TcM s ([Inst s], [TcIdOcc s])
278 newDictsAtLoc orig loc theta =
279 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
281 mk_dict u (clas, tys) = Dict u clas tys orig loc
282 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
284 returnNF_Tc (dicts, map instToId dicts)
286 newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s)
287 newDictFromOld (Dict _ _ _ orig loc) clas tys
288 = tcGetUnique `thenNF_Tc` \ uniq ->
289 returnNF_Tc (Dict uniq clas tys orig loc)
292 newMethod :: InstOrigin s
295 -> NF_TcM s (LIE s, TcIdOcc s)
296 newMethod orig id tys
297 = -- Get the Id type and instantiate it at the specified types
299 RealId id -> let (tyvars, rho) = splitForAllTys (idType id)
301 ASSERT( length tyvars == length tys)
302 tcInstType (zipTyVarEnv tyvars tys) rho
304 TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) ->
305 returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho)
306 ) `thenNF_Tc` \ rho_ty ->
308 (theta, tau) = splitRhoTy rho_ty
310 -- Our friend does the rest
311 newMethodWithGivenTy orig id tys theta tau
314 newMethodWithGivenTy orig id tys theta tau
315 = tcGetSrcLoc `thenNF_Tc` \ loc ->
316 tcGetUnique `thenNF_Tc` \ new_uniq ->
318 meth_inst = Method new_uniq id tys theta tau orig loc
320 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
322 newMethodAtLoc :: InstOrigin s -> SrcLoc
324 -> NF_TcM s (Inst s, TcIdOcc s)
325 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
326 -- slightly different interface
327 = -- Get the Id type and instantiate it at the specified types
329 (tyvars,rho) = splitForAllTys (idType real_id)
331 tcInstType (zipTyVarEnv tyvars tys) rho `thenNF_Tc` \ rho_ty ->
332 tcGetUnique `thenNF_Tc` \ new_uniq ->
334 (theta, tau) = splitRhoTy rho_ty
335 meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
337 returnNF_Tc (meth_inst, instToId meth_inst)
339 newOverloadedLit :: InstOrigin s
342 -> NF_TcM s (TcExpr s, LIE s)
343 newOverloadedLit orig (OverloadedIntegral i) ty
344 | isIntTy ty && inIntRange i -- Short cut for Int
345 = returnNF_Tc (int_lit, emptyLIE)
347 | isIntegerTy ty -- Short cut for Integer
348 = returnNF_Tc (integer_lit, emptyLIE)
351 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
352 integer_lit = HsLitOut (HsInt i) integerTy
353 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
355 newOverloadedLit orig lit ty -- The general case
356 = tcGetSrcLoc `thenNF_Tc` \ loc ->
357 tcGetUnique `thenNF_Tc` \ new_uniq ->
359 lit_inst = LitInst new_uniq lit ty orig loc
361 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
366 instToId :: Inst s -> TcIdOcc s
367 instToId (Dict u clas ty orig loc)
368 = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
370 occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
372 instToId (Method u id tys theta tau orig loc)
373 = TcId (mkUserLocal (getOccName id) u tau loc)
375 instToId (LitInst u list ty orig loc)
376 = TcId (mkSysLocal SLIT("lit") u ty loc)
382 Zonking makes sure that the instance types are fully zonked,
383 but doesn't do the same for the Id in a Method. There's no
384 need, and it's a lot of extra work.
387 zonkInst :: Inst s -> NF_TcM s (Inst s)
388 zonkInst (Dict u clas tys orig loc)
389 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
390 returnNF_Tc (Dict u clas new_tys orig loc)
392 zonkInst (Method u id tys theta tau orig loc)
393 = zonkTcId id `thenNF_Tc` \ new_id ->
394 -- Essential to zonk the id in case it's a local variable
395 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
396 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
397 zonkTcType tau `thenNF_Tc` \ new_tau ->
398 returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
400 zonkInst (LitInst u lit ty orig loc)
401 = zonkTcType ty `thenNF_Tc` \ new_ty ->
402 returnNF_Tc (LitInst u lit new_ty orig loc)
408 ToDo: improve these pretty-printing things. The ``origin'' is really only
409 relevant in error messages.
412 instance Outputable (Inst s) where
413 ppr inst = pprInst inst
415 pprInst (LitInst u lit ty orig loc)
417 OverloadedIntegral i -> integer i
418 OverloadedFractional f -> rational f,
423 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
425 pprInst (Method u id tys _ _ orig loc)
426 = hsep [ppr id, ptext SLIT("at"),
430 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
434 %************************************************************************
436 \subsection[InstEnv-types]{Type declarations}
438 %************************************************************************
441 type InstanceMapper = Class -> ClassInstEnv
444 A @ClassInstEnv@ lives inside a class, and identifies all the instances
445 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
448 There is an important consistency constraint between the @MatchEnv@s
449 in and the dfun @Id@s inside them: the free type variables of the
450 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
451 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
452 contain the following entry:
454 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
456 The "a" in the pattern must be one of the forall'd variables in
460 data LookupInstResult s
462 | SimpleInst (TcExpr s) -- Just a variable, type application, or literal
463 | GenInst [Inst s] (TcExpr s) -- The expression and its needed insts
465 -> NF_TcM s (LookupInstResult s)
469 lookupInst dict@(Dict _ clas tys orig loc)
470 = case matchSpecEnv (classInstEnv clas) tys of
474 (tyvars, rho) = splitForAllTys (idType dfun_id)
475 ty_args = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars
476 -- tenv should bind all the tyvars
478 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
480 (theta, tau) = splitRhoTy dfun_rho
481 ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
484 returnNF_Tc (SimpleInst ty_app)
486 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
488 rhs = mkHsDictApp ty_app dict_ids
490 returnNF_Tc (GenInst dicts rhs)
492 Nothing -> returnNF_Tc NoInstance
496 lookupInst inst@(Method _ id tys theta _ orig loc)
497 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
498 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
502 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
503 | isIntTy ty && in_int_range -- Short cut for Int
504 = returnNF_Tc (GenInst [] int_lit)
505 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
507 | isIntegerTy ty -- Short cut for Integer
508 = returnNF_Tc (GenInst [] integer_lit)
510 | in_int_range -- It's overloaded but small enough to fit into an Int
511 = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
512 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
513 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
515 | otherwise -- Alas, it is overloaded and a big literal!
516 = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
517 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
518 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
520 in_int_range = inIntRange i
521 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
522 integer_lit = HsLitOut (HsInt i) integerTy
523 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
525 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
526 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
528 -- The type Rational isn't wired in so we have to conjure it up
529 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
531 rational_ty = mkSynTy rational_tycon []
532 rational_lit = HsLitOut (HsFrac f) rational_ty
534 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
535 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
538 There is a second, simpler interface, when you want an instance of a
539 class at a given nullary type constructor. It just returns the
540 appropriate dictionary if it exists. It is used only when resolving
541 ambiguous dictionaries.
544 lookupSimpleInst :: ClassInstEnv
546 -> [Type] -- Look up (c,t)
547 -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
549 lookupSimpleInst class_inst_env clas tys
550 = case matchSpecEnv class_inst_env tys of
551 Nothing -> returnNF_Tc Nothing
554 -> returnNF_Tc (Just (instantiateThetaTy tenv theta))
556 (_, theta, _) = splitSigmaTy (idType dfun)
562 :: ClassInstEnv -- Incoming envt
563 -> [Type] -- The instance types: inst_tys
564 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
565 -- be the same as the forall'd tyvars of the dfun id.
567 ClassInstEnv -- Success
568 ([Type], Id) -- Offending overlap
570 addClassInst inst_env inst_tys dfun_id = addToSpecEnv inst_env inst_tys dfun_id
575 %************************************************************************
577 \subsection[Inst-origin]{The @InstOrigin@ type}
579 %************************************************************************
581 The @InstOrigin@ type gives information about where a dictionary came from.
582 This is important for decent error message reporting because dictionaries
583 don't appear in the original source code. Doubtless this type will evolve...
587 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
588 | OccurrenceOfCon Id -- Occurrence of a data constructor
592 | DataDeclOrigin -- Typechecking a data declaration
594 | InstanceDeclOrigin -- Typechecking an instance decl
596 | LiteralOrigin HsLit -- Occurrence of a literal
598 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
600 | SignatureOrigin -- A dict created from a type signature
601 | Rank2Origin -- A dict created when typechecking the argument
602 -- of a rank-2 typed function
604 | DoOrigin -- The monad for a do expression
606 | ClassDeclOrigin -- Manufactured during a class decl
608 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
611 -- When specialising instances the instance info attached to
612 -- each class is not yet ready, so we record it inside the
613 -- origin information. This is a bit of a hack, but it works
614 -- fine. (Patrick is to blame [WDP].)
616 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
618 -- Argument or result of a ccall
619 -- Dictionaries with this origin aren't actually mentioned in the
620 -- translated term, and so need not be bound. Nor should they
621 -- be abstracted over.
623 | CCallOrigin String -- CCall label
624 (Maybe RenamedHsExpr) -- Nothing if it's the result
625 -- Just arg, for an argument
627 | LitLitOrigin String -- the litlit
629 | UnknownOrigin -- Help! I give up...
633 pprOrigin :: Inst s -> SDoc
635 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
637 (orig, locn) = case inst of
638 Dict _ _ _ orig loc -> (orig,loc)
639 Method _ _ _ _ _ orig loc -> (orig,loc)
640 LitInst _ _ _ orig loc -> (orig,loc)
642 pp_orig (OccurrenceOf id)
643 = hsep [ptext SLIT("use of"), quotes (ppr id)]
644 pp_orig (OccurrenceOfCon id)
645 = hsep [ptext SLIT("use of"), quotes (ppr id)]
646 pp_orig (LiteralOrigin lit)
647 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
648 pp_orig (InstanceDeclOrigin)
649 = ptext SLIT("an instance declaration")
650 pp_orig (ArithSeqOrigin seq)
651 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
652 pp_orig (SignatureOrigin)
653 = ptext SLIT("a type signature")
654 pp_orig (Rank2Origin)
655 = ptext SLIT("a function with an overloaded argument type")
657 = ptext SLIT("a do statement")
658 pp_orig (ClassDeclOrigin)
659 = ptext SLIT("a class declaration")
660 pp_orig (InstanceSpecOrigin clas ty)
661 = hsep [text "a SPECIALIZE instance pragma; class",
662 quotes (ppr clas), text "type:", ppr ty]
663 pp_orig (ValSpecOrigin name)
664 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
665 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
666 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
667 pp_orig (CCallOrigin clabel (Just arg_expr))
668 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
669 text "namely", quotes (ppr arg_expr)]
670 pp_orig (LitLitOrigin s)
671 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
672 pp_orig (UnknownOrigin)
673 = ptext SLIT("...oops -- I don't know where the overloading came from!")