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 SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
16 SYN_IE(InstanceMapper),
18 newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
20 tyVarsOfInst, lookupInst, lookupSimpleInst,
27 instBindingRequired, instCanBeGeneralised,
33 IMPORT_1_3(Ratio(Rational))
35 import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity, MonoBinds(..),
36 InPat, OutPat, Stmt, DoOrListComp, Match, GRHSsAndBinds,
37 ArithSeqInfo, HsType, Fake )
38 import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
39 import TcHsSyn ( SYN_IE(TcExpr),
40 SYN_IE(TcDictBinds), SYN_IE(TcMonoBinds),
41 mkHsTyApp, mkHsDictApp, tcIdTyVars )
44 import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
45 import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcThetaType), SYN_IE(TcTauType),
46 SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
47 tcInstType, zonkTcType, zonkTcTheta,
48 tcSplitForAllTy, tcSplitRhoTy
50 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList,
51 listToBag, consBag, Bag )
52 import Class ( classInstEnv,
53 SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv)
55 import ErrUtils ( addErrLoc, SYN_IE(Error) )
56 import Id ( GenId, idType, mkUserLocal, mkSysLocal, SYN_IE(Id) )
57 import PrelInfo ( isCcallishClass, isNoDictClass )
58 import MatchEnv ( lookupMEnv, insertMEnv )
59 import Name ( OccName(..), Name, mkLocalName,
60 mkSysLocalName, occNameString, getOccName )
62 import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )
64 import SpecEnv ( SpecEnv )
65 import SrcLoc ( SrcLoc, noSrcLoc )
66 import Type ( GenType, eqSimpleTy, instantiateTy,
67 isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
68 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
71 import TyVar ( unionTyVarSets, GenTyVar )
72 import TysPrim ( intPrimTy )
73 import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
74 import Unique ( fromRationalClassOpKey, rationalTyConKey,
75 fromIntClassOpKey, fromIntegerClassOpKey, Unique
77 import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
78 #if __GLASGOW_HASKELL__ >= 202
83 %************************************************************************
85 \subsection[Inst-collections]{LIE: a collection of Insts}
87 %************************************************************************
90 type LIE s = Bag (Inst s)
93 unitLIE inst = unitBag inst
94 plusLIE lie1 lie2 = lie1 `unionBags` lie2
95 consLIE inst lie = inst `consBag` lie
96 plusLIEs lies = unionManyBags lies
98 zonkLIE :: LIE s -> NF_TcM s (LIE s)
99 zonkLIE lie = mapBagNF_Tc zonkInst lie
101 pprLIE :: PprStyle -> LIE s -> Doc
102 pprLIE sty lie = pprQuote sty $ \ sty ->
103 braces (hsep (punctuate comma (map (pprInst sty) (bagToList lie))))
106 pprLIEInFull sty insts
107 = vcat (map go (bagToList insts))
109 go inst = ppr sty inst <+> pprOrigin sty inst
112 %************************************************************************
114 \subsection[Inst-types]{@Inst@ types}
116 %************************************************************************
118 An @Inst@ is either a dictionary, an instance of an overloaded
119 literal, or an instance of an overloaded value. We call the latter a
120 ``method'' even though it may not correspond to a class operation.
121 For example, we might have an instance of the @double@ function at
122 type Int, represented by
124 Method 34 doubleId [Int] origin
130 Class -- The type of the dict is (c t), where
131 (TcType s) -- c is the class and t the type;
138 (TcIdOcc s) -- The overloaded function
139 -- This function will be a global, local, or ClassOpId;
140 -- inside instance decls (only) it can also be an InstId!
141 -- The id needn't be completely polymorphic.
142 -- You'll probably find its name (for documentation purposes)
143 -- inside the InstOrigin
145 [TcType s] -- The types to which its polymorphic tyvars
146 -- should be instantiated.
147 -- These types must saturate the Id's foralls.
149 (TcThetaType s) -- The (types of the) dictionaries to which the function
150 -- must be applied to get the method
152 (TcTauType s) -- The type of the method
157 -- INVARIANT: in (Method u f tys theta tau loc)
158 -- type of (f tys dicts(from theta)) = tau
163 (TcType s) -- The type at which the literal is used
164 (InstOrigin s) -- Always a literal; but more convenient to carry this around
168 = OverloadedIntegral Integer -- The number
169 | OverloadedFractional Rational -- The number
171 getInstOrigin (Dict u clas ty origin loc) = origin
172 getInstOrigin (Method u fn tys theta tau origin loc) = origin
173 getInstOrigin (LitInst u lit ty origin loc) = origin
180 newDicts :: InstOrigin s
181 -> [(Class, TcType s)]
182 -> NF_TcM s (LIE s, [TcIdOcc s])
184 = tcGetSrcLoc `thenNF_Tc` \ loc ->
185 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
186 returnNF_Tc (listToBag dicts, ids)
188 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
190 mk_dict u (clas, ty) = Dict u clas ty orig loc
191 dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
193 returnNF_Tc (listToBag dicts, map instToId dicts)
196 -- Local function, similar to newDicts,
197 -- but with slightly different interface
198 newDictsAtLoc :: InstOrigin s
200 -> [(Class, TcType s)]
201 -> NF_TcM s ([Inst s], [TcIdOcc s])
202 newDictsAtLoc orig loc theta =
203 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
205 mk_dict u (clas, ty) = Dict u clas ty orig loc
206 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
208 returnNF_Tc (dicts, map instToId dicts)
210 newMethod :: InstOrigin s
213 -> NF_TcM s (LIE s, TcIdOcc s)
214 newMethod orig id tys
215 = -- Get the Id type and instantiate it at the specified types
217 RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
219 tcInstType (zipEqual "newMethod" tyvars tys) rho
221 TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) ->
222 returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
223 ) `thenNF_Tc` \ rho_ty ->
225 (theta, tau) = splitRhoTy rho_ty
227 -- Our friend does the rest
228 newMethodWithGivenTy orig id tys theta tau
231 newMethodWithGivenTy orig id tys theta tau
232 = tcGetSrcLoc `thenNF_Tc` \ loc ->
233 tcGetUnique `thenNF_Tc` \ new_uniq ->
235 meth_inst = Method new_uniq id tys theta tau orig loc
237 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
239 newMethodAtLoc :: InstOrigin s -> SrcLoc
241 -> NF_TcM s (Inst s, TcIdOcc s)
242 newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
243 -- slightly different interface
244 = -- Get the Id type and instantiate it at the specified types
246 (tyvars,rho) = splitForAllTy (idType real_id)
248 tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty ->
249 tcGetUnique `thenNF_Tc` \ new_uniq ->
251 (theta, tau) = splitRhoTy rho_ty
252 meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
254 returnNF_Tc (meth_inst, instToId meth_inst)
256 newOverloadedLit :: InstOrigin s
259 -> NF_TcM s (TcExpr s, LIE s)
260 newOverloadedLit orig (OverloadedIntegral i) ty
261 | isIntTy ty && inIntRange i -- Short cut for Int
262 = returnNF_Tc (int_lit, emptyLIE)
264 | isIntegerTy ty -- Short cut for Integer
265 = returnNF_Tc (integer_lit, emptyLIE)
268 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
269 integer_lit = HsLitOut (HsInt i) integerTy
270 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
272 newOverloadedLit orig lit ty -- The general case
273 = tcGetSrcLoc `thenNF_Tc` \ loc ->
274 tcGetUnique `thenNF_Tc` \ new_uniq ->
276 lit_inst = LitInst new_uniq lit ty orig loc
278 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
283 instToId :: Inst s -> TcIdOcc s
284 instToId (Dict u clas ty orig loc)
285 = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
287 occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
289 instToId (Method u id tys theta tau orig loc)
290 = TcId (mkUserLocal (getOccName id) u tau loc)
292 instToId (LitInst u list ty orig loc)
293 = TcId (mkSysLocal SLIT("lit") u ty loc)
299 Zonking makes sure that the instance types are fully zonked,
300 but doesn't do the same for the Id in a Method. There's no
301 need, and it's a lot of extra work.
304 zonkInst :: Inst s -> NF_TcM s (Inst s)
305 zonkInst (Dict u clas ty orig loc)
306 = zonkTcType ty `thenNF_Tc` \ new_ty ->
307 returnNF_Tc (Dict u clas new_ty orig loc)
309 zonkInst (Method u id tys theta tau orig loc) -- Doesn't zonk the id!
310 = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
311 zonkTcTheta theta `thenNF_Tc` \ new_theta ->
312 zonkTcType tau `thenNF_Tc` \ new_tau ->
313 returnNF_Tc (Method u id new_tys new_theta new_tau orig loc)
315 zonkInst (LitInst u lit ty orig loc)
316 = zonkTcType ty `thenNF_Tc` \ new_ty ->
317 returnNF_Tc (LitInst u lit new_ty orig loc)
322 tyVarsOfInst :: Inst s -> TcTyVarSet s
323 tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
324 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
325 -- The id might not be a RealId; in the case of
326 -- locally-overloaded class methods, for example
327 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
330 @matchesInst@ checks when two @Inst@s are instances of the same
331 thing at the same type, even if their uniques differ.
334 matchesInst :: Inst s -> Inst s -> Bool
336 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
337 = clas1 == clas2 && ty1 `eqSimpleTy` ty2
339 matchesInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
341 && and (zipWith eqSimpleTy tys1 tys2)
342 && length tys1 == length tys2
344 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
345 = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
347 (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2
348 (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
351 matchesInst other1 other2 = False
358 isDict :: Inst s -> Bool
359 isDict (Dict _ _ _ _ _) = True
362 isTyVarDict :: Inst s -> Bool
363 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
364 isTyVarDict other = False
367 Two predicates which deal with the case where class constraints don't
368 necessarily result in bindings. The first tells whether an @Inst@
369 must be witnessed by an actual binding; the second tells whether an
370 @Inst@ can be generalised over.
373 instBindingRequired :: Inst s -> Bool
374 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
375 instBindingRequired other = True
377 instCanBeGeneralised :: Inst s -> Bool
378 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
379 instCanBeGeneralised other = True
385 ToDo: improve these pretty-printing things. The ``origin'' is really only
386 relevant in error messages.
389 instance Outputable (Inst s) where
390 ppr sty inst = pprQuote sty (\ sty -> pprInst sty inst)
392 pprInst sty (LitInst u lit ty orig loc)
394 OverloadedIntegral i -> integer i
395 OverloadedFractional f -> rational f,
400 pprInst sty (Dict u clas ty orig loc)
401 = hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u]
403 pprInst sty (Method u id tys _ _ orig loc)
404 = hsep [ppr sty id, ptext SLIT("at"),
408 show_uniq PprDebug u = ppr PprDebug u
409 show_uniq sty u = empty
412 Printing in error messages. These two must look the same.
415 noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst
417 noSimpleInst clas ty sty
418 = ptext SLIT("No instance for:") <+>
419 (pprQuote sty (\ sty -> ppr sty clas <+> pprParendGenType sty ty))
422 %************************************************************************
424 \subsection[InstEnv-types]{Type declarations}
426 %************************************************************************
429 type InstanceMapper = Class -> ClassInstEnv
432 A @ClassInstEnv@ lives inside a class, and identifies all the instances
433 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
436 There is an important consistency constraint between the @MatchEnv@s
437 in and the dfun @Id@s inside them: the free type variables of the
438 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
439 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
440 contain the following entry:
442 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
444 The "a" in the pattern must be one of the forall'd variables in
450 TcDictBinds s) -- The new binding
454 lookupInst dict@(Dict _ clas ty orig loc)
455 = case lookupMEnv matchTy (get_inst_env clas orig) ty of
456 Nothing -> tcAddSrcLoc loc $
457 tcAddErrCtxt (\sty -> pprOrigin sty dict) $
458 failTc (noInstanceErr dict)
462 (tyvars, rho) = splitForAllTy (idType dfun_id)
463 ty_args = map (assoc "lookupInst" tenv) tyvars
464 -- tenv should bind all the tyvars
466 tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
468 (theta, tau) = splitRhoTy dfun_rho
470 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
472 rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
474 returnTc (dicts, VarMonoBind (instToId dict) rhs)
479 lookupInst inst@(Method _ id tys theta _ orig loc)
480 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
481 returnTc (dicts, VarMonoBind (instToId inst) (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
485 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
486 | isIntTy ty && in_int_range -- Short cut for Int
487 = returnTc ([], VarMonoBind inst_id int_lit)
489 | isIntegerTy ty -- Short cut for Integer
490 = returnTc ([], VarMonoBind inst_id integer_lit)
492 | in_int_range -- It's overloaded but small enough to fit into an Int
493 = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
494 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
495 returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) int_lit))
497 | otherwise -- Alas, it is overloaded and a big literal!
498 = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
499 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
500 returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) integer_lit))
502 in_int_range = inIntRange i
503 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
504 integer_lit = HsLitOut (HsInt i) integerTy
505 int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
506 inst_id = instToId inst
508 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
509 = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
511 -- The type Rational isn't wired in so we have to conjure it up
512 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
514 rational_ty = mkSynTy rational_tycon []
515 rational_lit = HsLitOut (HsFrac f) rational_ty
517 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
518 returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) rational_lit))
521 There is a second, simpler interface, when you want an instance of a
522 class at a given nullary type constructor. It just returns the
523 appropriate dictionary if it exists. It is used only when resolving
524 ambiguous dictionaries.
527 lookupSimpleInst :: ClassInstEnv
529 -> Type -- Look up (c,t)
530 -> TcM s [(Class,Type)] -- Here are the needed (c,t)s
532 lookupSimpleInst class_inst_env clas ty
533 = case (lookupMEnv matchTy class_inst_env ty) of
534 Nothing -> failTc (noSimpleInst clas ty)
535 Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
537 (_, theta, _) = splitSigmaTy (idType dfun)
541 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
542 It does it by filtering the class's @InstEnv@. All pretty shady stuff.
545 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
549 mkInstSpecEnv :: Class -- class
550 -> Type -- instance type
551 -> [TyVarTemplate] -- instance tyvars
552 -> ThetaType -- superclasses dicts
553 -> SpecEnv -- specenv for dfun of instance
555 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
556 = mkSpecEnv (catMaybes (map maybe_spec_info matches))
558 matches = matchMEnv matchTy (classInstEnv clas) inst_ty
560 maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
561 = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
562 maybe_spec_info (_, match_info, _)
569 :: ClassInstEnv -- Incoming envt
570 -> Type -- The instance type: inst_ty
571 -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
572 -- be the same as the forall'd tyvars of the dfun id.
574 ClassInstEnv -- Success
575 (Type, Id) -- Offending overlap
577 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
582 %************************************************************************
584 \subsection[Inst-origin]{The @InstOrigin@ type}
586 %************************************************************************
588 The @InstOrigin@ type gives information about where a dictionary came from.
589 This is important for decent error message reporting because dictionaries
590 don't appear in the original source code. Doubtless this type will evolve...
594 = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
595 | OccurrenceOfCon Id -- Occurrence of a data constructor
599 | DataDeclOrigin -- Typechecking a data declaration
601 | InstanceDeclOrigin -- Typechecking an instance decl
603 | LiteralOrigin HsLit -- Occurrence of a literal
605 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
607 | SignatureOrigin -- A dict created from a type signature
608 | Rank2Origin -- A dict created when typechecking the argument
609 -- of a rank-2 typed function
611 | DoOrigin -- The monad for a do expression
613 | ClassDeclOrigin -- Manufactured during a class decl
616 -- | DerivingOrigin InstanceMapper
620 -- During "deriving" operations we have an ever changing
621 -- mapping of classes to instances, so we record it inside the
622 -- origin information. This is a bit of a hack, but it works
623 -- fine. (Simon is to blame [WDP].)
625 | InstanceSpecOrigin InstanceMapper
626 Class -- in a SPECIALIZE instance pragma
629 -- When specialising instances the instance info attached to
630 -- each class is not yet ready, so we record it inside the
631 -- origin information. This is a bit of a hack, but it works
632 -- fine. (Patrick is to blame [WDP].)
634 -- | DefaultDeclOrigin -- Related to a `default' declaration
636 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
638 -- Argument or result of a ccall
639 -- Dictionaries with this origin aren't actually mentioned in the
640 -- translated term, and so need not be bound. Nor should they
641 -- be abstracted over.
643 | CCallOrigin String -- CCall label
644 (Maybe RenamedHsExpr) -- Nothing if it's the result
645 -- Just arg, for an argument
647 | LitLitOrigin String -- the litlit
649 | UnknownOrigin -- Help! I give up...
653 -- During deriving and instance specialisation operations
654 -- we can't get the instances of the class from inside the
655 -- class, because the latter ain't ready yet. Instead we
656 -- find a mapping from classes to envts inside the dict origin.
658 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
659 -- get_inst_env clas (DerivingOrigin inst_mapper _ _)
660 -- = fst (inst_mapper clas)
661 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
663 get_inst_env clas other_orig = classInstEnv clas
666 pprOrigin :: PprStyle -> Inst s -> Doc
668 = hsep [text "arising from", pp_orig orig, text "at", ppr sty locn]
670 (orig, locn) = case inst of
671 Dict _ _ _ orig loc -> (orig,loc)
672 Method _ _ _ _ _ orig loc -> (orig,loc)
673 LitInst _ _ _ orig loc -> (orig,loc)
675 pp_orig (OccurrenceOf id)
676 = hsep [ptext SLIT("use of"), ppr sty id]
677 pp_orig (OccurrenceOfCon id)
678 = hsep [ptext SLIT("use of"), ppr sty id]
679 pp_orig (LiteralOrigin lit)
680 = hsep [ptext SLIT("the literal"), ppr sty lit]
681 pp_orig (InstanceDeclOrigin)
682 = ptext SLIT("an instance declaration")
683 pp_orig (ArithSeqOrigin seq)
684 = hsep [ptext SLIT("the arithmetic sequence:"), ppr sty seq]
685 pp_orig (SignatureOrigin)
686 = ptext SLIT("a type signature")
687 pp_orig (Rank2Origin)
688 = ptext SLIT("a function with an overloaded argument type")
690 = ptext SLIT("a do statement")
691 pp_orig (ClassDeclOrigin)
692 = ptext SLIT("a class declaration")
693 pp_orig (InstanceSpecOrigin _ clas ty)
694 = hsep [text "a SPECIALIZE instance pragma; class",
695 ppr sty clas, text "type:", ppr sty ty]
696 pp_orig (ValSpecOrigin name)
697 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr sty name]
698 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
699 = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel]
700 pp_orig (CCallOrigin clabel (Just arg_expr))
701 = hsep [ptext SLIT("an argument in the _ccall_ to"), text clabel <> comma, text "namely", ppr sty arg_expr]
702 pp_orig (LitLitOrigin s)
703 = hsep [ptext SLIT("the ``literal-literal''"), text s]
704 pp_orig (UnknownOrigin)
705 = ptext SLIT("...oops -- I don't know where the overloading came from!")