pretty printing

Author: andreabedini

Cabal/src/Distribution/Backpack/ModuleShape.hs

@@ -19,6 +19,8 @@ import Distribution.Backpack.ModSubst
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Distribution.Pretty
+import qualified Text.PrettyPrint as Disp
 
 -----------------------------------------------------------------------
 -- Module shapes
@@ -34,6 +36,12 @@ data ModuleShape = ModuleShape
 
 instance Binary ModuleShape
 instance Structured ModuleShape
+instance Pretty ModuleShape where
+  pretty (ModuleShape provs reqs) =
+    Disp.hang (Disp.text "ModuleShape") 2 $ Disp.vcat
+      [ Disp.hang (Disp.text "provides =") 2 $ dispOpenModuleSubst provs
+      , Disp.hang (Disp.text "requires =") 2 $ Disp.hsep (map pretty (Set.toList reqs))
+      ]
 
 instance ModSubst ModuleShape where
   modSubst subst (ModuleShape provs reqs) =

Cabal/src/Distribution/Simple/Compiler.hs

@@ -105,6 +105,7 @@ import Language.Haskell.Extension
 
 import qualified Data.Map as Map (lookup)
 import System.Directory (canonicalizePath)
+import Text.PrettyPrint (text)
 
 data Compiler = Compiler
   { compilerId :: CompilerId
@@ -199,6 +200,11 @@ data PackageDBX fp
     SpecificPackageDB fp
   deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable)
 
+instance Pretty fp => Pretty (PackageDBX fp) where
+  pretty GlobalPackageDB = text "GlobalPackageDB"
+  pretty UserPackageDB = text "UserPackageDB"
+  pretty (SpecificPackageDB db) = text "SpecificPackageDB" <+> pretty db
+
 instance Binary fp => Binary (PackageDBX fp)
 instance Structured fp => Structured (PackageDBX fp)
 

cabal-install/src/Distribution/Client/HashValue.hs

@@ -22,6 +22,7 @@ import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
 import System.IO (IOMode (..), withBinaryFile)
+import qualified Text.PrettyPrint as Disp
 
 -----------------------------------------------
 -- The specific choice of hash implementation
@@ -48,6 +49,9 @@ newtype HashValue = HashValue BS.ByteString
 instance Binary HashValue
 instance Structured HashValue
 
+instance Pretty HashValue where
+  pretty = Disp.text . showHashValue
+
 -- | Hash some data. Currently uses SHA256.
 hashValue :: LBS.ByteString -> HashValue
 hashValue = HashValue . SHA256.hashlazy

cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs

@@ -372,36 +372,36 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
 instance Pretty ElaboratedConfiguredPackage where
     pretty elab =
       hang (text "ElaboratedConfiguredPackage") 4 $ vcat $
