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 CmdLineOpts ( opt_AllowOverlappingInstances )
33 import HsSyn ( HsLit(..), HsExpr(..), MonoBinds )
34 import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr )
35 import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
36 mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
39 import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
40 import TcType ( TcThetaType,
41 TcType, TcTauType, TcMaybe, TcTyVarSet,
42 tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy,
45 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
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, occNameString, getOccName )
55 import PprType ( TyCon, pprConstraint )
56 import SpecEnv ( SpecEnv, lookupSpecEnv )
57 import SrcLoc ( SrcLoc )
58 import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy,
59 isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
60 splitRhoTy, tyVarsOfType, tyVarsOfTypes,
63 import TyVar ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets )
64 import TysPrim ( intPrimTy )
65 import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
66 import Unique ( fromRationalClassOpKey, rationalTyConKey,
67 fromIntClassOpKey, fromIntegerClassOpKey, Unique
69 import Maybes ( MaybeErr, expectJust )
70 import Util ( thenCmp, zipWithEqual )
74 %************************************************************************
76 \subsection[Inst-collections]{LIE: a collection of Insts}
78 %************************************************************************
81 type LIE s = Bag (Inst s)
84 unitLIE inst = unitBag inst
85 mkLIE insts = listToBag insts
86 plusLIE lie1 lie2 = lie1 `unionBags` lie2
87 consLIE inst lie = inst `consBag` lie
88 plusLIEs lies = unionManyBags lies
90 zonkLIE :: LIE s -> NF_TcM s (LIE s)
91 zonkLIE lie = mapBagNF_Tc zonkInst lie
93 pprInsts :: [Inst s] -> SDoc
94 pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
100 go inst = quotes (ppr inst) <+> pprOrigin inst
103 %************************************************************************
105 \subsection[Inst-types]{@Inst@ types}
107 %************************************************************************
109 An @Inst@ is either a dictionary, an instance of an overloaded
110 literal, or an instance of an overloaded value. We call the latter a
111 ``method'' even though it may not correspond to a class operation.
112 For example, we might have an instance of the @double@ function at
113 type Int, represented by
115 Method 34 doubleId [Int] origin
121 Class -- The type of the dict is (c ts), where
122 [TcType s] -- c is the class and ts the types;
129 (TcIdOcc s) -- The overloaded function
130 -- This function will be a global, local, or ClassOpId;
131 -- inside instance decls (only) it can also be an InstId!
132 -- The id needn't be completely polymorphic.
133 -- You'll probably find its name (for documentation purposes)
134 -- inside the InstOrigin
136 [TcType s] -- The types to which its polymorphic tyvars
137 -- should be instantiated.
138 -- These types must saturate the Id's foralls.
140 (TcThetaType s) -- The (types of the) dictionaries to which the function
141 -- must be applied to get the method
143 (TcTauType s) -- The type of the method
148 -- INVARIANT: in (Method u f tys theta tau loc)
149 -- type of (f tys dicts(from theta)) = tau
154 (TcType s) -- The type at which the literal is used
155 (InstOrigin s) -- Always a literal; but more convenient to carry this around
159 = OverloadedIntegral Integer -- The number
160 | OverloadedFractional Rational -- The number
165 @Insts@ are ordered by their class/type info, rather than by their
166 unique. This allows the context-reduction mechanism to use standard finite
167 maps to do their stuff.
170 instance Ord (Inst s) where
173 instance Eq (Inst s) where
174 (==) i1 i2 = case i1 `cmpInst` i2 of
178 cmpInst (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
179 = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
180 cmpInst (Dict _ _ _ _ _) other
184 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
186 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
187 = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
188 cmpInst (Method _ _ _ _ _ _ _) other
191 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
192 = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
193 cmpInst (LitInst _ _ _ _ _) other
196 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
197 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
198 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
199 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
206 instOrigin (Dict u clas tys origin loc) = origin
207 instOrigin (Method u clas ty _ _ origin loc) = origin
208 instOrigin (LitInst u lit ty origin loc) = origin
210 instLoc (Dict u clas tys origin loc) = loc
211 instLoc (Method u clas ty _ _ origin loc) = loc
212 instLoc (LitInst u lit ty origin loc) = loc
214 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
216 tyVarsOfInst :: Inst s -> TcTyVarSet s
217 tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys
218 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
219 -- The id might not be a RealId; in the case of
220 -- locally-overloaded class methods, for example
221 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
227 isDict :: Inst s -> Bool
228 isDict (Dict _ _ _ _ _) = True
231 isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool
232 isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
233 = id `elementOfIdSet` ids
237 isTyVarDict :: Inst s -> Bool
238 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
239 isTyVarDict other = False
241 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
242 isStdClassTyVarDict other = False
245 Two predicates which deal with the case where class constraints don't
246 necessarily result in bindings. The first tells whether an @Inst@
247 must be witnessed by an actual binding; the second tells whether an
248 @Inst@ can be generalised over.
251 instBindingRequired :: Inst s -> Bool
252 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
253 instBindingRequired other = True
255 instCanBeGeneralised :: Inst s -> Bool
256 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
257 instCanBeGeneralised other = True
265 newDicts :: InstOrigin s
267 -> NF_TcM s (LIE s, [TcIdOcc s])
269 = tcGetSrcLoc `thenNF_Tc` \ loc ->
270 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
271 returnNF_Tc (listToBag dicts, ids)
273 -- Local function, similar to newDicts,
274 -- but with slightly different interface
275 newDictsAtLoc :: InstOrigin s
278 -> NF_TcM s ([Inst s], [TcIdOcc s])
279 newDictsAtLoc orig loc theta =
280 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
282 mk_dict u (clas, tys) = Dict u clas tys orig loc
283 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
285 returnNF_Tc (dicts, map instToId dicts)
287 newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s)
288 newDictFromOld (Dict _ _ _ orig loc) clas tys
289 = tcGetUnique `thenNF_Tc` \ uniq ->
290 returnNF_Tc (Dict uniq clas tys orig loc)
293 newMethod :: InstOrigin s
296 -> NF_TcM s (LIE s, TcIdOcc s)
297 newMethod orig id tys
298 = -- Get the Id type and instantiate it at the specified types
300 RealId id -> let (tyvars, rho) = splitForAllTys (idType id)
302 ASSERT( length tyvars == length tys)
303 tcInstType (zipTyVarEnv tyvars tys) rho
305 TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) ->
306 returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho)
307 ) `thenNF_Tc` \ rho_ty ->
309 (theta, tau) = splitRhoTy rho_ty
311 -- Our friend does the rest
312 newMethodWithGivenTy orig id tys theta tau
315 newMethodWithGivenTy orig id tys theta tau
316 = tcGetSrcLoc `thenNF_Tc` \ loc ->
317 tcGetUnique `thenNF_Tc` \ new_uniq ->
319 meth_inst = Method new_uniq id tys theta tau orig loc
321 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
323 newMethodAtLoc :: InstOrigin s -> SrcLoc
325 -> NF_TcM s (Inst s, TcIdOcc s)
326 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
327 -- slightly different interface
328 = -- Get the Id type and instantiate it at the specified types
330 (tyvars,rho) = splitForAllTys (idType real_id)
332 tcInstType (zipTyVarEnv tyvars tys) rho `thenNF_Tc` \ rho_ty ->
333 tcGetUnique `thenNF_Tc` \ new_uniq ->
335 (theta, tau) = splitRhoTy rho_ty
336 meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
338 returnNF_Tc (meth_inst, instToId meth_inst)
340 newOverloadedLit :: InstOrigin s
343 -> NF_TcM s (TcExpr s, LIE s)
344 newOverloadedLit orig (OverloadedIntegral i) ty
345 | isIntTy ty && inIntRange i -- Short cut for Int
346 = returnNF_Tc (int_lit, emptyLIE)
348 | isIntegerTy ty -- Short cut for Integer
349 = returnNF_Tc (integer_lit, emptyLIE)
352 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
353 integer_lit = HsLitOut (HsInt i) integerTy
354 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
356 newOverloadedLit orig lit ty -- The general case
357 = tcGetSrcLoc `thenNF_Tc` \ loc ->
358 tcGetUnique `thenNF_Tc` \ new_uniq ->
360 lit_inst = LitInst new_uniq lit ty orig loc
362 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
367 instToId :: Inst s -> TcIdOcc s
368 instToId (Dict u clas ty orig loc)
369 = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
371 occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
373 instToId (Method u id tys theta tau orig loc)
374 = TcId (mkUserLocal (getOccName id) u tau loc)
376 instToId (LitInst u list ty orig loc)
377 = TcId (mkSysLocal SLIT("lit") u ty loc)
383 Zonking makes sure that the instance types are fully zonked,
384 but doesn't do the same for the Id in a Method. There's no
385 need, and it's a lot of extra work.
388 zonkInst :: Inst s -> NF_TcM s (Inst s)
389 zonkInst (Dict u clas tys orig loc)
390 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
391 returnNF_Tc (Dict u clas new_tys orig loc)
393 zonkInst (Method u id tys theta tau orig loc)
394 = zonkTcId id `thenNF_Tc` \ new_id ->
395 -- Essential to zonk the id in case it's a local variable
396 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
397 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
398 zonkTcType tau `thenNF_Tc` \ new_tau ->
399 returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
401 zonkInst (LitInst u lit ty orig loc)
402 = zonkTcType ty `thenNF_Tc` \ new_ty ->
403 returnNF_Tc (LitInst u lit new_ty orig loc)
409 ToDo: improve these pretty-printing things. The ``origin'' is really only
410 relevant in error messages.
413 instance Outputable (Inst s) where
414 ppr inst = pprInst inst
416 pprInst (LitInst u lit ty orig loc)
418 OverloadedIntegral i -> integer i
419 OverloadedFractional f -> rational f,
424 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
426 pprInst (Method u id tys _ _ orig loc)
427 = hsep [ppr id, ptext SLIT("at"),
431 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
435 %************************************************************************
437 \subsection[InstEnv-types]{Type declarations}
439 %************************************************************************
442 type InstanceMapper = Class -> ClassInstEnv
445 A @ClassInstEnv@ lives inside a class, and identifies all the instances
446 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
449 There is an important consistency constraint between the @MatchEnv@s
450 in and the dfun @Id@s inside them: the free type variables of the
451 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
452 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
453 contain the following entry:
455 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
457 The "a" in the pattern must be one of the forall'd variables in
461 data LookupInstResult s
463 | SimpleInst (TcExpr s) -- Just a variable, type application, or literal
464 | GenInst [Inst s] (TcExpr s) -- The expression and its needed insts
466 -> NF_TcM s (LookupInstResult s)
470 lookupInst dict@(Dict _ clas tys orig loc)
471 = case lookupSpecEnv (classInstEnv clas) tys of
475 (tyvars, rho) = splitForAllTys (idType dfun_id)
476 ty_args = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars
477 -- tenv should bind all the tyvars
479 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
481 (theta, tau) = splitRhoTy dfun_rho
482 ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
485 returnNF_Tc (SimpleInst ty_app)
487 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
489 rhs = mkHsDictApp ty_app dict_ids
491 returnNF_Tc (GenInst dicts rhs)
493 Nothing -> returnNF_Tc NoInstance
497 lookupInst inst@(Method _ id tys theta _ orig loc)
498 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
499 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
503 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
504 | isIntTy ty && in_int_range -- Short cut for Int
505 = returnNF_Tc (GenInst [] int_lit)
506 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
508 | isIntegerTy ty -- Short cut for Integer
509 = returnNF_Tc (GenInst [] integer_lit)
511 | in_int_range -- It's overloaded but small enough to fit into an Int
512 = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
513 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
514 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
516 | otherwise -- Alas, it is overloaded and a big literal!
517 = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
518 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
519 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
521 in_int_range = inIntRange i
522 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
523 integer_lit = HsLitOut (HsInt i) integerTy
524 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
526 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
527 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
529 -- The type Rational isn't wired in so we have to conjure it up
530 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
532 rational_ty = mkSynTy rational_tycon []
533 rational_lit = HsLitOut (HsFrac f) rational_ty
535 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
536 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
539 There is a second, simpler interface, when you want an instance of a
540 class at a given nullary type constructor. It just returns the
541 appropriate dictionary if it exists. It is used only when resolving
542 ambiguous dictionaries.
545 lookupSimpleInst :: ClassInstEnv
547 -> [Type] -- Look up (c,t)
548 -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
550 lookupSimpleInst class_inst_env clas tys
551 = case lookupSpecEnv class_inst_env tys of
552 Nothing -> returnNF_Tc Nothing
555 -> returnNF_Tc (Just (instantiateThetaTy tenv theta))
557 (_, theta, _) = splitSigmaTy (idType dfun)
562 %************************************************************************
564 \subsection[Inst-origin]{The @InstOrigin@ type}
566 %************************************************************************
568 The @InstOrigin@ type gives information about where a dictionary came from.
569 This is important for decent error message reporting because dictionaries
570 don't appear in the original source code. Doubtless this type will evolve...
574 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
575 | OccurrenceOfCon Id -- Occurrence of a data constructor
579 | DataDeclOrigin -- Typechecking a data declaration
581 | InstanceDeclOrigin -- Typechecking an instance decl
583 | LiteralOrigin HsLit -- Occurrence of a literal
585 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
587 | SignatureOrigin -- A dict created from a type signature
588 | Rank2Origin -- A dict created when typechecking the argument
589 -- of a rank-2 typed function
591 | DoOrigin -- The monad for a do expression
593 | ClassDeclOrigin -- Manufactured during a class decl
595 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
598 -- When specialising instances the instance info attached to
599 -- each class is not yet ready, so we record it inside the
600 -- origin information. This is a bit of a hack, but it works
601 -- fine. (Patrick is to blame [WDP].)
603 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
605 -- Argument or result of a ccall
606 -- Dictionaries with this origin aren't actually mentioned in the
607 -- translated term, and so need not be bound. Nor should they
608 -- be abstracted over.
610 | CCallOrigin String -- CCall label
611 (Maybe RenamedHsExpr) -- Nothing if it's the result
612 -- Just arg, for an argument
614 | LitLitOrigin String -- the litlit
616 | UnknownOrigin -- Help! I give up...
620 pprOrigin :: Inst s -> SDoc
622 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
624 (orig, locn) = case inst of
625 Dict _ _ _ orig loc -> (orig,loc)
626 Method _ _ _ _ _ orig loc -> (orig,loc)
627 LitInst _ _ _ orig loc -> (orig,loc)
629 pp_orig (OccurrenceOf id)
630 = hsep [ptext SLIT("use of"), quotes (ppr id)]
631 pp_orig (OccurrenceOfCon id)
632 = hsep [ptext SLIT("use of"), quotes (ppr id)]
633 pp_orig (LiteralOrigin lit)
634 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
635 pp_orig (InstanceDeclOrigin)
636 = ptext SLIT("an instance declaration")
637 pp_orig (ArithSeqOrigin seq)
638 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
639 pp_orig (SignatureOrigin)
640 = ptext SLIT("a type signature")
641 pp_orig (Rank2Origin)
642 = ptext SLIT("a function with an overloaded argument type")
644 = ptext SLIT("a do statement")
645 pp_orig (ClassDeclOrigin)
646 = ptext SLIT("a class declaration")
647 pp_orig (InstanceSpecOrigin clas ty)
648 = hsep [text "a SPECIALIZE instance pragma; class",
649 quotes (ppr clas), text "type:", ppr ty]
650 pp_orig (ValSpecOrigin name)
651 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
652 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
653 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
654 pp_orig (CCallOrigin clabel (Just arg_expr))
655 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
656 text "namely", quotes (ppr arg_expr)]
657 pp_orig (LitLitOrigin s)
658 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
659 pp_orig (UnknownOrigin)
660 = ptext SLIT("...oops -- I don't know where the overloading came from!")