From df5a41551a807a298e9af6448b8834586617a123 Mon Sep 17 00:00:00 2001 From: sof Date: Sun, 18 May 1997 22:27:51 +0000 Subject: [PATCH] [project @ 1997-05-18 22:26:40 by sof] New PP --- ghc/compiler/typecheck/TcInstUtil.lhs | 28 +++++++++++++++++----------- ghc/compiler/typecheck/TcKind.lhs | 32 ++++++++++++++++---------------- ghc/compiler/typecheck/TcMatches.lhs | 15 ++++++++++----- 3 files changed, 43 insertions(+), 32 deletions(-) diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index e4dd21f..3246e0a 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -24,13 +24,13 @@ import TcEnv ( tcAddImportedIdInfo ) import TcMonad import Inst ( SYN_IE(InstanceMapper) ) -import Bag ( bagToList ) +import Bag ( bagToList, Bag ) import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv), classBigSig, classOps, classOpLocalType, - SYN_IE(ClassOp) + SYN_IE(ClassOp), SYN_IE(Class) ) import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) -import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal ) +import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, SYN_IE(Id) ) import MatchEnv ( nullMEnv, insertMEnv ) import Maybes ( MaybeErr(..), mkLookupFunDef ) import Name ( getSrcLoc, Name{--O only-} ) @@ -39,10 +39,16 @@ import Pretty import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv ) import SrcLoc ( SrcLoc ) import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys, - splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) ) -import TyVar ( GenTyVar ) + instantiateTy, matchTy, SYN_IE(ThetaType), + SYN_IE(Type) ) +import TyVar ( GenTyVar, SYN_IE(TyVar) ) import Unique ( Unique ) -import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-} ) +import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) ) + +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif + --import PprStyle --import TcPragmas ( tcDictFunPragmas, tcGenPragmas ) @@ -229,10 +235,10 @@ addClassInstance dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2) -- Overlapping/duplicate instances for given class; msg could be more glamourous = tcAddErrCtxt ctxt $ - failTc (\sty -> ppPStr SLIT("Duplicate or overlapping instance declarations")) + failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations")) where - ctxt sty = ppHang (ppSep [ppBesides[ppPStr SLIT("Class `"), ppr sty clas, ppChar '\''], - ppBesides[ppPStr SLIT("type `"), ppr sty ty1, ppChar '\'']]) - 4 (ppSep [ppBesides [ppPStr SLIT("at "), ppr sty locn1], - ppBesides [ppPStr SLIT("and "), ppr sty locn2]]) + ctxt sty = hang (sep [ptext SLIT("Class"), ppr sty clas, + ptext SLIT("type"), ppr sty ty1]) + 4 (sep [hcat [ptext SLIT("at "), ppr sty locn1], + hcat [ptext SLIT("and "), ppr sty locn2]]) \end{code} diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index 8dd9e5b..20b0ff1 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -24,6 +24,9 @@ import TcMonad import Unique ( Unique, pprUnique10 ) import Pretty import Util ( nOfThem ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} @@ -179,13 +182,13 @@ instance Outputable (TcKind s) where ppr sty kind = ppr_kind sty kind ppr_kind sty TcTypeKind - = ppChar '*' + = char '*' ppr_kind sty (TcArrowKind kind1 kind2) - = ppSep [ppr_parend sty kind1, ppPStr SLIT("->"), ppr_kind sty kind2] + = sep [ppr_parend sty kind1, ptext SLIT("->"), ppr_kind sty kind2] ppr_kind sty (TcVarKind uniq box) - = ppBesides [ppChar 'k', pprUnique10 uniq] + = hcat [char 'k', pprUnique10 uniq] -ppr_parend sty kind@(TcArrowKind _ _) = ppBesides [ppChar '(', ppr_kind sty kind, ppChar ')'] +ppr_parend sty kind@(TcArrowKind _ _) = hcat [char '(', ppr_kind sty kind, char ')'] ppr_parend sty other_kind = ppr_kind sty other_kind \end{code} @@ -195,20 +198,17 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} unifyKindCtxt kind1 kind2 sty - = ppHang (ppPStr SLIT("When unifying two kinds")) 4 - (ppSep [ppr sty kind1, ppPStr SLIT("and"), ppr sty kind2]) + = hang (ptext SLIT("When unifying two kinds")) 4 + (sep [ppr sty kind1, ptext SLIT("and"), ppr sty kind2]) kindOccurCheck kind1 kind2 sty - = ppHang (ppPStr SLIT("Cannot construct the infinite kind:")) 4 - (ppSep [ppBesides [ppChar '`', ppr sty kind1, ppChar '\''], - ppChar '=', - ppBesides [ppChar '`', ppr sty kind1, ppChar '\''], - ppPStr SLIT("(\"occurs check\")")]) + = hang (ptext SLIT("Cannot construct the infinite kind:")) 4 + (sep [ppr sty kind1, equals, ppr sty kind1, ptext SLIT("(\"occurs check\")")]) kindMisMatchErr kind1 kind2 sty - = ppHang (ppPStr SLIT("Couldn't match the kind")) 4 - (ppSep [ppBesides [ppChar '`', ppr sty kind1, ppChar '\''], - ppPStr SLIT("against"), - ppBesides [ppChar '`', ppr sty kind2, ppChar '\''] - ]) + = hang (ptext SLIT("Couldn't match the kind")) 4 + (sep [ppr sty kind1, + ptext SLIT("against"), + ppr sty kind2] + ) \end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 143f0b4..38a5d16 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -11,7 +11,7 @@ module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where IMP_Ubiq() import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat, - HsExpr, HsBinds, OutPat, Fake, + HsExpr, HsBinds, OutPat, Fake, Stmt, collectPatBinders, pprMatch ) import RnHsSyn ( SYN_IE(RenamedMatch) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) ) @@ -29,6 +29,11 @@ import Kind ( Kind, mkTypeKind ) import Pretty import Type ( isTyVarTy, mkFunTy, getFunTy_maybe ) import Util +import Outputable +#if __GLASGOW_HASKELL__ >= 202 +import SrcLoc (SrcLoc) +#endif + \end{code} @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a @@ -208,16 +213,16 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} matchCtxt MCase match sty - = ppHang (ppPStr SLIT("In a \"case\" branch:")) + = hang (ptext SLIT("In a \"case\" branch:")) 4 (pprMatch sty True{-is_case-} match) matchCtxt (MFun fun) match sty - = ppHang (ppBesides [ppPStr SLIT("In an equation for function "), ppr sty fun, ppChar ':']) - 4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match]) + = hang (hcat [ptext SLIT("In an equation for function "), ppr sty fun, char ':']) + 4 (pprQuote sty $ \sty -> hcat [ppr sty fun, space, pprMatch sty False{-not case-} match]) \end{code} \begin{code} varyingArgsErr name matches sty - = ppSep [ppPStr SLIT("Varying number of arguments for function"), ppr sty name] + = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name] \end{code} -- 1.7.10.4