From e21f3023b095d9bbd000330b56aaaa2977134335 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Mon, 13 Apr 2020 16:29:44 +0300 Subject: Use Semigroup's (<>) for Doc/SDoc Before this patch, Outputable.hs defined its own (<>) which caused conflicts with (Data.Semigroup.<>) and thus led to inconvenience. However, replacing it is not trivial due to a different fixity: http://www.haskell.org/pipermail/libraries/2011-November/017066.html Nevertheless, it is possible to update the pretty-printing code to work with (<>) of a different fixitiy, and that's what this patch implements. Now Doc and SDoc are instances of Semigroup. --- compiler/GHC/CmmToAsm/PPC/RegInfo.hs | 2 +- compiler/GHC/Driver/Plugins.hs | 4 ---- compiler/GHC/Hs/Doc.hs | 6 +++--- compiler/GHC/HsToCore/Docs.hs | 1 - compiler/GHC/HsToCore/PmCheck/Oracle.hs | 1 - compiler/GHC/HsToCore/PmCheck/Types.hs | 1 - compiler/GHC/Iface/Ext/Types.hs | 10 ++++------ compiler/GHC/Iface/Recomp.hs | 4 ---- compiler/GHC/Parser/PostProcess.hs | 4 ++-- compiler/GHC/Rename/Module.hs | 2 +- compiler/GHC/Rename/Names.hs | 4 ++-- compiler/GHC/Rename/Utils.hs | 2 +- compiler/GHC/SysTools/Ar.hs | 1 - compiler/GHC/Tc/Errors.hs | 20 ++++++++++---------- compiler/GHC/Tc/Errors/Hole.hs | 2 +- compiler/GHC/Tc/Errors/Hole/FitTypes.hs | 2 +- compiler/GHC/Tc/Gen/Annotation.hs | 2 +- compiler/GHC/Tc/Gen/Expr.hs | 4 ++-- compiler/GHC/Tc/Gen/Pat.hs | 2 +- compiler/GHC/Tc/Instance/Family.hs | 4 ++-- compiler/GHC/Tc/Instance/FunDeps.hs | 6 +++--- compiler/GHC/Tc/Solver.hs | 4 ++-- compiler/GHC/Tc/TyCl/PatSyn.hs | 6 +++--- compiler/GHC/Tc/Types/Origin.hs | 4 ++-- compiler/GHC/Tc/Utils/TcMType.hs | 2 +- compiler/GHC/Tc/Validity.hs | 6 +++--- compiler/GHC/Types/Basic.hs | 2 +- compiler/GHC/Types/Unique/FM.hs | 8 ++++---- compiler/GHC/Types/Var/Set.hs | 4 ++-- compiler/utils/GhcPrelude.hs | 6 +----- compiler/utils/Outputable.hs | 23 ++++++++++++++--------- compiler/utils/Pretty.hs | 11 +++-------- ghc/GHCi/UI.hs | 2 +- ghc/GHCi/UI/Info.hs | 2 +- ghc/GHCi/UI/Monad.hs | 2 +- ghc/Main.hs | 2 +- 36 files changed, 75 insertions(+), 93 deletions(-) diff --git a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs index 58e3f44ece..59a0fd083b 100644 --- a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs @@ -28,7 +28,7 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Types.Unique -import Outputable (ppr, text, Outputable, (<>)) +import Outputable (ppr, text, Outputable) data JumpDest = DestBlockId BlockId diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index d9e29d451b..972a9fd89a 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -63,10 +63,6 @@ import Fingerprint import Data.List (sort) import Outputable (Outputable(..), text, (<+>)) ---Qualified import so we can define a Semigroup instance --- but it doesn't clash with Outputable.<> -import qualified Data.Semigroup - import Control.Monad -- | Command line options gathered from the -PModule.Name:stuff syntax diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 7da56b1524..104ce57015 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -126,7 +126,7 @@ instance Binary DeclDocMap where instance Outputable DeclDocMap where ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) where - pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) + pprPair (name, doc) = ppr name <> colon $$ nest 2 (ppr doc) emptyDeclDocMap :: DeclDocMap emptyDeclDocMap = DeclDocMap Map.empty @@ -144,9 +144,9 @@ instance Outputable ArgDocMap where ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) where pprPair (name, int_map) = - ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) + ppr name <> colon $$ nest 2 (pprIntMap int_map) pprIntMap im = vcat (map pprIPair (Map.toAscList im)) - pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) + pprIPair (i, doc) = ppr i <> colon $$ nest 2 (ppr doc) emptyArgDocMap :: ArgDocMap emptyArgDocMap = ArgDocMap Map.empty diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 48a8ef6f20..42901e4b59 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -26,7 +26,6 @@ import Data.Bifunctor (first) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe -import Data.Semigroup -- | Extract docs from renamer output. extractDocs :: TcGblEnv diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index 63cc4710dd..c1cde37d7b 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -78,7 +78,6 @@ import Data.Foldable (foldlM, minimumBy, toList) import Data.List (find) import qualified Data.List.NonEmpty as NonEmpty import Data.Ord (comparing) -import qualified Data.Semigroup as Semigroup import Data.Tuple (swap) -- Debugging Infrastructure diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs index 60ed0ce356..e4f01a56a0 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -70,7 +70,6 @@ import Numeric (fromRat) import Data.Foldable (find) import qualified Data.List.NonEmpty as NonEmpty import Data.Ratio -import qualified Data.Semigroup as Semi -- | Literals (simple and overloaded ones) for pattern match checking. -- diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index edd6540e80..a859188257 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -20,17 +20,15 @@ import FastString ( FastString ) import GHC.Iface.Type import GHC.Types.Module ( ModuleName, Module ) import GHC.Types.Name ( Name ) -import Outputable hiding ( (<>) ) +import Outputable import GHC.Types.SrcLoc ( RealSrcSpan ) import GHC.Types.Avail -import qualified Outputable as O ( (<>) ) import qualified Data.Array as A import qualified Data.Map as M import qualified Data.Set as S import Data.ByteString ( ByteString ) import Data.Data ( Typeable, Data ) -import Data.Semigroup ( Semigroup(..) ) import Data.Word ( Word8 ) import Control.Applicative ( (<|>) ) @@ -217,7 +215,7 @@ instance Outputable a => Outputable (HieASTs a) where ppr (HieASTs asts) = M.foldrWithKey go "" asts where go k a rest = vcat $ - [ "File: " O.<> ppr k + [ "File: " <> ppr k , ppr a , rest ] @@ -244,7 +242,7 @@ instance Binary (HieAST TypeIndex) where instance Outputable a => Outputable (HieAST a) where ppr (Node ni sp ch) = hang header 2 rest where - header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni + header = text "Node@" <> ppr sp <> ":" <+> ppr ni rest = vcat (map ppr ch) -- | The information stored in one AST node. @@ -569,7 +567,7 @@ instance Outputable TyVarScope where ppr (ResolvedScopes xs) = text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs) ppr (UnresolvedScope ns sp) = - text "unresolved type variable scope for name" O.<> plural ns + text "unresolved type variable scope for" <+> plural "name" ns <+> pprBindSpan sp instance Binary TyVarScope where diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 57809a6d59..a1f7e6d0ee 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -49,10 +49,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins ) ---Qualified import so we can define a Semigroup instance --- but it doesn't clash with Outputable.<> -import qualified Data.Semigroup - {- ----------------------------------------------- Recompilation checking diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 7ce2f4fb9a..47fa0df602 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1261,8 +1261,8 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | otherwise = return () where pprOptSemi True = semi pprOptSemi False = empty - expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> - text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> + expr = text "if" <+> (ppr guardExpr <> pprOptSemi semiThen) <+> + text "then" <+> (ppr thenExpr <> pprOptSemi semiElse) <+> text "else" <+> ppr elseExpr isFunLhs :: Located (PatBuilder GhcPs) diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index bc2c7d3d5d..8ac2d1a485 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1987,7 +1987,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid ; addErrAt srcSpan $ ( hsep - [ text "Unknown type variable" <> plural errorVars + [ text "Unknown type" <+> plural "variable" errorVars , text "on the RHS of injectivity condition:" , interpp'SP errorVars ] ) } diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index ed08087899..1fe8522040 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1701,8 +1701,8 @@ badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc badImportItemErrDataCon dataType_occ iface decl_spec ie = vcat [ text "In module" - <+> quotes (ppr (is_mod decl_spec)) - <+> source_import <> colon + <+> (quotes (ppr (is_mod decl_spec)) <+> source_import) + <> colon , nest 2 $ quotes datacon <+> text "is a data constructor of" <+> quotes dataType diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3c4f5d065f..b7811b9987 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -408,7 +408,7 @@ addNameClashErrRn rdr_name gres shadowedNameWarn :: OccName -> [SDoc] -> SDoc shadowedNameWarn occ shadowed_locs = sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, + <+> text "shadows the existing" <+> plural "binding" shadowed_locs, nest 2 (vcat shadowed_locs)] diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs index 200b652049..8c2fdb88f9 100644 --- a/compiler/GHC/SysTools/Ar.hs +++ b/compiler/GHC/SysTools/Ar.hs @@ -35,7 +35,6 @@ module GHC.SysTools.Ar import GhcPrelude import Data.List (mapAccumL, isPrefixOf) -import Data.Monoid ((<>)) import Data.Binary.Get import Data.Binary.Put import Control.Monad diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index ae08f78443..be6524d1ba 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -477,7 +477,7 @@ warnRedundantConstraints ctxt env info ev_vars = do { msg <- mkErrorReport ctxt env (important doc) ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } where - doc = text "Redundant constraint" <> plural redundant_evs <> colon + doc = text "Redundant" <+> plural "constraint" redundant_evs <> colon <+> pprEvVarTheta redundant_evs redundant_evs = @@ -1249,7 +1249,7 @@ mkIPErr ctxt cts givens = getUserGivens ctxt msg | null givens = addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts + sep [ text "Unbound implicit" <+> plural "parameter" cts , nest 2 (pprParendTheta preds) ] | otherwise = couldNotDeduce givens (preds, orig) @@ -1552,7 +1552,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + esc_doc = sep [ text "because" <+> what <+> plural "variable" esc_skols <+> pprQuotedList esc_skols , text "would escape" <+> if isSingleton esc_skols then text "its scope" @@ -2361,7 +2361,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over = vcat [ ppWhen lead_with_ambig $ text "Probable fix: use a type annotation to specify what" <+> pprQuotedList ambig_tvs <+> text "should be." - , text "These potential instance" <> plural unifiers + , text "These potential" <+> plural "instance" unifiers <+> text "exist:"] mb_patsyn_prov :: Maybe SDoc @@ -2737,8 +2737,8 @@ mkAmbigMsg prepend_msg ct msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs + = vcat [ text "Cannot resolve unknown runtime" + <+> plural "type" ambig_tvs <+> pprQuotedList ambig_tvs , text "Use :print or :force to determine these types"] | not (null ambig_tvs) @@ -2749,11 +2749,11 @@ mkAmbigMsg prepend_msg ct pp_ambig what tkvs | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs + = text "Ambiguous" <+> what <+> plural "variable" tkvs + <+> pprQuotedList tkvs | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs + = text "The" <+> what <+> plural "variable" tkvs <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc @@ -2940,7 +2940,7 @@ warnDefaulting wanteds default_ty (loc, ppr_wanteds) = pprWithArising tidy_wanteds warn_msg = hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds + , plural "constraint" tidy_wanteds , text "to type" , quotes (ppr default_ty) ]) 2 diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 771765901c..4e7b02bad0 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -492,7 +492,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = Just (_, unfunned) -> unwrapTypeVars unfunned _ -> [] where (vars, unforalled) = splitForAllVarBndrs t - holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches + holeVs = sep $ map (parens . ((text "_" <+> dcolon) <+>) . ppr) hfMatches holeDisp = if sMs then holeVs else sep $ replicate (length hfMatches) $ text "_" occDisp = pprPrefixOcc name diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 8aabc615ce..bade5a28f9 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -98,7 +98,7 @@ instance Outputable HoleFit where ppr (HoleFit _ cand ty _ _ mtchs _) = hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) where name = ppr $ getName cand - holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs + holes = sep $ map (parens . ((text "_" <+> dcolon) <+>) . ppr) mtchs -- We compare HoleFits by their name instead of their Id, since we don't -- want our tests to be affected by the non-determinism of `nonDetCmpVar`, diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index ef7168076f..98bf1a04bc 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -39,7 +39,7 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] warnAnns [] = return [] warnAnns anns@(L loc _ : _) = do { setSrcSpan loc $ addWarnTc NoReason $ - (text "Ignoring ANN annotation" <> plural anns <> comma + (text "Ignoring ANN" <+> plural "annotation" anns <> comma <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") ; return [] } diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 70201773b9..4d4e33edae 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -2657,8 +2657,8 @@ provided. badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) + = hang (text "Record update for insufficiently polymorphic" + <+> plural "field" prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) badFieldsUpd diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 2ae1f1cfb9..b7acc7e879 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -737,7 +737,7 @@ tcPatSig in_pat_bind sig res_ty patBindSigErr :: [(Name,TcTyVar)] -> SDoc patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs + = hang (text "You cannot bind scoped type" <+> plural "variable" sig_tvs <+> pprQuotedList (map fst sig_tvs)) 2 (text "in a pattern binding signature") diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 68c894f2e4..c6d3010ff1 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -990,8 +990,8 @@ reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn (tyfamEqn :| []) in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) where - herald = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) + herald = sep [ what <+> pluralVarSet "variable" tvs + <+> pprVarSet tvs (pprQuotedList . scopedSort) , text "cannot be inferred from the right-hand side." ] $$ extra diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 40344af9ed..357c4fc5a2 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -414,14 +414,14 @@ checkInstCoverage be_liberal clas theta inst_taus <+> quotes (ppr clas) , nest 2 $ text "for functional dependency:" <+> quotes (pprFunDep fd) ] - , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls + , sep [ text "Reason: lhs" <+> plural "type" ls <+> pprQuotedList ls , nest 2 $ (if isSingleton ls then text "does not" else text "do not jointly") - <+> text "determine rhs type"<>plural rs + <+> text "determine rhs" <+> plural "type" rs <+> pprQuotedList rs ] - , text "Un-determined variable" <> pluralVarSet undet_set <> colon + , text "Un-determined" <+> pluralVarSet "variable" undet_set <> colon <+> pprVarSet undet_set (pprWithCommas ppr) , ppWhen (not be_liberal && and (isEmptyVarSet <$> liberal_undet_tvs)) $ diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index c060eac638..4d88056665 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1165,8 +1165,8 @@ decideMonoTyVars infer_mode name_taus psigs candidates pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus mr_msg = - hang (sep [ text "The Monomorphism Restriction applies to the binding" - <> plural name_taus + hang (sep [ text "The Monomorphism Restriction applies to the" + <+> plural "binding" name_taus , text "for" <+> pp_bndrs ]) 2 (hsep [ text "Consider giving" , text (if isSingleton name_taus then "it" else "them") diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 797ff2f594..02949968fe 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -227,8 +227,8 @@ dependentArgErr (arg, bad_cos) , hang (text "Pattern-bound variable") 2 (ppr arg <+> dcolon <+> ppr (idType arg)) , nest 2 $ - hang (text "has a type that mentions pattern-bound coercion" - <> plural bad_co_list <> colon) + hang (text "has a type that mentions pattern-bound" + <+> plural "coercion" bad_co_list <> colon) 2 (pprWithCommas ppr bad_co_list) , text "Hint: use -fprint-explicit-coercions to see the coercions" , text "Probable fix: add a pattern signature" ] @@ -368,7 +368,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; checkTc (null bad_tvs) $ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma , text "namely" <+> quotes (ppr pat_ty) ]) - 2 (text "mentions existential type variable" <> plural bad_tvs + 2 (text "mentions existential type" <+> plural "variable" bad_tvs <+> pprQuotedList bad_tvs) -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 86427853de..e86bdf4c19 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -243,7 +243,7 @@ pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx pprSkolInfo (ForAllSkol doc) = quotes doc -pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" +pprSkolInfo (IPSkol ips) = text "the implicit-parameter" <+> plural "binding" ips <+> text "for" <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) pprSkolInfo InstSkol = text "the instance declaration" @@ -254,7 +254,7 @@ pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name pprSkolInfo ArrowSkol = text "an arrow form" pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl , text "in" <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") +pprSkolInfo (InferSkol ids) = hang (text "the inferred" <+> plural "type" ids <+> text "of") 2 (vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]) pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index d37b37efe3..27460b0882 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -2396,7 +2396,7 @@ naughtyQuantification orig_ty tv escapees orig_ty' = tidyType env orig_ty1 ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) doc = pprWithExplicitKindsWhen True $ - vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' + vcat [ sep [ text "Cannot generalise type;" <+> plural "skolem" escapees' , quotes $ ppr_tidied escapees' , text "would escape" <+> itsOrTheir escapees' <+> text "scope" ] diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 6e44a6c399..b5ba5feec9 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1424,7 +1424,7 @@ constraintSynErr env kind dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) dupPredWarn env dups = ( env - , text "Duplicate constraint" <> plural primaryDups <> text ":" + , text "Duplicate" <+> plural "constraint" primaryDups <> text ":" <+> pprWithCommas (ppr_tidy env) primaryDups ) where primaryDups = map NE.head dups @@ -1955,7 +1955,7 @@ smallerMsg what inst_head noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc noMoreMsg tvs what inst_head - = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) + = vcat [ hang (plural "Variable" tvs1 <+> quotes (pprWithCommas ppr tvs1) <+> occurs <+> text "more often") 2 (sep [ text "in the" <+> what , text "than in the instance head" <+> quotes inst_head ]) @@ -2196,7 +2196,7 @@ checkFamPatBinders fam_tc qtvs pats rhs check_tvs tvs what what2 = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ - hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs + hang (text "Type" <+> plural "variable" tvs <+> pprQuotedList tvs <+> isOrAre tvs <+> what <> comma) 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" , mk_extra tvs ]) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 103b1940a0..52b819a3b5 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -1487,7 +1487,7 @@ pprInline' :: Bool -- True <=> do not display the inl_inline field -> SDoc pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) - = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info + = (pp_inl inline <> pp_act inline activation) <+> pp_sat <+> pp_info where pp_inl x = if emptyInline then empty else ppr x diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 01ab645783..bb7e966819 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -410,7 +410,7 @@ pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) -- | Determines the pluralisation suffix appropriate for the length of a set -- in the same way that plural from Outputable does for lists. -pluralUFM :: UniqFM a -> SDoc -pluralUFM ufm - | sizeUFM ufm == 1 = empty - | otherwise = char 's' +pluralUFM :: String -> UniqFM a -> SDoc +pluralUFM s ufm + | sizeUFM ufm == 1 = text s + | otherwise = text (s ++ "s") diff --git a/compiler/GHC/Types/Var/Set.hs b/compiler/GHC/Types/Var/Set.hs index 5126988a2c..1d095a69e9 100644 --- a/compiler/GHC/Types/Var/Set.hs +++ b/compiler/GHC/Types/Var/Set.hs @@ -196,8 +196,8 @@ seqVarSet s = sizeVarSet s `seq` () -- | Determines the pluralisation suffix appropriate for the length of a set -- in the same way that plural from Outputable does for lists. -pluralVarSet :: VarSet -> SDoc -pluralVarSet = pluralUFM . getUniqSet +pluralVarSet :: String -> VarSet -> SDoc +pluralVarSet s = pluralUFM s . getUniqSet -- | Pretty-print a non-deterministic set. -- The order of variables is non-deterministic and for pretty-printing that diff --git a/compiler/utils/GhcPrelude.hs b/compiler/utils/GhcPrelude.hs index dd78f15573..fa028b2d56 100644 --- a/compiler/utils/GhcPrelude.hs +++ b/compiler/utils/GhcPrelude.hs @@ -12,11 +12,7 @@ module GhcPrelude (module X) where --- We export the 'Semigroup' class but w/o the (<>) operator to avoid --- clashing with the (Outputable.<>) operator which is heavily used --- through GHC's code-base. - -import Prelude as X hiding ((<>)) +import Prelude as X import Data.Foldable as X (foldl') {- diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index d36faa4724..a65dda8f75 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -700,12 +700,14 @@ unicode unicode plain = sdocOption sdocCanUseUnicode $ \case True -> unicode False -> plain +infixr 6 <+> -- matches that of (Semigroup.<>) +infixl 5 $$, $+$ + nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap (<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them +-- ^ Join two 'SDoc' together horizontally with a gap between them. +-- Use '(<>)' to join without a gap. ($$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically; if there is -- no vertical overlap it "dovetails" the two onto one line @@ -713,11 +715,14 @@ nest :: Int -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically nest n d = SDoc $ Pretty.nest n . runSDoc d -(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) +-- | Join two 'SDoc' together horizontally without a gap +instance Semigroup SDoc where + d1 <> d2 = SDoc $ \sty -> runSDoc d1 sty <> runSDoc d2 sty + hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally hsep :: [SDoc] -> SDoc @@ -790,8 +795,8 @@ coloured col sdoc = sdocOption sdocShouldUseColor $ \case ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } -> let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in Pretty.zeroWidthText (Col.renderColour col) - Pretty.<> runSDoc sdoc ctx' - Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) + <> runSDoc sdoc ctx' + <> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) ctx -> runSDoc sdoc ctx False -> sdoc @@ -1179,9 +1184,9 @@ speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments -- > plural [] = char 's' -- > plural ["Hello"] = empty -- > plural ["Hello", "World"] = char 's' -plural :: [a] -> SDoc -plural [_] = empty -- a bit frightening, but there you are -plural _ = char 's' +plural :: String -> [a] -> SDoc +plural s [_] = text s -- a bit frightening, but there you are +plural s _ = text (s ++ "s") -- | Determines the form of to be appropriate for the length of a list: -- diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs index 5adfdd7699..6e8686a62d 100644 --- a/compiler/utils/Pretty.hs +++ b/compiler/utils/Pretty.hs @@ -201,8 +201,7 @@ But it doesn't work, for if x=empty, we would have -- --------------------------------------------------------------------------- -- Operator fixity -infixl 6 <> -infixl 6 <+> +infixr 6 <+> -- matches that of (Semigroup.<>) infixl 5 $$, $+$ @@ -659,14 +658,10 @@ nilAboveNest g k q | not g && k > 0 -- No newline if no overlap -- --------------------------------------------------------------------------- -- Horizontal composition @<>@ --- We intentionally avoid Data.Monoid.(<>) here due to interactions of --- Data.Monoid.(<>) and (<+>). See --- http://www.haskell.org/pipermail/libraries/2011-November/017066.html - -- | Beside. -- '<>' is associative, with identity 'empty'. -(<>) :: Doc -> Doc -> Doc -p <> q = beside_ p False q +instance Semigroup Doc where + p <> q = beside_ p False q -- | Beside, separated by space, unless one of the arguments is 'empty'. -- '<+>' is associative, with identity 'empty'. diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 87826438e3..13a220298c 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -110,7 +110,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.Time.LocalTime ( getZonedTime ) import Data.Time.Format ( formatTime, defaultTimeLocale ) import Data.Version ( showVersion ) -import Prelude hiding ((<>)) +import Prelude import Exception hiding (catch) import Foreign hiding (void) diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index f5df1edc38..9c93f17ed7 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -28,7 +28,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Time -import Prelude hiding (mod,(<>)) +import Prelude hiding (mod) import System.Directory import qualified GHC.Core.Utils diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 27e31b6cf6..bc7e56e48c 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -62,7 +62,7 @@ import Data.Time import System.Environment import System.IO import Control.Monad -import Prelude hiding ((<>)) +import Prelude import System.Console.Haskeline (CompletionFunc, InputT) import Control.Monad.Catch diff --git a/ghc/Main.hs b/ghc/Main.hs index 7a356b920a..0699e8d075 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -862,7 +862,7 @@ dumpFastStringStats dflags = do -- the "z-encoded" total. putMsg dflags msg where - x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' + x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO () showPackages dflags = putStrLn (showSDoc dflags (pprPackages (pkgState dflags))) -- cgit v1.2.1