X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=af113be0f00fb59100988e866424cae5c27b1ab6;hb=87e57c1ff5df3a5c3d5f67a9805f7300e7932ba3;hp=8582f65e35a5ab6bdcbc1dc6a098a89d5c5afe77;hpb=c4f3290f3d4c2a5c2e81a97717f7fd06ee180f6d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 8582f65..af113be 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -1,14 +1,15 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Inst]{The @Inst@ type: dictionaries or method instances} \begin{code} module Inst ( - LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE, - pprInsts, pprInstsInFull, + LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, + plusLIEs, mkLIE, isEmptyLIE, - Inst, OverloadedLit(..), pprInst, + Inst, OverloadedLit(..), + pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, InstanceMapper, @@ -22,53 +23,56 @@ module Inst ( isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, instBindingRequired, instCanBeGeneralised, - zonkInst, instToId, + zonkInst, instToId, instToIdBndr, InstOrigin(..), pprOrigin ) where #include "HsVersions.h" -import CmdLineOpts ( opt_AllowOverlappingInstances ) -import HsSyn ( HsLit(..), HsExpr(..), MonoBinds ) -import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr ) -import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, - mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId +import HsSyn ( HsLit(..), HsExpr(..) ) +import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat ) +import TcHsSyn ( TcExpr, TcId, + mkHsTyApp, mkHsDictApp, zonkId ) import TcMonad -import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey ) +import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey ) import TcType ( TcThetaType, - TcType, TcTauType, TcMaybe, TcTyVarSet, - tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy, + TcType, TcTauType, TcTyVarSet, + zonkTcType, zonkTcTypes, zonkTcThetaType ) -import Bag ( emptyBag, unitBag, unionBags, unionManyBags, - listToBag, consBag, Bag ) +import Bag import Class ( classInstEnv, Class, ClassInstEnv ) -import MkId ( mkUserLocal, mkSysLocal ) -import Id ( Id, idType, mkId, - GenIdSet, elementOfIdSet - ) +import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) +import VarSet ( elemVarSet ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( OccName(..), Name, occNameString, getOccName ) -import PprType ( TyCon, pprConstraint ) +import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName ) +import PprType ( pprConstraint ) import SpecEnv ( SpecEnv, lookupSpecEnv ) import SrcLoc ( SrcLoc ) -import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy, +import Type ( Type, ThetaType, substTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy, splitRhoTy, tyVarsOfType, tyVarsOfTypes, - mkSynTy + mkSynTy, substTopTy, substTopTheta, + tidyOpenType, tidyOpenTypes ) -import TyVar ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets ) -import TysPrim ( intPrimTy ) -import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange ) +import TyCon ( TyCon ) +import VarEnv ( zipVarEnv, lookupVarEnv, TidyEnv ) +import VarSet ( unionVarSet ) +import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy ) +import TysWiredIn ( intDataCon, isIntTy, inIntRange, + floatDataCon, isFloatTy, + doubleDataCon, isDoubleTy, + integerTy, isIntegerTy + ) import Unique ( fromRationalClassOpKey, rationalTyConKey, fromIntClassOpKey, fromIntegerClassOpKey, Unique ) -import Maybes ( MaybeErr, expectJust ) -import Util ( thenCmp, zipWithEqual ) +import Maybes ( expectJust ) +import Util ( thenCmp, zipWithEqual, mapAccumL ) import Outputable \end{code} @@ -79,8 +83,9 @@ import Outputable %************************************************************************ \begin{code} -type LIE s = Bag (Inst s) +type LIE = Bag Inst +isEmptyLIE = isEmptyBag emptyLIE = emptyBag unitLIE inst = unitBag inst mkLIE insts = listToBag insts @@ -88,10 +93,10 @@ plusLIE lie1 lie2 = lie1 `unionBags` lie2 consLIE inst lie = inst `consBag` lie plusLIEs lies = unionManyBags lies -zonkLIE :: LIE s -> NF_TcM s (LIE s) +zonkLIE :: LIE -> NF_TcM s LIE zonkLIE lie = mapBagNF_Tc zonkInst lie -pprInsts :: [Inst s] -> SDoc +pprInsts :: [Inst] -> SDoc pprInsts insts = parens (hsep (punctuate comma (map pprInst insts))) @@ -116,34 +121,34 @@ type Int, represented by Method 34 doubleId [Int] origin \begin{code} -data Inst s +data Inst = Dict Unique Class -- The type of the dict is (c ts), where - [TcType s] -- c is the class and ts the types; - (InstOrigin s) + [TcType] -- c is the class and ts the types; + InstOrigin SrcLoc | Method Unique - (TcIdOcc s) -- The overloaded function + TcId -- The overloaded function -- This function will be a global, local, or ClassOpId; -- inside instance decls (only) it can also be an InstId! -- The id needn't be completely polymorphic. -- You'll probably find its name (for documentation purposes) -- inside the InstOrigin - [TcType s] -- The types to which its polymorphic tyvars + [TcType] -- The types to which its polymorphic tyvars -- should be instantiated. -- These types must saturate the Id's foralls. - (TcThetaType s) -- The (types of the) dictionaries to which the function + TcThetaType -- The (types of the) dictionaries to which the function -- must be applied to get the method - (TcTauType s) -- The type of the method + TcTauType -- The type of the method - (InstOrigin s) + InstOrigin SrcLoc -- INVARIANT: in (Method u f tys theta tau loc) @@ -152,8 +157,8 @@ data Inst s | LitInst Unique OverloadedLit - (TcType s) -- The type at which the literal is used - (InstOrigin s) -- Always a literal; but more convenient to carry this around + TcType -- The type at which the literal is used + InstOrigin -- Always a literal; but more convenient to carry this around SrcLoc data OverloadedLit @@ -168,10 +173,10 @@ unique. This allows the context-reduction mechanism to use standard finite maps to do their stuff. \begin{code} -instance Ord (Inst s) where +instance Ord Inst where compare = cmpInst -instance Eq (Inst s) where +instance Eq Inst where (==) i1 i2 = case i1 `cmpInst` i2 of EQ -> True other -> False @@ -214,10 +219,10 @@ instLoc (LitInst u lit ty origin loc) = loc getDictClassTys (Dict u clas tys _ _) = (clas, tys) -tyVarsOfInst :: Inst s -> TcTyVarSet s +tyVarsOfInst :: Inst -> TcTyVarSet tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys -tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id - -- The id might not be a RealId; in the case of +tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id + -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty \end{code} @@ -225,17 +230,17 @@ tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty Predicates ~~~~~~~~~~ \begin{code} -isDict :: Inst s -> Bool +isDict :: Inst -> Bool isDict (Dict _ _ _ _ _) = True isDict other = False -isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool -isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc) - = id `elementOfIdSet` ids +isMethodFor :: TcIdSet -> Inst -> Bool +isMethodFor ids (Method uniq id tys _ _ orig loc) + = id `elemVarSet` ids isMethodFor ids inst = False -isTyVarDict :: Inst s -> Bool +isTyVarDict :: Inst -> Bool isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys isTyVarDict other = False @@ -249,11 +254,11 @@ must be witnessed by an actual binding; the second tells whether an @Inst@ can be generalised over. \begin{code} -instBindingRequired :: Inst s -> Bool +instBindingRequired :: Inst -> Bool instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas) instBindingRequired other = True -instCanBeGeneralised :: Inst s -> Bool +instCanBeGeneralised :: Inst -> Bool instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas) instCanBeGeneralised other = True \end{code} @@ -263,9 +268,9 @@ Construction ~~~~~~~~~~~~ \begin{code} -newDicts :: InstOrigin s - -> TcThetaType s - -> NF_TcM s (LIE s, [TcIdOcc s]) +newDicts :: InstOrigin + -> TcThetaType + -> NF_TcM s (LIE, [TcId]) newDicts orig theta = tcGetSrcLoc `thenNF_Tc` \ loc -> newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) -> @@ -273,10 +278,10 @@ newDicts orig theta -- Local function, similar to newDicts, -- but with slightly different interface -newDictsAtLoc :: InstOrigin s +newDictsAtLoc :: InstOrigin -> SrcLoc - -> TcThetaType s - -> NF_TcM s ([Inst s], [TcIdOcc s]) + -> TcThetaType + -> NF_TcM s ([Inst], [TcId]) newDictsAtLoc orig loc theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let @@ -285,32 +290,25 @@ newDictsAtLoc orig loc theta = in returnNF_Tc (dicts, map instToId dicts) -newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s) +newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst newDictFromOld (Dict _ _ _ orig loc) clas tys = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (Dict uniq clas tys orig loc) -newMethod :: InstOrigin s - -> TcIdOcc s - -> [TcType s] - -> NF_TcM s (LIE s, TcIdOcc s) +newMethod :: InstOrigin + -> TcId + -> [TcType] + -> NF_TcM s (LIE, TcId) newMethod orig id tys = -- Get the Id type and instantiate it at the specified types - (case id of - RealId id -> let (tyvars, rho) = splitForAllTys (idType id) - in - ASSERT( length tyvars == length tys) - tcInstType (zipTyVarEnv tyvars tys) rho - - TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) -> - returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho) - ) `thenNF_Tc` \ rho_ty -> let + (tyvars, rho) = splitForAllTys (idType id) + rho_ty = substTy (zipVarEnv tyvars tys) rho (theta, tau) = splitRhoTy rho_ty in - -- Our friend does the rest - newMethodWithGivenTy orig id tys theta tau + newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst -> + returnNF_Tc (unitLIE meth_inst, instToId meth_inst) newMethodWithGivenTy orig id tys theta tau @@ -319,29 +317,35 @@ newMethodWithGivenTy orig id tys theta tau let meth_inst = Method new_uniq id tys theta tau orig loc in - returnNF_Tc (unitLIE meth_inst, instToId meth_inst) + returnNF_Tc meth_inst -newMethodAtLoc :: InstOrigin s -> SrcLoc - -> Id -> [TcType s] - -> NF_TcM s (Inst s, TcIdOcc s) +newMethodAtLoc :: InstOrigin -> SrcLoc + -> Id -> [TcType] + -> NF_TcM s (Inst, TcId) newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with -- slightly different interface = -- Get the Id type and instantiate it at the specified types - let - (tyvars,rho) = splitForAllTys (idType real_id) - in - tcInstType (zipTyVarEnv tyvars tys) rho `thenNF_Tc` \ rho_ty -> tcGetUnique `thenNF_Tc` \ new_uniq -> let - (theta, tau) = splitRhoTy rho_ty - meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc + (tyvars,rho) = splitForAllTys (idType real_id) + rho_ty = ASSERT( length tyvars == length tys ) + substTopTy (zipVarEnv tyvars tys) rho + (theta, tau) = splitRhoTy rho_ty + meth_inst = Method new_uniq real_id tys theta tau orig loc in returnNF_Tc (meth_inst, instToId meth_inst) +\end{code} -newOverloadedLit :: InstOrigin s +In newOverloadedLit we convert directly to an Int or Integer if we +know that's what we want. This may save some time, by not +temporarily generating overloaded literals, but it won't catch all +cases (the rest are caught in lookupInst). + +\begin{code} +newOverloadedLit :: InstOrigin -> OverloadedLit - -> TcType s - -> NF_TcM s (TcExpr s, LIE s) + -> TcType + -> NF_TcM s (TcExpr, LIE) newOverloadedLit orig (OverloadedIntegral i) ty | isIntTy ty && inIntRange i -- Short cut for Int = returnNF_Tc (int_lit, emptyLIE) @@ -352,7 +356,7 @@ newOverloadedLit orig (OverloadedIntegral i) ty where intprim_lit = HsLitOut (HsIntPrim i) intPrimTy integer_lit = HsLitOut (HsInt i) integerTy - int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit + int_lit = HsCon intDataCon [] [intprim_lit] newOverloadedLit orig lit ty -- The general case = tcGetSrcLoc `thenNF_Tc` \ loc -> @@ -365,17 +369,18 @@ newOverloadedLit orig lit ty -- The general case \begin{code} -instToId :: Inst s -> TcIdOcc s -instToId (Dict u clas ty orig loc) - = TcId (mkUserLocal occ u (mkDictTy clas ty) loc) - where - occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas))) +instToId :: Inst -> TcId +instToId inst = instToIdBndr inst + +instToIdBndr :: Inst -> TcId +instToIdBndr (Dict u clas ty orig loc) + = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc -instToId (Method u id tys theta tau orig loc) - = TcId (mkUserLocal (getOccName id) u tau loc) +instToIdBndr (Method u id tys theta tau orig loc) + = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc -instToId (LitInst u list ty orig loc) - = TcId (mkSysLocal SLIT("lit") u ty loc) +instToIdBndr (LitInst u list ty orig loc) + = mkSysLocal SLIT("lit") u ty \end{code} @@ -386,14 +391,17 @@ but doesn't do the same for the Id in a Method. There's no need, and it's a lot of extra work. \begin{code} -zonkInst :: Inst s -> NF_TcM s (Inst s) +zonkInst :: Inst -> NF_TcM s Inst zonkInst (Dict u clas tys orig loc) = zonkTcTypes tys `thenNF_Tc` \ new_tys -> returnNF_Tc (Dict u clas new_tys orig loc) zonkInst (Method u id tys theta tau orig loc) - = zonkTcId id `thenNF_Tc` \ new_id -> - -- Essential to zonk the id in case it's a local variable + = zonkId id `thenNF_Tc` \ new_id -> + -- Essential to zonk the id in case it's a local variable + -- Can't use zonkIdOcc because the id might itself be + -- an InstId, in which case it won't be in scope + zonkTcTypes tys `thenNF_Tc` \ new_tys -> zonkTcThetaType theta `thenNF_Tc` \ new_theta -> zonkTcType tau `thenNF_Tc` \ new_tau -> @@ -411,7 +419,7 @@ ToDo: improve these pretty-printing things. The ``origin'' is really only relevant in error messages. \begin{code} -instance Outputable (Inst s) where +instance Outputable Inst where ppr inst = pprInst inst pprInst (LitInst u lit ty orig loc) @@ -426,9 +434,28 @@ pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u pprInst (Method u id tys _ _ orig loc) = hsep [ppr id, ptext SLIT("at"), - interppSP tys, + brackets (interppSP tys), show_uniq u] +tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst) +tidyInst env (LitInst u lit ty orig loc) + = (env', LitInst u lit ty' orig loc) + where + (env', ty') = tidyOpenType env ty + +tidyInst env (Dict u clas tys orig loc) + = (env', Dict u clas tys' orig loc) + where + (env', tys') = tidyOpenTypes env tys + +tidyInst env (Method u id tys theta tau orig loc) + = (env', Method u id tys' theta tau orig loc) + -- Leave theta, tau alone cos we don't print them + where + (env', tys') = tidyOpenTypes env tys + +tidyInsts env insts = mapAccumL tidyInst env insts + show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") \end{code} @@ -461,9 +488,10 @@ the dfun type. \begin{code} data LookupInstResult s = NoInstance - | SimpleInst (TcExpr s) -- Just a variable, type application, or literal - | GenInst [Inst s] (TcExpr s) -- The expression and its needed insts -lookupInst :: Inst s + | SimpleInst TcExpr -- Just a variable, type application, or literal + | GenInst [Inst] TcExpr -- The expression and its needed insts + +lookupInst :: Inst -> NF_TcM s (LookupInstResult s) -- Dictionaries @@ -474,13 +502,11 @@ lookupInst dict@(Dict _ clas tys orig loc) Just (tenv, dfun_id) -> let (tyvars, rho) = splitForAllTys (idType dfun_id) - ty_args = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars + ty_args = map (expectJust "Inst" . lookupVarEnv tenv) tyvars -- tenv should bind all the tyvars - in - tcInstType tenv rho `thenNF_Tc` \ dfun_rho -> - let - (theta, tau) = splitRhoTy dfun_rho - ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args + dfun_rho = substTopTy tenv rho + (theta, tau) = splitRhoTy dfun_rho + ty_app = mkHsTyApp (HsVar dfun_id) ty_args in if null theta then returnNF_Tc (SimpleInst ty_app) @@ -510,22 +536,30 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc) = returnNF_Tc (GenInst [] integer_lit) | in_int_range -- It's overloaded but small enough to fit into an Int - = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> + = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit)) | otherwise -- Alas, it is overloaded and a big literal! - = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> + = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (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 + int_lit = HsCon intDataCon [] [intprim_lit] + +-- similar idea for overloaded floating point literals: if the literal is +-- *definitely* a float or a double, generate the real thing here. +-- This is essential (see nofib/spectral/nucleic). lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc) - = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> + | isFloatTy ty = returnNF_Tc (GenInst [] float_lit) + | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) + + | otherwise + = tcLookupValueByKey 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 -> @@ -535,6 +569,13 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc) in newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) + + where + floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy + float_lit = HsCon floatDataCon [] [floatprim_lit] + doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy + double_lit = HsCon doubleDataCon [] [doubleprim_lit] + \end{code} There is a second, simpler interface, when you want an instance of a @@ -553,7 +594,7 @@ lookupSimpleInst class_inst_env clas tys Nothing -> returnNF_Tc Nothing Just (tenv, dfun) - -> returnNF_Tc (Just (instantiateThetaTy tenv theta)) + -> returnNF_Tc (Just (substTopTheta tenv theta)) where (_, theta, _) = splitSigmaTy (idType dfun) \end{code} @@ -571,8 +612,8 @@ This is important for decent error message reporting because dictionaries don't appear in the original source code. Doubtless this type will evolve... \begin{code} -data InstOrigin s - = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier +data InstOrigin + = OccurrenceOf TcId -- Occurrence of an overloaded identifier | OccurrenceOfCon Id -- Occurrence of a data constructor | RecordUpdOrigin @@ -583,6 +624,8 @@ data InstOrigin s | LiteralOrigin HsLit -- Occurrence of a literal + | PatOrigin RenamedPat + | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc | SignatureOrigin -- A dict created from a type signature @@ -618,7 +661,7 @@ data InstOrigin s \end{code} \begin{code} -pprOrigin :: Inst s -> SDoc +pprOrigin :: Inst -> SDoc pprOrigin inst = hsep [text "arising from", pp_orig orig, text "at", ppr locn] where @@ -633,6 +676,8 @@ pprOrigin inst = hsep [ptext SLIT("use of"), quotes (ppr id)] pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] + pp_orig (PatOrigin pat) + = hsep [ptext SLIT("the pattern"), quotes (ppr pat)] pp_orig (InstanceDeclOrigin) = ptext SLIT("an instance declaration") pp_orig (ArithSeqOrigin seq)