Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.PackageDescription.PrettyPrint
   9 -- Copyright   :  Jürgen Nicklisch-Franken 2010
  10 -- License     :  BSD3
  11 --
  12 -- Maintainer  : cabal-devel@haskell.org
  13 -- Stability   : provisional
  14 -- Portability : portable
  15 --
  16 -- Pretty printing for cabal files
  17 module Distribution.PackageDescription.PrettyPrint
  18   ( -- * Generic package descriptions
  19     writeGenericPackageDescription
  20   , showGenericPackageDescription
  21   , ppGenericPackageDescription
  22
  23     -- * Package descriptions
  24   , writePackageDescription
  25   , showPackageDescription
  26
  27     -- ** Supplementary build information
  28   , writeHookedBuildInfo
  29   , showHookedBuildInfo
  30   ) where
  31
  32 import Distribution.Compat.Prelude
  33 import Prelude ()
  34
  35 import Distribution.CabalSpecVersion
  36 import Distribution.Compat.Lens
  37 import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar)
  38 import Distribution.Fields.Pretty
  39 import Distribution.PackageDescription
  40 import Distribution.PackageDescription.Configuration (transformAllBuildInfos)
  41 import Distribution.PackageDescription.FieldGrammar
  42   ( benchmarkFieldGrammar
  43   , buildInfoFieldGrammar
  44   , executableFieldGrammar
  45   , flagFieldGrammar
  46   , foreignLibFieldGrammar
  47   , libraryFieldGrammar
  48   , packageDescriptionFieldGrammar
  49   , setupBInfoFieldGrammar
  50   , sourceRepoFieldGrammar
  51   , testSuiteFieldGrammar
  52   )
  53 import Distribution.Pretty
  54 import Distribution.Utils.Generic (writeFileAtomic, writeUTF8File)
  55
  56 import qualified Distribution.PackageDescription.FieldGrammar as FG
  57 import qualified Distribution.Types.BuildInfo.Lens as L
  58 import qualified Distribution.Types.SetupBuildInfo.Lens as L
  59
  60 import Text.PrettyPrint (Doc, char, hsep, parens, text)
  61
  62 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
  63 import qualified Distribution.Compat.NonEmptySet as NES
  64
  65 -- | Writes a .cabal file from a generic package description
  66 writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
  67 writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
  68
  69 -- | Writes a generic package description to a string
  70 showGenericPackageDescription :: GenericPackageDescription -> String
  71 showGenericPackageDescription gpd = showFields (const NoComment) $ ppGenericPackageDescription v gpd
  72   where
  73     v = specVersion $ packageDescription gpd
  74
  75 -- | Convert a generic package description to 'PrettyField's.
  76 ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()]
  77 ppGenericPackageDescription v gpd0 =
  78   concat
  79     [ ppPackageDescription v (packageDescription gpd)
  80     , ppSetupBInfo v (setupBuildInfo (packageDescription gpd))
  81     , ppGenPackageFlags v (genPackageFlags gpd)
  82     , ppCondLibrary v (condLibrary gpd)
  83     , ppCondSubLibraries v (condSubLibraries gpd)
  84     , ppCondForeignLibs v (condForeignLibs gpd)
  85     , ppCondExecutables v (condExecutables gpd)
  86     , ppCondTestSuites v (condTestSuites gpd)
  87     , ppCondBenchmarks v (condBenchmarks gpd)
  88     ]
  89   where
  90     gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0
  91
  92 ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()]
  93 ppPackageDescription v pd =
  94   prettyFieldGrammar v packageDescriptionFieldGrammar pd
  95     ++ ppSourceRepos v (sourceRepos pd)
  96
  97 ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()]
  98 ppSourceRepos = map . ppSourceRepo
  99
 100 ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ()
 101 ppSourceRepo v repo =
 102   PrettySection () "source-repository" [pretty kind] $
 103     prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo
 104   where
 105     kind = repoKind repo
 106
 107 ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()]
 108 ppSetupBInfo _ Nothing = mempty
 109 ppSetupBInfo v (Just sbi)
 110   | defaultSetupDepends sbi = mempty
 111   | otherwise =
 112       pure $
 113         PrettySection () "custom-setup" [] $
 114           prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi
 115
 116 ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()]
 117 ppGenPackageFlags = map . ppFlag
 118
 119 ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ()
 120 ppFlag v flag@(MkPackageFlag name _ _ _) =
 121   PrettySection () "flag" [ppFlagName name] $
 122     prettyFieldGrammar v (flagFieldGrammar name) flag
 123
 124 ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()]
 125 ppCondTree2 v grammar = go
 126   where
 127     -- TODO: recognise elif opportunities
 128     go (CondNode it _ ifs) =
 129       prettyFieldGrammar v grammar it
 130         ++ concatMap ppIf ifs
 131
 132     ppIf (CondBranch c thenTree Nothing)
 133       --        | isEmpty thenDoc = mempty
 134       | otherwise = [ppIfCondition c thenDoc]
 135       where
 136         thenDoc = go thenTree
 137     ppIf (CondBranch c thenTree (Just elseTree)) =
 138       -- See #6193
 139       [ ppIfCondition c (go thenTree)
 140       , PrettySection () "else" [] (go elseTree)
 141       ]
 142
 143 ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()]
 144 ppCondLibrary _ Nothing = mempty
 145 ppCondLibrary v (Just condTree) =
 146   pure $
 147     PrettySection () "library" [] $
 148       ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree
 149
 150 ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()]
 151 ppCondSubLibraries v libs =
 152   [ PrettySection () "library" [pretty n] $
 153     ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree
 154   | (n, condTree) <- libs
 155   ]
 156
 157 ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()]
 158 ppCondForeignLibs v flibs =
 159   [ PrettySection () "foreign-library" [pretty n] $
 160     ppCondTree2 v (foreignLibFieldGrammar n) condTree
 161   | (n, condTree) <- flibs
 162   ]
 163
 164 ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()]
 165 ppCondExecutables v exes =
 166   [ PrettySection () "executable" [pretty n] $
 167     ppCondTree2 v (executableFieldGrammar n) condTree
 168   | (n, condTree) <- exes
 169   ]
 170
 171 ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()]
 172 ppCondTestSuites v suites =
 173   [ PrettySection () "test-suite" [pretty n] $
 174     ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)
 175   | (n, condTree) <- suites
 176   ]
 177
 178 ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()]
 179 ppCondBenchmarks v suites =
 180   [ PrettySection () "benchmark" [pretty n] $
 181     ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)
 182   | (n, condTree) <- suites
 183   ]
 184
 185 ppCondition :: Condition ConfVar -> Doc
 186 ppCondition (Var x) = ppConfVar x
 187 ppCondition (Lit b) = text (show b)
 188 ppCondition (CNot c) = char '!' <<>> (ppCondition c)
 189 ppCondition (COr c1 c2) =
 190   parens
 191     ( hsep
 192         [ ppCondition c1
 193         , text "||"
 194             <+> ppCondition c2
 195         ]
 196     )
 197 ppCondition (CAnd c1 c2) =
 198   parens
 199     ( hsep
 200         [ ppCondition c1
 201         , text "&&"
 202             <+> ppCondition c2
 203         ]
 204     )
 205 ppConfVar :: ConfVar -> Doc
 206 ppConfVar (OS os) = text "os" <<>> parens (pretty os)
 207 ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch)
 208 ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name)
 209 ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v)
 210
 211 ppFlagName :: FlagName -> Doc
 212 ppFlagName = text . unFlagName
 213
 214 ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField ()
 215 ppIfCondition c = PrettySection () "if" [ppCondition c]
 216
 217 -- | @since 2.0.0.2
 218 writePackageDescription :: FilePath -> PackageDescription -> IO ()
 219 writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
 220
 221 -- TODO: make this use section syntax
 222 -- add equivalent for GenericPackageDescription
 223
 224 -- | @since 2.0.0.2
 225 showPackageDescription :: PackageDescription -> String
 226 showPackageDescription = showGenericPackageDescription . pdToGpd
 227
 228 pdToGpd :: PackageDescription -> GenericPackageDescription
 229 pdToGpd pd =
 230   GenericPackageDescription
 231     { packageDescription = pd
 232     , gpdScannedVersion = Nothing
 233     , genPackageFlags = []
 234     , condLibrary = mkCondTree <$> library pd
 235     , condSubLibraries = mkCondTreeL <$> subLibraries pd
 236     , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd
 237     , condExecutables = mkCondTree' exeName <$> executables pd
 238     , condTestSuites = mkCondTree' testName <$> testSuites pd
 239     , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd
 240     }
 241   where
 242     -- We set CondTree's [Dependency] to an empty list, as it
 243     -- is not pretty printed anyway.
 244     mkCondTree x = CondNode x [] []
 245     mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] [])
 246
 247     mkCondTree'
 248       :: (a -> UnqualComponentName)
 249       -> a
 250       -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
 251     mkCondTree' f x = (f x, CondNode x [] [])
 252
 253 -------------------------------------------------------------------------------
 254 -- Internal libs
 255 -------------------------------------------------------------------------------
 256
 257 -- See Note [Dependencies on sublibraries] in Distribution.PackageDescription.Parsec
 258 --
 259 preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription
 260 preProcessInternalDeps specVer gpd
 261   | specVer >= CabalSpecV3_4 = gpd
 262   | otherwise = transformAllBuildInfos transformBI transformSBI gpd
 263   where
 264     transformBI :: BuildInfo -> BuildInfo
 265     transformBI =
 266       over L.targetBuildDepends (concatMap transformD)
 267         . over L.mixins (map transformM)
 268
 269     transformSBI :: SetupBuildInfo -> SetupBuildInfo
 270     transformSBI = over L.setupDepends (concatMap transformD)
 271
 272     transformD :: Dependency -> [Dependency]
 273     transformD (Dependency pn vr ln)
 274       | pn == thisPn =
 275           if LMainLibName `NES.member` ln
 276             then Dependency thisPn vr mainLibSet : sublibs
 277             else sublibs
 278       where
 279         sublibs =
 280           [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet
 281           | LSubLibName uqn <- NES.toList ln
 282           ]
 283     transformD d = [d]
 284
 285     transformM :: Mixin -> Mixin
 286     transformM (Mixin pn (LSubLibName uqn) inc)
 287       | pn == thisPn =
 288           mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc
 289     transformM m = m
 290
 291     thisPn :: PackageName
 292     thisPn = pkgName (package (packageDescription gpd))
 293
 294 -------------------------------------------------------------------------------
 295 -- HookedBuildInfo
 296 -------------------------------------------------------------------------------
 297
 298 -- | @since 2.0.0.2
 299 writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
 300 writeHookedBuildInfo fpath =
 301   writeFileAtomic fpath
 302     . BS.Char8.pack
 303     . showHookedBuildInfo
 304
 305 -- | @since 2.0.0.2
 306 showHookedBuildInfo :: HookedBuildInfo -> String
 307 showHookedBuildInfo (mb_lib_bi, ex_bis) =
 308   showFields (const NoComment) $
 309     maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi
 310       ++ [ PrettySection () "executable:" [pretty name] $
 311           prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi
 312          | (name, bi) <- ex_bis
 313          ]