X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=67688c014590e4884a04c950c17cf47c4c793ecd;hb=d85022e77941df072eff0a49d8659c016552a30d;hp=b4fc7f2c8046f07d0cf4cbf58d6655613a9b9359;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index b4fc7f2..67688c0 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -10,9 +10,10 @@ module Inst ( Inst(..), -- Visible only to TcSimplify InstOrigin(..), OverloadedLit(..), - LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, + SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, + pprLIE, pprLIEInFull, - InstanceMapper(..), + SYN_IE(InstanceMapper), newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit, @@ -23,45 +24,59 @@ module Inst ( zonkInst, instToId, matchesInst, - instBindingRequired, instCanBeGeneralised - + instBindingRequired, instCanBeGeneralised, + + pprInst ) where -import Ubiq - -import HsSyn ( HsLit(..), HsExpr(..), HsBinds, - InPat, OutPat, Stmt, Qual, Match, - ArithSeqInfo, PolyType, Fake ) -import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) ) -import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..), - mkHsTyApp, mkHsDictApp ) - -import TcMonad hiding ( rnMtoTcM ) -import TcEnv ( tcLookupGlobalValueByKey ) -import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), - tcInstType, zonkTcType ) - -import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) -import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv ) -import Id ( GenId, idType, mkInstId ) +IMP_Ubiq() +IMPORT_1_3(Ratio(Rational)) + +import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity, MonoBinds(..), + InPat, OutPat, Stmt, DoOrListComp, Match, GRHSsAndBinds, + ArithSeqInfo, HsType, Fake ) +import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) ) +import TcHsSyn ( SYN_IE(TcExpr), + SYN_IE(TcDictBinds), SYN_IE(TcMonoBinds), + mkHsTyApp, mkHsDictApp, tcIdTyVars ) + +import TcMonad +import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey ) +import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), + SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet), + tcInstType, zonkTcType, tcSplitForAllTy, tcSplitRhoTy ) + +import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList, + listToBag, consBag, Bag ) +import Class ( classInstEnv, + SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv) + ) +import ErrUtils ( addErrLoc, SYN_IE(Error) ) +import Id ( GenId, idType, mkInstId, SYN_IE(Id) ) +import PrelInfo ( isCcallishClass, isNoDictClass ) import MatchEnv ( lookupMEnv, insertMEnv ) -import Name ( mkLocalName, getLocalName, Name ) +import Name ( OccName(..), Name, mkLocalName, + mkSysLocalName, occNameString, getOccName ) import Outputable -import PprType ( GenClass, TyCon, GenType, GenTyVar ) -import PprStyle ( PprStyle(..) ) +import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType ) import Pretty -import RnHsSyn ( RnName{-instance NamedThing-} ) -import SpecEnv ( SpecEnv(..) ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SpecEnv ( SpecEnv ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Type ( GenType, eqSimpleTy, instantiateTy, isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy, - splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes ) -import TyVar ( GenTyVar ) + splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes, + mkSynTy, SYN_IE(Type) + ) +import TyVar ( unionTyVarSets, GenTyVar ) import TysPrim ( intPrimTy ) -import TysWiredIn ( intDataCon ) -import Unique ( Unique, showUnique, - fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey ) -import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic ) +import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange ) +import Unique ( fromRationalClassOpKey, rationalTyConKey, + fromIntClassOpKey, fromIntegerClassOpKey, Unique + ) +import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} ) +#if __GLASGOW_HASKELL__ >= 202 +import Maybes +#endif \end{code} %************************************************************************ @@ -81,6 +96,16 @@ plusLIEs lies = unionManyBags lies zonkLIE :: LIE s -> NF_TcM s (LIE s) zonkLIE lie = mapBagNF_Tc zonkInst lie + +pprLIE :: PprStyle -> LIE s -> Doc +pprLIE sty lie = pprQuote sty $ \ sty -> + braces (hsep (punctuate comma (map (pprInst sty) (bagToList lie)))) + + +pprLIEInFull sty insts + = vcat (map go (bagToList insts)) + where + go inst = ppr sty inst <+> pprOrigin sty inst \end{code} %************************************************************************ @@ -154,21 +179,30 @@ newDicts :: InstOrigin s -> NF_TcM s (LIE s, [TcIdOcc s]) newDicts orig theta = tcGetSrcLoc `thenNF_Tc` \ loc -> + newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) -> + returnNF_Tc (listToBag dicts, ids) +{- tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let mk_dict u (clas, ty) = Dict u clas ty orig loc dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta in returnNF_Tc (listToBag dicts, map instToId dicts) - -newDictsAtLoc orig loc theta -- Local function, similar to newDicts, - -- but with slightly different interface - = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let - mk_dict u (clas, ty) = Dict u clas ty orig loc - dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta - in - returnNF_Tc (dicts, map instToId dicts) +-} + +-- Local function, similar to newDicts, +-- but with slightly different interface +newDictsAtLoc :: InstOrigin s + -> SrcLoc + -> [(Class, TcType s)] + -> NF_TcM s ([Inst s], [TcIdOcc s]) +newDictsAtLoc orig loc theta = + tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> + let + mk_dict u (clas, ty) = Dict u clas ty orig loc + dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta + in + returnNF_Tc (dicts, map instToId dicts) newMethod :: InstOrigin s -> TcIdOcc s @@ -178,9 +212,11 @@ newMethod orig id tys = -- Get the Id type and instantiate it at the specified types (case id of RealId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstType (zipEqual "newMethod" tyvars tys) rho - TcId id -> let (tyvars, rho) = splitForAllTy (idType id) - in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho) + in + (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $ + tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho + TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) -> + returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho) ) `thenNF_Tc` \ rho_ty -> -- Our friend does the rest newMethodWithGivenTy orig id tys rho_ty @@ -211,14 +247,26 @@ newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but newOverloadedLit :: InstOrigin s -> OverloadedLit -> TcType s - -> NF_TcM s (LIE s, TcIdOcc s) -newOverloadedLit orig lit ty + -> NF_TcM s (TcExpr s, LIE s) +newOverloadedLit orig (OverloadedIntegral i) ty + | isIntTy ty && inIntRange i -- Short cut for Int + = returnNF_Tc (int_lit, emptyLIE) + + | isIntegerTy ty -- Short cut for Integer + = returnNF_Tc (integer_lit, emptyLIE) + + where + intprim_lit = HsLitOut (HsIntPrim i) intPrimTy + integer_lit = HsLitOut (HsInt i) integerTy + int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit + +newOverloadedLit orig lit ty -- The general case = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUnique `thenNF_Tc` \ new_uniq -> let lit_inst = LitInst new_uniq lit ty orig loc in - returnNF_Tc (unitLIE lit_inst, instToId lit_inst) + returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst) \end{code} @@ -227,15 +275,18 @@ instToId :: Inst s -> TcIdOcc s instToId (Dict u clas ty orig loc) = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc)) where - str = SLIT("d.") _APPEND_ (getLocalName clas) + str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas))) + instToId (Method u id tys rho_ty orig loc) - = TcId (mkInstId u tau_ty (mkLocalName u str loc)) + = TcId (mkInstId u tau_ty (mkLocalName u occ loc)) where - (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type - str = SLIT("m.") _APPEND_ (getLocalName id) - + occ = getOccName id + (_, tau_ty) = splitRhoTy rho_ty + -- I hope we don't need tcSplitRhoTy... + -- NB The method Id has just the tau type + instToId (LitInst u list ty orig loc) - = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc)) + = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc)) \end{code} \begin{code} @@ -272,7 +323,9 @@ zonkInst (LitInst u lit ty orig loc) \begin{code} tyVarsOfInst :: Inst s -> TcTyVarSet s tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty -tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys +tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id + -- The id might not be a RealId; in the case of + -- locally-overloaded class methods, for example tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty \end{code} @@ -320,19 +373,12 @@ must be witnessed by an actual binding; the second tells whether an \begin{code} instBindingRequired :: Inst s -> Bool -instBindingRequired inst - = case getInstOrigin inst of - CCallOrigin _ _ -> False -- No binding required - LitLitOrigin _ -> False - OccurrenceOfCon _ -> False - other -> True +instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas) +instBindingRequired other = True instCanBeGeneralised :: Inst s -> Bool -instCanBeGeneralised inst - = case getInstOrigin inst of - CCallOrigin _ _ -> False -- Can't be generalised - LitLitOrigin _ -> False -- Can't be generalised - other -> True +instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas) +instCanBeGeneralised other = True \end{code} @@ -343,38 +389,36 @@ relevant in error messages. \begin{code} instance Outputable (Inst s) where - ppr sty (LitInst uniq lit ty orig loc) - = ppSep [case lit of - OverloadedIntegral i -> ppInteger i - OverloadedFractional f -> ppRational f, - ppStr "at", - ppr sty ty, - show_uniq sty uniq - ] - - ppr sty (Dict uniq clas ty orig loc) - = ppSep [ppr sty clas, - ppStr "at", - ppr sty ty, - show_uniq sty uniq - ] - - ppr sty (Method uniq id tys rho orig loc) - = ppSep [ppr sty id, - ppStr "at", - ppr sty tys, - show_uniq sty uniq - ] - -show_uniq PprDebug uniq = ppr PprDebug uniq -show_uniq sty uniq = ppNil - + ppr sty inst = pprQuote sty (\ sty -> pprInst sty inst) + +pprInst sty (LitInst u lit ty orig loc) + = hsep [case lit of + OverloadedIntegral i -> integer i + OverloadedFractional f -> rational f, + ptext SLIT("at"), + ppr sty ty, + show_uniq sty u] + +pprInst sty (Dict u clas ty orig loc) + = hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u] + +pprInst sty (Method u id tys rho orig loc) + = hsep [ppr sty id, ptext SLIT("at"), + interppSP sty tys, + show_uniq sty u] + +show_uniq PprDebug u = ppr PprDebug u +show_uniq sty u = empty \end{code} -Printing in error messages +Printing in error messages. These two must look the same. \begin{code} -noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst) +noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst + +noSimpleInst clas ty sty + = ptext SLIT("No instance for:") <+> + (pprQuote sty (\ sty -> ppr sty clas <+> pprParendGenType sty ty)) \end{code} %************************************************************************ @@ -384,7 +428,7 @@ noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty ins %************************************************************************ \begin{code} -type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv) +type InstanceMapper = Class -> ClassInstEnv \end{code} A @ClassInstEnv@ lives inside a class, and identifies all the instances @@ -405,14 +449,14 @@ the dfun type. \begin{code} lookupInst :: Inst s -> TcM s ([Inst s], - (TcIdOcc s, TcExpr s)) -- The new binding + TcDictBinds s) -- The new binding -- Dictionaries lookupInst dict@(Dict _ clas ty orig loc) = case lookupMEnv matchTy (get_inst_env clas orig) ty of Nothing -> tcAddSrcLoc loc $ - tcAddErrCtxt (pprOrigin orig) $ + tcAddErrCtxt (\sty -> pprOrigin sty dict) $ failTc (noInstanceErr dict) Just (dfun_id, tenv) @@ -429,39 +473,52 @@ lookupInst dict@(Dict _ clas ty orig loc) let rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids in - returnTc (dicts, (instToId dict, rhs)) + returnTc (dicts, VarMonoBind (instToId dict) rhs) -- Methods lookupInst inst@(Method _ id tys rho orig loc) - = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) -> - returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids)) - where - (theta,_) = splitRhoTy rho + = tcSplitRhoTy rho `thenNF_Tc` \ (theta, _) -> + newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) -> + returnTc (dicts, VarMonoBind (instToId inst) (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids)) -- Literals lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc) - | i >= toInteger minInt && i <= toInteger maxInt - = -- It's overloaded but small enough to fit into an Int - tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> - newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit)) - - | otherwise - = -- Alas, it is overloaded and a big literal! - tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> + | isIntTy ty && in_int_range -- Short cut for Int + = returnTc ([], VarMonoBind inst_id int_lit) + + | isIntegerTy ty -- Short cut for Integer + = returnTc ([], VarMonoBind inst_id integer_lit) + + | in_int_range -- It's overloaded but small enough to fit into an Int + = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> + newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> + returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) int_lit)) + + | otherwise -- Alas, it is overloaded and a big literal! + = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty))) + returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) integer_lit)) where + in_int_range = inIntRange i intprim_lit = HsLitOut (HsIntPrim i) intPrimTy + integer_lit = HsLitOut (HsInt i) integerTy int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit + inst_id = instToId inst lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc) = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> + + -- The type Rational isn't wired in so we have to conjure it up + tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> + let + rational_ty = mkSynTy rational_tycon [] + rational_lit = HsLitOut (HsFrac f) rational_ty + in newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty))) + returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) rational_lit)) \end{code} There is a second, simpler interface, when you want an instance of a @@ -481,10 +538,6 @@ lookupSimpleInst class_inst_env clas ty Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta] where (_, theta, _) = splitSigmaTy (idType dfun) - -noSimpleInst clas ty sty - = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas), - ppStr "at type", ppQuote (ppr sty ty)] \end{code} @@ -555,6 +608,8 @@ data InstOrigin s | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc | SignatureOrigin -- A dict created from a type signature + | Rank2Origin -- A dict created when typechecking the argument + -- of a rank-2 typed function | DoOrigin -- The monad for a do expression @@ -607,55 +662,48 @@ get_inst_env :: Class -> InstOrigin s -> ClassInstEnv -- get_inst_env clas (DerivingOrigin inst_mapper _ _) -- = fst (inst_mapper clas) get_inst_env clas (InstanceSpecOrigin inst_mapper _ _) - = fst (inst_mapper clas) + = inst_mapper clas get_inst_env clas other_orig = classInstEnv clas -pprOrigin :: InstOrigin s -> PprStyle -> Pretty - -pprOrigin (OccurrenceOf id) sty - = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"), - ppr sty id, ppChar '\''] -pprOrigin (OccurrenceOfCon id) sty - = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"), - ppr sty id, ppChar '\''] -pprOrigin (InstanceDeclOrigin) sty - = ppStr "in an instance declaration" -pprOrigin (LiteralOrigin lit) sty - = ppCat [ppStr "at an overloaded literal:", ppr sty lit] -pprOrigin (ArithSeqOrigin seq) sty - = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq] -pprOrigin (SignatureOrigin) sty - = ppStr "in a type signature" -pprOrigin (DoOrigin) sty - = ppStr "in a do statement" -pprOrigin (ClassDeclOrigin) sty - = ppStr "in a class declaration" --- pprOrigin (DerivingOrigin _ clas tycon) sty --- = ppBesides [ppStr "in a `deriving' clause; class `", --- ppr sty clas, --- ppStr "'; offending type `", --- ppr sty tycon, --- ppStr "'"] -pprOrigin (InstanceSpecOrigin _ clas ty) sty - = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", - ppr sty clas, ppStr "\" type: ", ppr sty ty] --- pprOrigin (DefaultDeclOrigin) sty --- = ppStr "in a `default' declaration" -pprOrigin (ValSpecOrigin name) sty - = ppBesides [ppStr "in a SPECIALIZE user-pragma for `", - ppr sty name, ppStr "'"] -pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty - = ppBesides [ppStr "in the result of the _ccall_ to `", - ppStr clabel, ppStr "'"] -pprOrigin (CCallOrigin clabel (Just arg_expr)) sty - = ppBesides [ppStr "in an argument in the _ccall_ to `", - ppStr clabel, ppStr "', namely: ", ppr sty arg_expr] -pprOrigin (LitLitOrigin s) sty - = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s] -pprOrigin UnknownOrigin sty - = ppStr "in... oops -- I don't know where the overloading came from!" +pprOrigin :: PprStyle -> Inst s -> Doc +pprOrigin sty inst + = hsep [text "arising from", pp_orig orig, text "at", ppr sty locn] + where + (orig, locn) = case inst of + Dict _ _ _ orig loc -> (orig,loc) + Method _ _ _ _ orig loc -> (orig,loc) + LitInst _ _ _ orig loc -> (orig,loc) + + pp_orig (OccurrenceOf id) + = hsep [ptext SLIT("use of"), ppr sty id] + pp_orig (OccurrenceOfCon id) + = hsep [ptext SLIT("use of"), ppr sty id] + pp_orig (LiteralOrigin lit) + = hsep [ptext SLIT("the literal"), ppr sty lit] + pp_orig (InstanceDeclOrigin) + = ptext SLIT("an instance declaration") + pp_orig (ArithSeqOrigin seq) + = hsep [ptext SLIT("the arithmetic sequence:"), ppr sty seq] + pp_orig (SignatureOrigin) + = ptext SLIT("a type signature") + pp_orig (Rank2Origin) + = ptext SLIT("a function with an overloaded argument type") + pp_orig (DoOrigin) + = ptext SLIT("a do statement") + pp_orig (ClassDeclOrigin) + = ptext SLIT("a class declaration") + pp_orig (InstanceSpecOrigin _ clas ty) + = hsep [text "a SPECIALIZE instance pragma; class", + ppr sty clas, text "type:", ppr sty ty] + pp_orig (ValSpecOrigin name) + = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr sty name] + pp_orig (CCallOrigin clabel Nothing{-ccall result-}) + = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel] + pp_orig (CCallOrigin clabel (Just arg_expr)) + = hsep [ptext SLIT("an argument in the _ccall_ to"), text clabel <> comma, text "namely", ppr sty arg_expr] + pp_orig (LitLitOrigin s) + = hsep [ptext SLIT("the ``literal-literal''"), text s] + pp_orig (UnknownOrigin) + = ptext SLIT("...oops -- I don't know where the overloading came from!") \end{code} - - -