hackage-cli-0.1.0.2: lib/Distribution/Server/Util/CabalRevisions.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module : Distribution.Server.Util.CabalRevisions
-- Copyright : Duncan Coutts et al.
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Maintainer : Andreas Abel
-- Stability : provisional
-- Portability : portable
--
-- Validation and helpers for Cabal revision handling
module Distribution.Server.Util.CabalRevisions
( diffCabalRevisions
, diffCabalRevisions'
, Change(..)
, insertRevisionField
) where
-- NB: This module avoids to import any hackage-server modules
import Distribution.CabalSpecVersion (CabalSpecVersion(..), cabalSpecLatest, showCabalSpecVersion)
import Distribution.Types.Dependency
import Distribution.Types.ExeDependency
import Distribution.Types.PkgconfigDependency
import Distribution.Types.PkgconfigVersionRange
import Distribution.Types.LegacyExeDependency
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.Types.ForeignLib
import Distribution.Package
import Distribution.Pretty (Pretty (..), prettyShow)
import Distribution.Version
import Distribution.Compiler (CompilerFlavor)
import Distribution.FieldGrammar (prettyFieldGrammar)
import Distribution.Fields.Pretty (PrettyField (..), showFields)
#if MIN_VERSION_Cabal(3,7,0)
import Distribution.Fields.Pretty (pattern NoComment)
#endif
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult)
import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
import Distribution.PackageDescription.Check
import Distribution.Parsec (showPWarning, showPError, PWarning (..))
import Distribution.Utils.ShortText
import Text.PrettyPrint as Doc
((<+>), colon, text, Doc, hsep, punctuate)
import Control.Applicative
import Control.Monad
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.Writer (MonadWriter(..), Writer, runWriter)
import Data.Foldable (for_)
import Data.List
((\\), deleteBy, intercalate)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.Char as Char
import qualified Data.Semigroup as S
import qualified Data.Monoid as M
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy(Proxy))
import qualified Control.Monad.Fail as Fail
-- | Entry point to cabal revision validator
--
-- This takes an original and a revised @.cabal@ decoded as Unicode
-- 'String' and performs validations. Returns either a validation
-- error or a list of detected changes.
diffCabalRevisions :: BS.ByteString -> BS.ByteString -> Either String [Change]
diffCabalRevisions = diffCabalRevisions' True
-- | Like 'diffCabalRevisions' but only optionally check @x-revision@ field modifications.
diffCabalRevisions'
:: Bool -- ^ check @x-revision@
-> BS.ByteString -- ^ old revision
-> BS.ByteString -- ^ new revision
-> Either String [Change]
diffCabalRevisions' checkXRevision oldVersion newRevision = runCheck $
checkCabalFileRevision checkXRevision oldVersion newRevision
newtype CheckM a = CheckM { unCheckM :: ExceptT String (Writer [Change]) a }
deriving (Functor, Applicative)
runCheck :: CheckM () -> Either String [Change]
runCheck c = case runWriter . runExceptT . unCheckM $ c of
(Left err, _ ) -> Left err
(Right (), changes)
| foldMap changeSeverity changes /= Trivial -> Right changes
| otherwise ->
Left "Only trivial changes, don't bother making this revision."
changeSeverity :: Change -> Severity
changeSeverity (Change s _ _ _) = s
instance Monad CheckM where
return = Control.Applicative.pure
CheckM m >>= f = CheckM (m >>= unCheckM . f)
#if !MIN_VERSION_base(4,13,0)
fail = Fail.fail
#endif
instance Fail.MonadFail CheckM where
fail = CheckM . throwError
-- | If we have only 'Trivial' changes, then there is no point to make
-- a revision. In other words for changes to be accepted, there should
-- be at least one 'Normal' change.
data Severity
= Normal
| Trivial
deriving (Eq, Ord, Show, Enum, Bounded)
instance S.Semigroup Severity where
Normal <> _ = Normal
Trivial <> x = x
-- | "Max" monoid.
instance M.Monoid Severity where
mempty = Trivial
mappend = (S.<>)
data Change = Change Severity String String String -- severity, what, from, to
deriving Show
logChange :: Change -> CheckM ()
logChange change = CheckM (tell [change])
type Check a = a -> a -> CheckM ()
checkCabalFileRevision :: Bool -> Check BS.ByteString
checkCabalFileRevision checkXRevision old new = do
(pkg, warns) <- parseCabalFile old
(pkg', warns') <- parseCabalFile new
let pkgid = packageId pkg
filename = prettyShow pkgid ++ ".cabal"
checkGenericPackageDescription checkXRevision pkg pkg'
checkParserWarnings filename warns warns'
checkPackageChecks pkg pkg'
where
parseCabalFile fileContent =
case runParseResult $ parseGenericPackageDescription fileContent of
(warnings, Right pkg) -> return (pkg, warnings)
(_warnings, Left (_mver, errs)) -> do
for_ errs $ \err -> fail (showPError "-" err)
fail "no better error"
-- new PWarning isn't Eq
differenceBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
differenceBy eq = foldl (flip $ deleteBy eq)
-- things can move, pos can change
eqPWarning :: PWarning -> PWarning -> Bool
eqPWarning (PWarning t _pos s) (PWarning t' _pos' s') =
t == t' && s == s'
checkParserWarnings :: FilePath -> Check [PWarning]
checkParserWarnings filename warns warns' =
case differenceBy eqPWarning warns' warns of
[] -> return ()
newwarns -> fail $ "New parse warning: "
++ unlines (map (showPWarning filename) newwarns)
checkPackageChecks :: Check GenericPackageDescription
checkPackageChecks pkg pkg' =
let checks = checkPackage pkg
-- The API change of checkPackage happened somewhere between 3.10 and 3.12.
#if !MIN_VERSION_Cabal(3,12,0)
Nothing
#endif
checks' = checkPackage pkg'
#if !MIN_VERSION_Cabal(3,12,0)
Nothing
#endif
in case checks' \\ checks of
[] -> return ()
newchecks -> fail $ unlines (map ppPackageCheck newchecks)
#if !MIN_VERSION_Cabal(3,9,0)
where ppPackageCheck = explanation
#endif
checkGenericPackageDescription :: Bool -> Check GenericPackageDescription
checkGenericPackageDescription checkXRevision
(GenericPackageDescription descrA _versionA flagsA libsA sublibsA flibsA exesA testsA benchsA)
(GenericPackageDescription descrB _versionB flagsB libsB sublibsB flibsB exesB testsB benchsB) = do
checkPackageDescriptions checkXRevision descrA descrB
checkList "Cannot add or remove flags" checkFlag flagsA flagsB
checkMaybe "Cannot add or remove library sections"
(checkCondTree checkLibrary)
(withComponentName' (CLibName LMainLibName) <$> libsA)
(withComponentName' (CLibName LMainLibName) <$> libsB)
checkListAssoc "Cannot add or remove sub-library sections"
(checkCondTree checkLibrary)
(withComponentName (CLibName . LSubLibName) <$> sublibsA)
(withComponentName (CLibName . LSubLibName) <$> sublibsB)
checkListAssoc "Cannot add or remove foreign-library sections"
(checkCondTree checkForeignLib)
(withComponentName CFLibName <$> flibsA)
(withComponentName CFLibName <$> flibsB)
checkListAssoc "Cannot add or remove executable sections"
(checkCondTree checkExecutable)
(withComponentName CExeName <$> exesA)
(withComponentName CExeName <$> exesB)
checkListAssoc "Cannot add or remove test-suite sections"
(checkCondTree checkTestSuite)
(withComponentName CTestName <$> testsA)
(withComponentName CTestName <$> testsB)
checkListAssoc "Cannot add or remove benchmark sections"
(checkCondTree checkBenchmark)
(withComponentName CBenchName <$> benchsA)
(withComponentName CBenchName <$> benchsB)
where
withComponentName f (name, condTree) = (name, (f name, condTree))
withComponentName' f condTree = (f, condTree)
checkFlag :: Check PackageFlag
checkFlag flagOld flagNew = do
-- This check is applied via 'checkList' and for simplicity we
-- disallow renaming/reordering flags (even though reordering
-- would be fine semantically)
checkSame "Cannot change ordering of flags"
(flagName flagOld) (flagName flagNew)
-- Automatic flags' defaults may be changed as they don't make new
-- configurations reachable by the solver that weren't before
--
-- Moreover, automatic flags may be converted into manual flags
-- but not the other way round.
--
-- NB: We always allow to change the flag description as it has
-- purely informational value
when (flagManual flagOld) $ do
checkSame "Cannot change the default of a manual flag"
(flagDefault flagOld) (flagDefault flagNew)
checkSame "Cannot change a manual flag into an automatic flag"
(flagManual flagOld) (flagManual flagNew)
let fname = unFlagName (flagName flagOld)
changesOk ("type of flag '" ++ fname ++ "'")
(\b -> if b then "manual" else "automatic")
(flagManual flagOld) (flagManual flagNew)
changesOk ("default of flag '" ++ fname ++ "'") prettyShow
(flagDefault flagOld) (flagDefault flagNew)
changesOk ("description of flag '" ++ fname ++ "'") id
(flagDescription flagOld) (flagDescription flagNew)
checkPackageDescriptions :: Bool -> Check PackageDescription
checkPackageDescriptions checkXRevision
pdA@(PackageDescription
{ specVersion = _specVersionA
, package = packageIdA
, licenseRaw = licenseRawA
, licenseFiles = licenseFilesA
, copyright = copyrightA
, maintainer = maintainerA
, author = authorA
, stability = stabilityA
, testedWith = testedWithA
, homepage = homepageA
, pkgUrl = pkgUrlA
, bugReports = bugReportsA
, sourceRepos = sourceReposA
, synopsis = synopsisA
, description = descriptionA
, category = categoryA
, customFieldsPD = customFieldsPDA
, buildTypeRaw = buildTypeRawA
, setupBuildInfo = setupBuildInfoA
, library = _libraryA
, subLibraries = _subLibrariesA
, executables = _executablesA
, foreignLibs = _foreignLibsA
, testSuites = _testSuitesA
, benchmarks = _benchmarksA
, dataFiles = dataFilesA
, dataDir = dataDirA
, extraSrcFiles = extraSrcFilesA
, extraTmpFiles = extraTmpFilesA
, extraDocFiles = extraDocFilesA
})
pdB@(PackageDescription
{ specVersion = _specVersionB
, package = packageIdB
, licenseRaw = licenseRawB
, licenseFiles = licenseFilesB
, copyright = copyrightB
, maintainer = maintainerB
, author = authorB
, stability = stabilityB
, testedWith = testedWithB
, homepage = homepageB
, pkgUrl = pkgUrlB
, bugReports = bugReportsB
, sourceRepos = sourceReposB
, synopsis = synopsisB
, description = descriptionB
, category = categoryB
, customFieldsPD = customFieldsPDB
, buildTypeRaw = buildTypeRawB
, setupBuildInfo = setupBuildInfoB
, library = _libraryB
, subLibraries = _subLibrariesB
, executables = _executablesB
, foreignLibs = _foreignLibsB
, testSuites = _testSuitesB
, benchmarks = _benchmarksB
, dataFiles = dataFilesB
, dataDir = dataDirB
, extraSrcFiles = extraSrcFilesB
, extraTmpFiles = extraTmpFilesB
, extraDocFiles = extraDocFilesB
})
= do
checkSame "Don't be silly! You can't change the package name!"
(packageName packageIdA) (packageName packageIdB)
checkSame "You can't change the package version!"
(packageVersion packageIdA) (packageVersion packageIdB)
checkSame "Cannot change the license"
(licenseRawA, licenseFilesA) (licenseRawB, licenseFilesB)
changesOk "copyright" fromShortText copyrightA copyrightB
changesOk "maintainer" fromShortText maintainerA maintainerB
changesOk "author" fromShortText authorA authorB
changesOk "stability" fromShortText stabilityA stabilityB
changesOk' Trivial "tested-with" (show . ppTestedWith) testedWithA testedWithB
changesOk "homepage" fromShortText homepageA homepageB
checkSame "The package-url field is unused, don't bother changing it."
pkgUrlA pkgUrlB
changesOk "bug-reports" fromShortText bugReportsA bugReportsB
changesOkList changesOk "source-repository" (showFields noComment . (:[]) . ppSourceRepo)
sourceReposA sourceReposB
changesOk "synopsis" fromShortText synopsisA synopsisB
changesOk "description" fromShortText descriptionA descriptionB
changesOk "category" fromShortText categoryA categoryB
checkSame "Cannot change the build-type"
buildTypeRawA buildTypeRawB
checkSame "Cannot change the data files"
(dataFilesA, dataDirA) (dataFilesB, dataDirB)
checkSame "Changing extra-tmp-files is a bit pointless at this stage"
extraTmpFilesA extraTmpFilesB
checkSame "Changing extra-source-files would not make sense!"
extraSrcFilesA extraSrcFilesB
checkSame "You can't change the extra-doc-files."
extraDocFilesA extraDocFilesB
checkSame "Cannot change custom/extension fields"
(filter (\(f,_) -> f `notElem` ["x-revision","x-curation"]) customFieldsPDA)
(filter (\(f,_) -> f `notElem` ["x-revision","x-curation"]) customFieldsPDB)
checkSpecVersionRaw pdA pdB
checkSetupBuildInfo setupBuildInfoA setupBuildInfoB
when checkXRevision $ checkRevision customFieldsPDA customFieldsPDB
checkCuration customFieldsPDA customFieldsPDB
where
#if MIN_VERSION_Cabal(3,7,0)
noComment _ = NoComment
#else
noComment _ = []
#endif
checkSpecVersionRaw :: Check PackageDescription
checkSpecVersionRaw pdA pdB
| range110To120 specVersionA
, range110To120 specVersionB
= changesOk "cabal-version" showCabalSpecVersion specVersionA specVersionB
| otherwise
= checkSame "Cannot change the Cabal spec version"
specVersionA specVersionB
where
specVersionA = specVersion pdA
specVersionB = specVersion pdB
-- nothing interesting changed within the Cabal >=1.10 && <1.21 range
-- therefore we allow to change the spec version within this interval
range110To120 v = CabalSpecV1_10 >= v && v <= CabalSpecV1_20
checkRevision :: Check [(String, String)]
checkRevision customFieldsA customFieldsB =
checkSame ("The new x-revision must be " ++ show expectedRevision)
newRevision expectedRevision
where
oldRevision = getRevision customFieldsA
newRevision = getRevision customFieldsB
expectedRevision = oldRevision + 1
getRevision customFields =
case lookup "x-revision" customFields of
Just s | [(n,"")] <- reads s -> n :: Int
_ -> 0
checkCuration :: Check [(String, String)]
checkCuration customFieldsA customFieldsB =
checkNotPresent "Revised metadata must not contain an x-curation field as revisions necessarily imply curation, and revising an uncurated package adopts it into the curated layer." oldCuration newCuration
where
oldCuration = lookup "x-curation" customFieldsA
newCuration = lookup "x-curation" customFieldsB
checkCondTree :: (ComponentName -> Check a) -> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree checkElem (componentName, condNodeA)
(_ , condNodeB) =
checkCondNode condNodeA condNodeB
where
checkCondNode (CondNode dataA constraintsA componentsA)
(CondNode dataB constraintsB componentsB) = do
checkDependencies componentName constraintsA constraintsB
checkList "Cannot add or remove 'if' conditionals"
checkComponent componentsA componentsB
checkElem componentName dataA dataB
checkComponent (CondBranch condA ifPartA thenPartA)
(CondBranch condB ifPartB thenPartB) = do
checkSame "Cannot change the 'if' condition expressions"
condA condB
checkCondNode ifPartA ifPartB
checkMaybe "Cannot add or remove the 'else' part in conditionals"
checkCondNode thenPartA thenPartB
checkDependencies :: forall d vr. (Pretty d, IsDependency vr d) => ComponentName -> Check [d]
checkDependencies componentName ds1 ds2 = do
forM_ removed $ \dep -> do
fail (unwords [ "Cannot remove existing", depKind, "on"
, depKeyShow dproxy (depKey dep), "in", cnameStr, " component"])
forM_ added $ \dep ->
if depInAddWhitelist dep
then logChange (Change Normal (unwords ["added the", cnameStr, "component's"
, depKind, "on"]) "" (prettyShow dep))
else fail (unwords [ "Cannot add new", depKind, "on"
, depKeyShow dproxy (depKey dep)
, "in", cnameStr, "component"])
forM_ changed $ \(depk, (verA, verB)) -> do
changesOk (unwords ["the", cnameStr, "component's", depKind, "on"
, depKeyShow dproxy depk])
prettyShow verA verB
where
(removed, changed, added) = computeCanonDepChange ds1 ds2
dproxy :: Proxy d
dproxy = Proxy
cnameStr = showComponentName componentName
depKind = depTypeName dproxy ++ " dependency"
class (Ord (DepKey d), Pretty vr, Eq vr) => IsDependency vr d | d -> vr where
type DepKey d
depTypeName :: Proxy d -> String
depKey :: d -> DepKey d
depKeyShow :: Proxy d -> DepKey d -> String
depVerRg :: d -> vr
reconstructDep :: DepKey d -> vr -> d
depInAddWhitelist :: d -> Bool
depInAddWhitelist _ = False
intersectVr :: Proxy d -> vr -> vr -> vr
instance IsDependency VersionRange Dependency where
type DepKey Dependency = PackageName
depTypeName Proxy = "library"
depKey (Dependency pkgname _ _) = pkgname
depKeyShow Proxy = prettyShow''
depVerRg (Dependency _ vr _) = vr
reconstructDep = \n vr -> Dependency n vr mainLibSet
depInAddWhitelist (Dependency pn _ _) = pn `elem`
-- Special case: there are some pretty weird broken packages out there, see
-- https://github.com/haskell/hackage-server/issues/303
-- which need us to add a new dep on `base`
[ mkPackageName "base"
-- See also https://github.com/haskell/hackage-server/issues/472
--
-- this is mostly to allow to add dependencies on `base-orphans == 0`
-- as otherwise we have no way to express when a package is
-- incompatible with the recently introduced `base-orphans` package
-- which started adopting orphan instances; in the long-term we need a
-- more general approach to this, as otherwise we'll end up adding
-- ad-hoc exceptions like this one. See e.g.
-- https://github.com/haskell/cabal/issues/3061
--
, mkPackageName "base-orphans"
]
intersectVr _ = intersectVersionRanges
instance IsDependency VersionRange ExeDependency where
type DepKey ExeDependency = (PackageName,UnqualComponentName)
depTypeName Proxy = "tool"
depKey (ExeDependency pkgname cn _) = (pkgname,cn)
depKeyShow Proxy (pkgname,cn) = concat ["'", prettyShow pkgname, ":", prettyShow cn, "'"]
depVerRg (ExeDependency _ _ vr) = vr
reconstructDep (pkgname,cn) = ExeDependency pkgname cn
intersectVr _ = intersectVersionRanges
instance IsDependency VersionRange LegacyExeDependency where
type DepKey LegacyExeDependency = String
depTypeName Proxy = "legacy-tool"
depKey (LegacyExeDependency tname _) = tname
depKeyShow Proxy tname = "'" ++ tname ++ "'"
depVerRg (LegacyExeDependency _ vr) = vr
reconstructDep = LegacyExeDependency
intersectVr _ = intersectVersionRanges
depInAddWhitelist (LegacyExeDependency pn _) = pn `elem`
-- list of trusted tools cabal supports w/o explicit build-tools
-- c.f. Distribution.Simple.BuildToolDepends.desugarBuildTool
-- and 'knownSuffixHandlers' in "Distribution.Client.Init.Heuristics"
[ "alex"
, "c2hs"
, "cpphs"
, "greencard"
, "happy"
, "hsc2hs"
]
instance IsDependency PkgconfigVersionRange PkgconfigDependency where
type DepKey PkgconfigDependency = PkgconfigName
depTypeName Proxy = "pkg-config"
depKey (PkgconfigDependency pkgname _) = pkgname
depKeyShow Proxy = prettyShow''
depVerRg (PkgconfigDependency _ vr) = vr
reconstructDep = PkgconfigDependency
intersectVr _ = PcIntersectVersionRanges
-- The result tuple represents the 3 canonicalised dependency
-- (removed deps (old ranges), retained deps (old & new ranges), added deps (new ranges))
-- or expressed as set-operations: (A \ B, (A ∩ B), B \ A)
computeCanonDepChange :: forall vr d. IsDependency vr d => [d] -> [d] -> ([d],[(DepKey d,(vr,vr))],[d])
computeCanonDepChange depsA depsB
= ( mapToDeps (a `Map.difference` b)
, Map.toList $ Map.intersectionWith (,) a b
, mapToDeps (b `Map.difference` a)
)
where
a = depsToMapWithCanonVerRange depsA
b = depsToMapWithCanonVerRange depsB
depsToMapWithCanonVerRange
= Map.fromListWith (flip $ intersectVr (Proxy :: Proxy d)) .
map (\d -> (depKey d, depVerRg d))
mapToDeps
= map (\(pkgname, verrange) -> reconstructDep pkgname verrange) . Map.toList
checkSetupBuildInfo :: Check (Maybe SetupBuildInfo)
checkSetupBuildInfo Nothing Nothing = return ()
checkSetupBuildInfo (Just _) Nothing =
fail "Cannot remove a 'custom-setup' section"
checkSetupBuildInfo Nothing (Just (SetupBuildInfo setupDependsA _internalA)) =
logChange $ Change Normal
"added a 'custom-setup' section with 'setup-depends'"
"[implicit]" (intercalate ", " (map prettyShow setupDependsA))
checkSetupBuildInfo (Just (SetupBuildInfo setupDependsA _internalA))
(Just (SetupBuildInfo setupDependsB _internalB)) = do
forM_ removed $ \dep ->
logChange $ Change Normal "removed 'custom-setup' dependency on" (prettyShow dep) ""
forM_ added $ \dep ->
logChange $ Change Normal "added 'custom-setup' dependency on" "" (prettyShow dep)
forM_ changed $ \(pkgn, (verA, verB)) ->
changesOk ("the 'custom-setup' dependency on " ++ prettyShow'' pkgn)
prettyShow verA verB
where
(removed, changed, added) =
computeCanonDepChange setupDependsA setupDependsB
checkLibrary :: ComponentName -> Check Library
checkLibrary componentName
(Library modulesA reexportedA requiredSigsA exposedSigsA
exposedA visibilityA buildInfoA)
(Library modulesB reexportedB requiredSigsB exposedSigsB
exposedB visibilityB buildInfoB) = do
checkSame "Cannot change the exposed modules" modulesA modulesB
checkSame "Cannot change the re-exported modules" reexportedA reexportedB
checkSame "Cannot change the required signatures" requiredSigsA requiredSigsB
checkSame "Cannot change the exposed signatures" exposedSigsA exposedSigsB
checkSame "Cannot change the package exposed status" exposedA exposedB
checkSame "Cannot change the package visibility" visibilityA visibilityB
checkBuildInfo componentName buildInfoA buildInfoB
checkForeignLib :: ComponentName -> Check ForeignLib
checkForeignLib componentName
(ForeignLib nameA typeA optionsA buildInfoA verA verLinuxA modDefA)
(ForeignLib nameB typeB optionsB buildInfoB verB verLinuxB modDefB) = do
checkSame "Cannot change the foreign library name" nameA nameB
checkSame "Cannot change the foreign library type" typeA typeB
checkSame "Cannot change the foreign library options" optionsA optionsB
checkSame "Cannot change the foreign library version" verA verB
checkSame "Cannot change the foreign library version for Linux" verLinuxA verLinuxB
checkSame "Cannot change the module definition files" modDefA modDefB
checkBuildInfo componentName buildInfoA buildInfoB
checkExecutable :: ComponentName -> Check Executable
checkExecutable componentName
(Executable _nameA pathA scopeA buildInfoA)
(Executable _nameB pathB scopeB buildInfoB) = do
checkSame "Cannot change build information" pathA pathB
checkSame "Cannot change executable scope" scopeA scopeB
checkBuildInfo componentName buildInfoA buildInfoB
checkTestSuite :: ComponentName -> Check TestSuite
checkTestSuite componentName
#if MIN_VERSION_Cabal(3,7,0)
(TestSuite _nameA interfaceA buildInfoA testGeneratorsA)
(TestSuite _nameB interfaceB buildInfoB testGeneratorsB)
#else
(TestSuite _nameA interfaceA buildInfoA)
(TestSuite _nameB interfaceB buildInfoB)
#endif
= do
checkSame "Cannot change test-suite type" interfaceA interfaceB
checkBuildInfo componentName buildInfoA buildInfoB
#if MIN_VERSION_Cabal(3,7,0)
-- @test-generators@
checkSame "Cannot change test-generators" testGeneratorsA testGeneratorsB
#endif
checkBenchmark :: ComponentName -> Check Benchmark
checkBenchmark componentName
(Benchmark _nameA interfaceA buildInfoA)
(Benchmark _nameB interfaceB buildInfoB) = do
checkSame "Cannot change benchmark type" interfaceA interfaceB
checkBuildInfo componentName buildInfoA buildInfoB
checkBuildInfo :: ComponentName -> Check BuildInfo
checkBuildInfo componentName biA biB = do
-- @other-extension@
changesOkSet ("'other-extensions' in " ++ showComponentName componentName ++ " component")
prettyShow
(Set.fromList $ otherExtensions biA) (Set.fromList $ otherExtensions biB)
-- @buildable@
changesOk ("'buildable' in " ++ showComponentName componentName ++ " component") prettyShow
(buildable biA) (buildable biB)
-- @build-tool-depends@
checkDependencies componentName
(buildToolDepends biA)
(buildToolDepends biB)
-- @build-tools@
checkDependencies componentName
(buildTools biA)
(buildTools biB)
-- @pkgconfig-depends@
checkDependencies componentName
(pkgconfigDepends biA)
(pkgconfigDepends biB)
checkSame "Cannot change build information (just the dependency version constraints)"
(biA { targetBuildDepends = [], otherExtensions = [], buildTools = [], buildToolDepends = [], pkgconfigDepends = [], buildable = True })
(biB { targetBuildDepends = [], otherExtensions = [], buildTools = [], buildToolDepends = [], pkgconfigDepends = [], buildable = True })
changesOk' :: Eq a => Severity -> String -> (a -> String) -> Check a
changesOk' rel what render a b
| a == b = return ()
| otherwise = logChange (Change rel what (render a) (render b))
changesOk :: Eq a => String -> (a -> String) -> Check a
changesOk = changesOk' Normal
changesOkList :: (String -> (a -> String) -> Check a)
-> String -> (a -> String) -> Check [a]
changesOkList changesOkElem what render = go
where
go [] [] = return ()
go (a:_) [] = logChange (Change Normal ("removed " ++ what) (render a) "")
go [] (b:_) = logChange (Change Normal ("added " ++ what) "" (render b))
go (a:as) (b:bs) = changesOkElem what render a b >> go as bs
changesOkSet :: Ord a => String -> (a -> String) -> Check (Set.Set a)
changesOkSet what render old new = do
unless (Set.null removed) $
logChange (Change Normal ("removed " ++ what) (renderSet removed) "")
unless (Set.null added) $
logChange (Change Normal ("added " ++ what) "" (renderSet added))
return ()
where
added = new Set.\\ old
removed = old Set.\\ new
renderSet = intercalate ", " . map render . Set.toList
-- | Single-quote-wrapping 'prettyShow'
prettyShow'' :: Pretty a => a -> String
prettyShow'' x = "'" ++ prettyShow x ++ "'"
checkSame :: Eq a => String -> Check a
checkSame msg x y | x == y = return ()
| otherwise = fail msg
checkList :: String -> Check a -> Check [a]
checkList _ _ [] [] = return ()
checkList msg checkElem (x:xs) (y:ys) = checkElem x y
>> checkList msg checkElem xs ys
checkList msg _ _ _ = fail msg
checkListAssoc :: Eq b => String -> Check a -> Check [(b,a)]
checkListAssoc _ _ [] [] = return ()
checkListAssoc msg checkElem ((kx,x):xs) ((ky,y):ys)
| kx == ky = checkElem x y
>> checkListAssoc msg checkElem xs ys
| otherwise = fail msg
checkListAssoc msg _ _ _ = fail msg
checkNotPresent :: String -> Check (Maybe String)
checkNotPresent msg _ (Just _) = fail msg
checkNotPresent _ _ Nothing = return ()
checkMaybe :: String -> Check a -> Check (Maybe a)
checkMaybe _ _ Nothing Nothing = return ()
checkMaybe _ check (Just x) (Just y) = check x y
checkMaybe msg _ _ _ = fail msg
ppTestedWith :: [(CompilerFlavor, VersionRange)] -> Doc
ppTestedWith = hsep . punctuate colon . map (uncurry ppPair)
where
ppPair compiler vr = text (prettyShow compiler) <+> text (prettyShow vr)
ppSourceRepo :: SourceRepo -> PrettyField ()
ppSourceRepo repo = PrettySection () "source-repository" [pretty kind] $
prettyFieldGrammar cabalSpecLatest (sourceRepoFieldGrammar kind) repo
where
kind = repoKind repo
-- TODO: Verify that we don't need to worry about UTF8
-- | Insert or update \"x-revision:\" field
insertRevisionField :: Int -> ByteString -> ByteString
insertRevisionField rev
| rev == 1 = LBS8.unlines . insertAfterVersion . LBS8.lines
| otherwise = LBS8.unlines . replaceRevision . LBS8.lines
where
replaceRevision [] = []
replaceRevision (ln:lns)
| isField (LBS8.pack "x-revision") ln
= LBS8.pack ("x-revision: " ++ show rev) : lns
| otherwise
= ln : replaceRevision lns
insertAfterVersion [] = []
insertAfterVersion (ln:lns)
| isField (LBS8.pack "version") ln
= ln : LBS8.pack ("x-revision: " ++ show rev) : lns
| otherwise
= ln : insertAfterVersion lns
isField nm ln
| LBS8.isPrefixOf nm (LBS8.map Char.toLower ln)
, let (_, t) = LBS8.span (\c -> c == ' ' || c == '\t')
(LBS8.drop (LBS8.length nm) ln)
, Just (':',_) <- LBS8.uncons t
= True
| otherwise = False