2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
8 LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
9 plusLIEs, mkLIE, isEmptyLIE,
11 Inst, OverloadedLit(..),
12 pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
16 newDictFromOld, newDicts, newDictsAtLoc,
17 newMethod, newMethodWithGivenTy, newOverloadedLit,
19 tyVarsOfInst, instLoc, getDictClassTys,
21 lookupInst, lookupSimpleInst, LookupInstResult(..),
23 isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor,
24 instBindingRequired, instCanBeGeneralised,
26 zonkInst, instToId, instToIdBndr,
28 InstOrigin(..), pprOrigin
31 #include "HsVersions.h"
33 import HsSyn ( HsLit(..), HsExpr(..) )
34 import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
35 import TcHsSyn ( TcExpr, TcId,
36 mkHsTyApp, mkHsDictApp, zonkId
39 import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
40 import TcType ( TcThetaType,
41 TcType, TcTauType, TcTyVarSet,
42 zonkTcType, zonkTcTypes,
46 import Class ( classInstEnv,
49 import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
50 import VarSet ( elemVarSet )
51 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
52 import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName )
53 import PprType ( pprConstraint )
54 import SpecEnv ( SpecEnv, lookupSpecEnv )
55 import SrcLoc ( SrcLoc )
56 import Type ( Type, ThetaType, substTy,
57 isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
58 splitRhoTy, tyVarsOfType, tyVarsOfTypes,
59 mkSynTy, substTopTy, substTopTheta,
60 tidyOpenType, tidyOpenTypes
62 import TyCon ( TyCon )
63 import VarEnv ( zipVarEnv, lookupVarEnv, TidyEnv )
64 import VarSet ( unionVarSet )
65 import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
66 import TysWiredIn ( intDataCon, isIntTy, inIntRange,
67 floatDataCon, isFloatTy,
68 doubleDataCon, isDoubleTy,
69 integerTy, isIntegerTy
71 import Unique ( fromRationalClassOpKey, rationalTyConKey,
72 fromIntClassOpKey, fromIntegerClassOpKey, Unique
74 import Maybes ( expectJust )
75 import Util ( thenCmp, zipWithEqual, mapAccumL )
79 %************************************************************************
81 \subsection[Inst-collections]{LIE: a collection of Insts}
83 %************************************************************************
88 isEmptyLIE = isEmptyBag
90 unitLIE inst = unitBag inst
91 mkLIE insts = listToBag insts
92 plusLIE lie1 lie2 = lie1 `unionBags` lie2
93 consLIE inst lie = inst `consBag` lie
94 plusLIEs lies = unionManyBags lies
96 zonkLIE :: LIE -> NF_TcM s LIE
97 zonkLIE lie = mapBagNF_Tc zonkInst lie
99 pprInsts :: [Inst] -> SDoc
100 pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
104 = vcat (map go insts)
106 go inst = quotes (ppr inst) <+> pprOrigin inst
109 %************************************************************************
111 \subsection[Inst-types]{@Inst@ types}
113 %************************************************************************
115 An @Inst@ is either a dictionary, an instance of an overloaded
116 literal, or an instance of an overloaded value. We call the latter a
117 ``method'' even though it may not correspond to a class operation.
118 For example, we might have an instance of the @double@ function at
119 type Int, represented by
121 Method 34 doubleId [Int] origin
127 Class -- The type of the dict is (c ts), where
128 [TcType] -- c is the class and ts the types;
135 TcId -- The overloaded function
136 -- This function will be a global, local, or ClassOpId;
137 -- inside instance decls (only) it can also be an InstId!
138 -- The id needn't be completely polymorphic.
139 -- You'll probably find its name (for documentation purposes)
140 -- inside the InstOrigin
142 [TcType] -- The types to which its polymorphic tyvars
143 -- should be instantiated.
144 -- These types must saturate the Id's foralls.
146 TcThetaType -- The (types of the) dictionaries to which the function
147 -- must be applied to get the method
149 TcTauType -- The type of the method
154 -- INVARIANT: in (Method u f tys theta tau loc)
155 -- type of (f tys dicts(from theta)) = tau
160 TcType -- The type at which the literal is used
161 InstOrigin -- Always a literal; but more convenient to carry this around
165 = OverloadedIntegral Integer -- The number
166 | OverloadedFractional Rational -- The number
171 @Insts@ are ordered by their class/type info, rather than by their
172 unique. This allows the context-reduction mechanism to use standard finite
173 maps to do their stuff.
176 instance Ord Inst where
179 instance Eq Inst where
180 (==) i1 i2 = case i1 `cmpInst` i2 of
184 cmpInst (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
185 = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
186 cmpInst (Dict _ _ _ _ _) other
190 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
192 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
193 = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
194 cmpInst (Method _ _ _ _ _ _ _) other
197 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
198 = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
199 cmpInst (LitInst _ _ _ _ _) other
202 cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
203 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
204 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
205 cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT
212 instOrigin (Dict u clas tys origin loc) = origin
213 instOrigin (Method u clas ty _ _ origin loc) = origin
214 instOrigin (LitInst u lit ty origin loc) = origin
216 instLoc (Dict u clas tys origin loc) = loc
217 instLoc (Method u clas ty _ _ origin loc) = loc
218 instLoc (LitInst u lit ty origin loc) = loc
220 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
222 tyVarsOfInst :: Inst -> TcTyVarSet
223 tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys
224 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
225 -- The id might have free type variables; in the case of
226 -- locally-overloaded class methods, for example
227 tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
233 isDict :: Inst -> Bool
234 isDict (Dict _ _ _ _ _) = True
237 isMethodFor :: TcIdSet -> Inst -> Bool
238 isMethodFor ids (Method uniq id tys _ _ orig loc)
239 = id `elemVarSet` ids
243 isTyVarDict :: Inst -> Bool
244 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
245 isTyVarDict other = False
247 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
248 isStdClassTyVarDict other = False
251 Two predicates which deal with the case where class constraints don't
252 necessarily result in bindings. The first tells whether an @Inst@
253 must be witnessed by an actual binding; the second tells whether an
254 @Inst@ can be generalised over.
257 instBindingRequired :: Inst -> Bool
258 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
259 instBindingRequired other = True
261 instCanBeGeneralised :: Inst -> Bool
262 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
263 instCanBeGeneralised other = True
271 newDicts :: InstOrigin
273 -> NF_TcM s (LIE, [TcId])
275 = tcGetSrcLoc `thenNF_Tc` \ loc ->
276 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
277 returnNF_Tc (listToBag dicts, ids)
279 -- Local function, similar to newDicts,
280 -- but with slightly different interface
281 newDictsAtLoc :: InstOrigin
284 -> NF_TcM s ([Inst], [TcId])
285 newDictsAtLoc orig loc theta =
286 tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
288 mk_dict u (clas, tys) = Dict u clas tys orig loc
289 dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
291 returnNF_Tc (dicts, map instToId dicts)
293 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
294 newDictFromOld (Dict _ _ _ orig loc) clas tys
295 = tcGetUnique `thenNF_Tc` \ uniq ->
296 returnNF_Tc (Dict uniq clas tys orig loc)
299 newMethod :: InstOrigin
302 -> NF_TcM s (LIE, TcId)
303 newMethod orig id tys
304 = -- Get the Id type and instantiate it at the specified types
306 (tyvars, rho) = splitForAllTys (idType id)
307 rho_ty = substTy (zipVarEnv tyvars tys) rho
308 (theta, tau) = splitRhoTy rho_ty
310 newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
311 returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
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 meth_inst
322 newMethodAtLoc :: InstOrigin -> SrcLoc
324 -> NF_TcM s (Inst, TcId)
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
328 tcGetUnique `thenNF_Tc` \ new_uniq ->
330 (tyvars,rho) = splitForAllTys (idType real_id)
331 rho_ty = ASSERT( length tyvars == length tys )
332 substTopTy (zipVarEnv tyvars tys) rho
333 (theta, tau) = splitRhoTy rho_ty
334 meth_inst = Method new_uniq real_id tys theta tau orig loc
336 returnNF_Tc (meth_inst, instToId meth_inst)
339 In newOverloadedLit we convert directly to an Int or Integer if we
340 know that's what we want. This may save some time, by not
341 temporarily generating overloaded literals, but it won't catch all
342 cases (the rest are caught in lookupInst).
345 newOverloadedLit :: InstOrigin
348 -> NF_TcM s (TcExpr, LIE)
349 newOverloadedLit orig (OverloadedIntegral i) ty
350 | isIntTy ty && inIntRange i -- Short cut for Int
351 = returnNF_Tc (int_lit, emptyLIE)
353 | isIntegerTy ty -- Short cut for Integer
354 = returnNF_Tc (integer_lit, emptyLIE)
357 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
358 integer_lit = HsLitOut (HsInt i) integerTy
359 int_lit = HsCon intDataCon [] [intprim_lit]
361 newOverloadedLit orig lit ty -- The general case
362 = tcGetSrcLoc `thenNF_Tc` \ loc ->
363 tcGetUnique `thenNF_Tc` \ new_uniq ->
365 lit_inst = LitInst new_uniq lit ty orig loc
367 returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
372 instToId :: Inst -> TcId
373 instToId inst = instToIdBndr inst
375 instToIdBndr :: Inst -> TcId
376 instToIdBndr (Dict u clas ty orig loc)
377 = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
379 instToIdBndr (Method u id tys theta tau orig loc)
380 = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
382 instToIdBndr (LitInst u list ty orig loc)
383 = mkSysLocal SLIT("lit") u ty
389 Zonking makes sure that the instance types are fully zonked,
390 but doesn't do the same for the Id in a Method. There's no
391 need, and it's a lot of extra work.
394 zonkInst :: Inst -> NF_TcM s Inst
395 zonkInst (Dict u clas tys orig loc)
396 = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
397 returnNF_Tc (Dict u clas new_tys orig loc)
399 zonkInst (Method u id tys theta tau orig loc)
400 = zonkId id `thenNF_Tc` \ new_id ->
401 -- Essential to zonk the id in case it's a local variable
402 -- Can't use zonkIdOcc because the id might itself be
403 -- an InstId, in which case it won't be in scope
405 zonkTcTypes tys `thenNF_Tc` \ new_tys ->
406 zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
407 zonkTcType tau `thenNF_Tc` \ new_tau ->
408 returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
410 zonkInst (LitInst u lit ty orig loc)
411 = zonkTcType ty `thenNF_Tc` \ new_ty ->
412 returnNF_Tc (LitInst u lit new_ty orig loc)
418 ToDo: improve these pretty-printing things. The ``origin'' is really only
419 relevant in error messages.
422 instance Outputable Inst where
423 ppr inst = pprInst inst
425 pprInst (LitInst u lit ty orig loc)
427 OverloadedIntegral i -> integer i
428 OverloadedFractional f -> rational f,
433 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
435 pprInst (Method u id tys _ _ orig loc)
436 = hsep [ppr id, ptext SLIT("at"),
437 brackets (interppSP tys),
440 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
441 tidyInst env (LitInst u lit ty orig loc)
442 = (env', LitInst u lit ty' orig loc)
444 (env', ty') = tidyOpenType env ty
446 tidyInst env (Dict u clas tys orig loc)
447 = (env', Dict u clas tys' orig loc)
449 (env', tys') = tidyOpenTypes env tys
451 tidyInst env (Method u id tys theta tau orig loc)
452 = (env', Method u id tys' theta tau orig loc)
453 -- Leave theta, tau alone cos we don't print them
455 (env', tys') = tidyOpenTypes env tys
457 tidyInsts env insts = mapAccumL tidyInst env insts
459 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
463 %************************************************************************
465 \subsection[InstEnv-types]{Type declarations}
467 %************************************************************************
470 type InstanceMapper = Class -> ClassInstEnv
473 A @ClassInstEnv@ lives inside a class, and identifies all the instances
474 of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
477 There is an important consistency constraint between the @MatchEnv@s
478 in and the dfun @Id@s inside them: the free type variables of the
479 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
480 type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
481 contain the following entry:
483 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
485 The "a" in the pattern must be one of the forall'd variables in
489 data LookupInstResult s
491 | SimpleInst TcExpr -- Just a variable, type application, or literal
492 | GenInst [Inst] TcExpr -- The expression and its needed insts
495 -> NF_TcM s (LookupInstResult s)
499 lookupInst dict@(Dict _ clas tys orig loc)
500 = case lookupSpecEnv (ppr clas) (classInstEnv clas) tys of
504 (tyvars, rho) = splitForAllTys (idType dfun_id)
505 ty_args = map (expectJust "Inst" . lookupVarEnv tenv) tyvars
506 -- tenv should bind all the tyvars
507 dfun_rho = substTopTy tenv rho
508 (theta, tau) = splitRhoTy dfun_rho
509 ty_app = mkHsTyApp (HsVar dfun_id) ty_args
512 returnNF_Tc (SimpleInst ty_app)
514 newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
516 rhs = mkHsDictApp ty_app dict_ids
518 returnNF_Tc (GenInst dicts rhs)
520 Nothing -> returnNF_Tc NoInstance
524 lookupInst inst@(Method _ id tys theta _ orig loc)
525 = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
526 returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
530 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
531 | isIntTy ty && in_int_range -- Short cut for Int
532 = returnNF_Tc (GenInst [] int_lit)
533 -- GenInst, not SimpleInst, because int_lit is actually a constructor application
535 | isIntegerTy ty -- Short cut for Integer
536 = returnNF_Tc (GenInst [] integer_lit)
538 | in_int_range -- It's overloaded but small enough to fit into an Int
539 = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
540 newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
541 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
543 | otherwise -- Alas, it is overloaded and a big literal!
544 = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
545 newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
546 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
548 in_int_range = inIntRange i
549 intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
550 integer_lit = HsLitOut (HsInt i) integerTy
551 int_lit = HsCon intDataCon [] [intprim_lit]
553 -- similar idea for overloaded floating point literals: if the literal is
554 -- *definitely* a float or a double, generate the real thing here.
555 -- This is essential (see nofib/spectral/nucleic).
557 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
558 | isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
559 | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
562 = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
564 -- The type Rational isn't wired in so we have to conjure it up
565 tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
567 rational_ty = mkSynTy rational_tycon []
568 rational_lit = HsLitOut (HsFrac f) rational_ty
570 newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
571 returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
574 floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy
575 float_lit = HsCon floatDataCon [] [floatprim_lit]
576 doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
577 double_lit = HsCon doubleDataCon [] [doubleprim_lit]
581 There is a second, simpler interface, when you want an instance of a
582 class at a given nullary type constructor. It just returns the
583 appropriate dictionary if it exists. It is used only when resolving
584 ambiguous dictionaries.
587 lookupSimpleInst :: ClassInstEnv
589 -> [Type] -- Look up (c,t)
590 -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
592 lookupSimpleInst class_inst_env clas tys
593 = case lookupSpecEnv (ppr clas) class_inst_env tys of
594 Nothing -> returnNF_Tc Nothing
597 -> returnNF_Tc (Just (substTopTheta tenv theta))
599 (_, theta, _) = splitSigmaTy (idType dfun)
604 %************************************************************************
606 \subsection[Inst-origin]{The @InstOrigin@ type}
608 %************************************************************************
610 The @InstOrigin@ type gives information about where a dictionary came from.
611 This is important for decent error message reporting because dictionaries
612 don't appear in the original source code. Doubtless this type will evolve...
616 = OccurrenceOf TcId -- Occurrence of an overloaded identifier
617 | OccurrenceOfCon Id -- Occurrence of a data constructor
621 | DataDeclOrigin -- Typechecking a data declaration
623 | InstanceDeclOrigin -- Typechecking an instance decl
625 | LiteralOrigin HsLit -- Occurrence of a literal
627 | PatOrigin RenamedPat
629 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
631 | SignatureOrigin -- A dict created from a type signature
632 | Rank2Origin -- A dict created when typechecking the argument
633 -- of a rank-2 typed function
635 | DoOrigin -- The monad for a do expression
637 | ClassDeclOrigin -- Manufactured during a class decl
639 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
642 -- When specialising instances the instance info attached to
643 -- each class is not yet ready, so we record it inside the
644 -- origin information. This is a bit of a hack, but it works
645 -- fine. (Patrick is to blame [WDP].)
647 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
649 -- Argument or result of a ccall
650 -- Dictionaries with this origin aren't actually mentioned in the
651 -- translated term, and so need not be bound. Nor should they
652 -- be abstracted over.
654 | CCallOrigin String -- CCall label
655 (Maybe RenamedHsExpr) -- Nothing if it's the result
656 -- Just arg, for an argument
658 | LitLitOrigin String -- the litlit
660 | UnknownOrigin -- Help! I give up...
664 pprOrigin :: Inst -> SDoc
666 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
668 (orig, locn) = case inst of
669 Dict _ _ _ orig loc -> (orig,loc)
670 Method _ _ _ _ _ orig loc -> (orig,loc)
671 LitInst _ _ _ orig loc -> (orig,loc)
673 pp_orig (OccurrenceOf id)
674 = hsep [ptext SLIT("use of"), quotes (ppr id)]
675 pp_orig (OccurrenceOfCon id)
676 = hsep [ptext SLIT("use of"), quotes (ppr id)]
677 pp_orig (LiteralOrigin lit)
678 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
679 pp_orig (PatOrigin pat)
680 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
681 pp_orig (InstanceDeclOrigin)
682 = ptext SLIT("an instance declaration")
683 pp_orig (ArithSeqOrigin seq)
684 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr 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 quotes (ppr clas), text "type:", ppr ty]
696 pp_orig (ValSpecOrigin name)
697 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
698 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
699 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
700 pp_orig (CCallOrigin clabel (Just arg_expr))
701 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
702 text "namely", quotes (ppr arg_expr)]
703 pp_orig (LitLitOrigin s)
704 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
705 pp_orig (UnknownOrigin)
706 = ptext SLIT("...oops -- I don't know where the overloading came from!")