-        [ text "elabUnitId =" <+> pretty (elabUnitId elab)
-        , text "elabComponentId =" <+> pretty (elabComponentId elab)
-        , text "elabIsCanonical =" <+> text (show (elabIsCanonical elab))
-        , text "elabPkgSourceId =" <+> pretty (elabPkgSourceId elab)
-        , text "elabModuleShape =" <+> text (show (elabModuleShape elab))
-        , text "elabFlagAssignment =" <+> Cabal.dispFlagAssignment (elabFlagAssignment elab)
-        , text "elabFlagDefaults =" <+> Cabal.dispFlagAssignment (elabFlagDefaults elab)
-        , text "elabPkgDescription =" <+> text "<PackageDescription>"
-        , text "elabPkgSourceLocation =" <+> text (show (elabPkgSourceLocation elab))
-        , text "elabPkgSourceHash =" <+> text (show (elabPkgSourceHash elab))
-        , text "elabLocalToProject =" <+> text (show (elabLocalToProject elab))
-        , text "elabBuildStyle =" <+> text (show (elabBuildStyle elab))
-        , text "elabEnabledSpec =" <+> text (show (elabEnabledSpec elab))
+        [ hang (text "elabUnitId =") 2 $ pretty (elabUnitId elab)
+        , hang (text "elabComponentId =") 2 $ pretty (elabComponentId elab)
+        , hang (text "elabIsCanonical =") 2 $ pretty (elabIsCanonical elab)
+        , hang (text "elabPkgSourceId =") 2 $ pretty (elabPkgSourceId elab)
+        , hang (text "elabModuleShape =") 2 $ pretty (elabModuleShape elab)
+        , hang (text "elabFlagAssignment =") 2 $ Cabal.dispFlagAssignment (elabFlagAssignment elab)
+        , hang (text "elabFlagDefaults =") 2 $ Cabal.dispFlagAssignment (elabFlagDefaults elab)
+        , hang (text "elabPkgDescription =") 2 $ text "<PackageDescription>"
+        , hang (text "elabPkgSourceLocation =") 2 $ pretty (maybe mempty text <$> elabPkgSourceLocation elab)
+        , hang (text "elabPkgSourceHash =") 2 $ maybe mempty pretty (elabPkgSourceHash elab)
+        , hang (text "elabLocalToProject =") 2 $ text (show (elabLocalToProject elab))
+        , hang (text "elabBuildStyle =") 2 $ text $ show $ elabBuildStyle elab
+        , hang (text "elabEnabledSpec =") 2 $ text $ show $ elabEnabledSpec elab
         -- , text "elabStanzasAvailable =" <+> text (show (elabStanzasAvailable elab))
         -- , text "elabStanzasRequested =" <+> text (show (elabStanzasRequested elab))
-        , text "elabStage =" <+> text (show (elabStage elab))
-        -- , text "elabPackageDbs =" <+> text (show (elabPackageDbs elab))
-        -- , text "elabSetupPackageDBStack =" <+> text (show (elabSetupPackageDBStack elab))
-        -- , text "elabBuildPackageDBStack =" <+> text (show (elabBuildPackageDBStack elab))
-        -- , text "elabRegisterPackageDBStack =" <+> text (show (elabRegisterPackageDBStack elab))
+        , hang (text "elabStage =") 2 $ pretty (elabStage elab)
+        , hang (text "elabPackageDbs =") 2 $ sep $ map pretty $ fmap text <$> elabPackageDbs elab
+        , hang (text "elabSetupPackageDBStack =") 2 $ text (show (elabSetupPackageDBStack elab))
+        , hang (text "elabBuildPackageDBStack =") 2 $ text (show (elabBuildPackageDBStack elab))
+        , hang (text "elabRegisterPackageDBStack =") 2 $ text (show (elabRegisterPackageDBStack elab))
         -- , text "elabInplaceSetupPackageDBStack =" <+> text (show (elabInplaceSetupPackageDBStack elab))
         -- , text "elabInplaceBuildPackageDBStack =" <+> text (show (elabInplaceBuildPackageDBStack elab))
         -- , text "elabInplaceRegisterPackageDBStack =" <+> text (show (elabInplaceRegisterPackageDBStack elab))
-        , text "elabPkgDescriptionOverride =" <+> text (show (elabPkgDescriptionOverride elab))
-        , text "elabBuildOptions =" <+> text "<BuildOptions>"
+        , hang (text "elabPkgDescriptionOverride =") 2 $ text (show (elabPkgDescriptionOverride elab))
+        , hang (text "elabBuildOptions =") 2 $ text "<BuildOptions>"
         -- , text "elabDumpBuildInfo =" <+> text (show (elabDumpBuildInfo elab))
         -- , text "elabProgramPaths =" <+> text (show (elabProgramPaths elab))
         -- , text "elabProgramArgs =" <+> text (show (elabProgramArgs elab))
         -- , text "elabProgramPathExtra =" <+> text (show (elabProgramPathExtra elab))
-        , text "elabConfigureScriptArgs =" <+> text (show (elabConfigureScriptArgs elab))
+        , hang (text "elabConfigureScriptArgs =") 2 $ text (show (elabConfigureScriptArgs elab))
         -- , text "elabExtraLibDirs =" <+> text (show (elabExtraLibDirs elab))
         -- , text "elabExtraLibDirsStatic =" <+> text (show (elabExtraLibDirsStatic elab))
         -- , text "elabExtraFrameworkDirs =" <+> text (show (elabExtraFrameworkDirs elab))
@@ -435,19 +435,19 @@ instance Pretty ElaboratedConfiguredPackage where
         -- , text "elabTestWrapper =" <+> text (show (elabTestWrapper elab))
         -- , text "elabTestFailWhenNoTestSuites =" <+> text (show (elabTestFailWhenNoTestSuites elab))
         -- , text "elabTestTestOptions =" <+> text (show (elabTestTestOptions elab))
-        , text "elabBenchmarkOptions =" <+> text (show (elabBenchmarkOptions elab))
-        , text "elabSetupScriptStyle =" <+> text (show (elabSetupScriptStyle elab))
-        , text "elabSetupScriptCliVersion =" <+> pretty (elabSetupScriptCliVersion elab)
-        , text "elabConfigureTargets =" <+> text (show (elabConfigureTargets elab))
-        , text "elabBuildTargets =" <+> text (show (elabBuildTargets elab))
-        , text "elabTestTargets =" <+> text (show (elabTestTargets elab))
-        , text "elabBenchTargets =" <+> text (show (elabBenchTargets elab))
-        , text "elabReplTarget =" <+> text (show (elabReplTarget elab))
-        , text "elabHaddockTargets =" <+> text (show (elabHaddockTargets elab))
-        , text "elabBuildHaddocks =" <+> text (show (elabBuildHaddocks elab))
-        , text "elabPkgOrComp =" <+> pretty (elabPkgOrComp elab)
+        , hang (text "elabBenchmarkOptions =") 2 $ text (show (elabBenchmarkOptions elab))
+        , hang (text "elabSetupScriptStyle =") 2 $ text (show (elabSetupScriptStyle elab))
+        , hang (text "elabSetupScriptCliVersion =") 2 $ pretty (elabSetupScriptCliVersion elab)
+        , hang (text "elabConfigureTargets =") 2 $ text (show (elabConfigureTargets elab))
+        , hang (text "elabBuildTargets =") 2 $ text (show (elabBuildTargets elab))
+        , hang (text "elabTestTargets =") 2 $ text (show (elabTestTargets elab))
+        , hang (text "elabBenchTargets =") 2 $ text (show (elabBenchTargets elab))
+        , hang (text "elabReplTarget =") 2 $ text (show (elabReplTarget elab))
+        , hang (text "elabHaddockTargets =") 2 $ text (show (elabHaddockTargets elab))
+        , hang (text "elabBuildHaddocks =") 2 $ text (show (elabBuildHaddocks elab))
+        , hang (text "elabPkgOrComp =") 2 $ pretty (elabPkgOrComp elab)
         ]
-      
+
 normaliseConfiguredPackage
   :: ElaboratedSharedConfig
   -> ElaboratedConfiguredPackage
@@ -847,8 +847,8 @@ instance Structured ElaboratedComponent
 instance Pretty ElaboratedComponent where
   pretty comp =
     hang (text "ElaboratedComponent") 4 $ vcat $
-      [ text "compSolverName =" <+> text (show (compSolverName comp))
-      , text "compComponentName =" <+> text (show (compComponentName comp))
+      [ hang (text "compSolverName =") 2 $ text (show (compSolverName comp))
+      , hang (text "compComponentName =") 2 $ text (show (compComponentName comp))
       , hang (text "compLibDependencies =") 4 $ sep
           [ pretty cid <+> if promised then text "promised" else mempty
           | (cid, promised) <- compLibDependencies comp
@@ -857,14 +857,14 @@ instance Pretty ElaboratedComponent where
           [ pretty ouid
           | ouid <- compLinkedLibDependencies comp
           ]
-      , text "compInstantiatedWith =" <+> text (show (compInstantiatedWith comp))
-      , text "compLinkedInstantiatedWith =" <+> text (show (compLinkedInstantiatedWith comp))
+      , hang (text "compInstantiatedWith =") 2 $ text (show (compInstantiatedWith comp))
+      , hang (text "compLinkedInstantiatedWith =") 2 $ text (show (compLinkedInstantiatedWith comp))
       , hang (text "compExeDependencies =") 4 $ sep
           [ pretty cid
           | cid <- compExeDependencies comp
           ]
-      , text "compPkgConfigDependencies =" <+> text (show (compPkgConfigDependencies comp))
-      , text "compExeDependencyPaths =" <+> text (show (compExeDependencyPaths comp))
+      , hang (text "compPkgConfigDependencies =") 2 $ text (show (compPkgConfigDependencies comp))
+      , hang (text "compExeDependencyPaths =") 2 $ text (show (compExeDependencyPaths comp))
       , hang (text "compOrderLibDependencies =") 4 $ sep $
           map pretty (compOrderLibDependencies comp)
       ]
@@ -903,21 +903,21 @@ instance Structured ElaboratedPackage
 instance Pretty ElaboratedPackage where
   pretty pkg =
     hang (text "ElaboratedPackage") 4 $ vcat $
-      [ text "pkgStage =" <+> pretty (pkgStage pkg)
-      , text "pkgInstalledId =" <+> pretty (pkgInstalledId pkg)
-      , text "pkgLibDependencies =" <+> pretty (fmap (vcat .  map prettyPromised) (pkgLibDependencies pkg))
-      , text "pkgDependsOnSelfLib =" <+> pretty (fmap (vcat . map (const (text "*"))) (pkgDependsOnSelfLib pkg))
-      , text "pkgExeDependencies =" <+> pretty (fmap (vcat . map pretty) (pkgExeDependencies pkg))
-      , text "pkgExeDependencyPaths =" <+> pretty (fmap (vcat . map prettyExePath) (pkgExeDependencyPaths pkg))
-      , text "pkgPkgConfigDependencies =" <+> text (show (pkgPkgConfigDependencies pkg))
-      , text "pkgStanzasEnabled =" <+> text (show (pkgStanzasEnabled pkg))
-      , text "pkgWhyNotPerComponent =" <+> text (show (pkgWhyNotPerComponent pkg))
+      [ hang (text "pkgStage =") 2 $ pretty (pkgStage pkg)
+      , hang (text "pkgInstalledId =") 2 $ pretty (pkgInstalledId pkg)
+      , hang (text "pkgLibDependencies =") 2 $ pretty (fmap (vcat .  map prettyPromised) (pkgLibDependencies pkg))
+      , hang (text "pkgDependsOnSelfLib =") 2 $ pretty (fmap (vcat . map (const (text "*"))) (pkgDependsOnSelfLib pkg))
+      , hang (text "pkgExeDependencies =") 2 $ pretty (fmap (vcat . map pretty) (pkgExeDependencies pkg))
+      , hang (text "pkgExeDependencyPaths =") 2 $ pretty (fmap (vcat . map prettyExePath) (pkgExeDependencyPaths pkg))
+      , hang (text "pkgPkgConfigDependencies =") 2 $ text (show (pkgPkgConfigDependencies pkg))
+      , hang (text "pkgStanzasEnabled =") 2 $ text (show (pkgStanzasEnabled pkg))
+      , hang (text "pkgWhyNotPerComponent =") 2 $ text (show (pkgWhyNotPerComponent pkg))
       ]
     where
       prettyPromised (l, p) =
         pretty l <+> if p then text "promised" else mempty
       prettyExePath (l, p) =
-        pretty l <+> text "at" <+> text (show p)
+        pretty l <+> hang (text "at") 2 (text (show p))
 
 -- | Why did we fall-back to a per-package build, instead of using
 -- a per-component build?

cabal-install/src/Distribution/Client/Types/PackageLocation.hs

@@ -18,6 +18,7 @@ import Distribution.Types.PackageId (PackageId)
 import Distribution.Client.Types.Repo
 import Distribution.Client.Types.SourceRepo (SourceRepoMaybe)
 import Distribution.Solver.Types.SourcePackage (SourcePackage)
+import Text.PrettyPrint (text)
 
 type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)
 
@@ -39,6 +40,18 @@ data PackageLocation local
     RemoteSourceRepoPackage SourceRepoMaybe local
   deriving (Show, Functor, Eq, Ord, Generic)
 
+instance Pretty local => Pretty (PackageLocation local) where
+  pretty (LocalUnpackedPackage dir) =
+    text "LocalUnpackedPackage" <+> text dir
+  pretty (LocalTarballPackage file) =
+    text "LocalTarballPackage" <+> text file
+  pretty (RemoteTarballPackage uri loc) =
+    text "RemoteTarballPackage" <+> text (show uri) <+> pretty loc
+  pretty (RepoTarballPackage repo pkgId loc) =
+    text "RepoTarballPackage" <+> pretty repo <+> pretty pkgId <+> pretty loc
+  pretty (RemoteSourceRepoPackage repo loc) =
+    text "RemoteSourceRepoPackage" <+> pretty repo <+> pretty loc
+
 instance Binary local => Binary (PackageLocation local)
 instance Structured local => Structured (PackageLocation local)
 

cabal-install/src/Distribution/Client/Types/Repo.hs

@@ -182,6 +182,11 @@ data Repo
 instance Binary Repo
 instance Structured Repo
 
+instance Pretty Repo where
+  pretty (RepoLocalNoIndex r _) = pretty r
+  pretty (RepoRemote r _) = pretty r
+  pretty (RepoSecure r _) = pretty r
+
 -- | Check if this is a remote repo
 isRepoRemote :: Repo -> Bool
 isRepoRemote RepoLocalNoIndex{} = False

cabal-install/src/Distribution/Client/Types/SourceRepo.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Distribution.Client.Types.SourceRepo
   ( SourceRepositoryPackage (..)
@@ -24,6 +25,7 @@ import Prelude ()
 
 import Distribution.FieldGrammar
 import Distribution.Types.SourceRepo (RepoType (..))
+import qualified Text.PrettyPrint as Disp
 
 -- | @source-repository-package@ definition
 data SourceRepositoryPackage f = SourceRepositoryPackage
@@ -42,6 +44,17 @@ deriving instance Show (f FilePath) => Show (SourceRepositoryPackage f)
 deriving instance Binary (f FilePath) => Binary (SourceRepositoryPackage f)
 deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)
 
+instance (Foldable f) => Pretty (SourceRepositoryPackage f) where
+  pretty SourceRepositoryPackage{..} =
+    Disp.hang (Disp.text "SourceRepositoryPackage") 2 $ Disp.vcat
+      [ Disp.hang (Disp.text "type =") 2 $ pretty srpType
+      , Disp.hang (Disp.text "location =") 2 $ Disp.text srpLocation
+      , Disp.hang (Disp.text "tag =") 2 $ maybe Disp.empty Disp.text srpTag
+      , Disp.hang (Disp.text "branch =") 2 $ maybe Disp.empty Disp.text srpBranch
+      , Disp.hang (Disp.text "subdir =") 2 $ Disp.vcat (map Disp.text (toList srpSubdir))
+      , Disp.hang (Disp.text "post-checkout-command =") 2 $ Disp.vcat (map Disp.text srpCommand)
+      ]
+
 -- | Read from @cabal.project@
 type SourceRepoList = SourceRepositoryPackage []