From d2bb9241b7364b981e2a1eb1338ae1e19ab16bc8 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 4 Nov 2024 15:09:33 -0800 Subject: [PATCH] Convert display functions into `Pretty` instances We have a lot of `showType` functions that are effectively a `Pretty` instance but less composable. Let's make them proper `Pretty` instances. Split off of #10524 --- .../Solver/Types/ConstraintSource.hs | 51 ++++++++++--------- .../Solver/Types/PackageConstraint.hs | 39 +++++++------- .../src/Distribution/Client/Targets.hs | 2 +- 3 files changed, 46 insertions(+), 46 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index cb91bc742b4..3f171b3c6d7 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -6,7 +6,8 @@ module Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath) -import Text.PrettyPrint (render) +import Distribution.Pretty (Pretty(pretty), prettyShow) +import Text.PrettyPrint (text) -- | Source of a 'PackageConstraint'. data ConstraintSource = @@ -55,31 +56,35 @@ data ConstraintSource = -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion - deriving (Eq, Show, Generic) + deriving (Show, Eq, Generic) instance Binary ConstraintSource instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ render (docProjectConfigPath path) -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonReinstallablePackage = - "non-reinstallable package" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceMultiRepl = - "--enable-multi-repl" -showConstraintSource ConstraintSourceProfiledDynamic = - "--enable-profiling-shared" -showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" -showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" +showConstraintSource = prettyShow + +instance Pretty ConstraintSource where + pretty constraintSource = case constraintSource of + (ConstraintSourceMainConfig path) -> + text "main config" <+> text path + (ConstraintSourceProjectConfig path) -> + text "project config" <+> docProjectConfigPath path + (ConstraintSourceUserConfig path)-> text "user config " <+> text path + ConstraintSourceCommandlineFlag -> text "command line flag" + ConstraintSourceUserTarget -> text "user target" + ConstraintSourceNonReinstallablePackage -> + text "non-reinstallable package" + ConstraintSourceFreeze -> text "cabal freeze" + ConstraintSourceConfigFlagOrTarget -> + text "config file, command line flag, or user target" + ConstraintSourceMultiRepl -> + text "--enable-multi-repl" + ConstraintSourceProfiledDynamic -> + text "--enable-profiling-shared" + ConstraintSourceUnknown -> text "unknown source" + ConstraintSetupCabalMinVersion -> + text "minimum version of Cabal used by Setup.hs" + ConstraintSetupCabalMaxVersion -> + text "maximum version of Cabal used by Setup.hs" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index fbe56380e81..06c5ae169fa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -11,9 +11,7 @@ module Distribution.Solver.Types.PackageConstraint ( scopeToPackageName, constraintScopeMatches, PackageProperty(..), - dispPackageProperty, PackageConstraint(..), - dispPackageConstraint, showPackageConstraint, packageConstraintToDependency ) where @@ -23,7 +21,7 @@ import Prelude () import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, pretty) +import Distribution.Pretty (flatStyle, Pretty(pretty)) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) import Distribution.Version (VersionRange, simplifyVersionRange) @@ -82,12 +80,11 @@ constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' --- | Pretty-prints a constraint scope. -dispConstraintScope :: ConstraintScope -> Disp.Doc -dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn -dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn -dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn -dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn +instance Pretty ConstraintScope where + pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn + pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn + pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn + pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. data PackageProperty @@ -101,24 +98,22 @@ data PackageProperty instance Binary PackageProperty instance Structured PackageProperty --- | Pretty-prints a package property. -dispPackageProperty :: PackageProperty -> Disp.Doc -dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange -dispPackageProperty PackagePropertyInstalled = Disp.text "installed" -dispPackageProperty PackagePropertySource = Disp.text "source" -dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags -dispPackageProperty (PackagePropertyStanzas stanzas) = - Disp.hsep $ map (Disp.text . showStanza) stanzas +instance Pretty PackageProperty where + pretty (PackagePropertyVersion verrange) = pretty verrange + pretty PackagePropertyInstalled = Disp.text "installed" + pretty PackagePropertySource = Disp.text "source" + pretty (PackagePropertyFlags flags) = dispFlagAssignment flags + pretty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty deriving (Eq, Show) --- | Pretty-prints a package constraint. -dispPackageConstraint :: PackageConstraint -> Disp.Doc -dispPackageConstraint (PackageConstraint scope prop) = - dispConstraintScope scope <+> dispPackageProperty prop +instance Pretty PackageConstraint where + pretty (PackageConstraint scope prop) = + pretty scope <+> pretty prop -- | Alternative textual representation of a package constraint -- for debugging purposes (slightly more verbose than that @@ -126,7 +121,7 @@ dispPackageConstraint (PackageConstraint scope prop) = -- showPackageConstraint :: PackageConstraint -> String showPackageConstraint pc@(PackageConstraint scope prop) = - Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 + Disp.renderStyle flatStyle . postprocess $ pretty pc2 where pc2 = case prop of PackagePropertyVersion vr -> diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index e1387cfba20..a973433ccb8 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -674,7 +674,7 @@ readUserConstraint str = instance Pretty UserConstraint where pretty (UserConstraint scope prop) = - dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop + pretty $ PackageConstraint (fromUserConstraintScope scope) prop instance Parsec UserConstraint where parsec = do