{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}

-- |
-- Module      :  Distribution.Server.Util.CabalRevisions
-- Copyright   :  Duncan Coutts et al.
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Maintainer  :  libraries@haskell.org
-- 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)
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 :: ByteString -> ByteString -> Either String [Change]
diffCabalRevisions = Bool -> ByteString -> ByteString -> Either String [Change]
diffCabalRevisions' Bool
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' :: Bool -> ByteString -> ByteString -> Either String [Change]
diffCabalRevisions' Bool
checkXRevision ByteString
oldVersion ByteString
newRevision = CheckM () -> Either String [Change]
runCheck (CheckM () -> Either String [Change])
-> CheckM () -> Either String [Change]
forall a b. (a -> b) -> a -> b
$
    Bool -> Check ByteString
checkCabalFileRevision Bool
checkXRevision ByteString
oldVersion ByteString
newRevision

newtype CheckM a = CheckM { CheckM a -> ExceptT String (Writer [Change]) a
unCheckM :: ExceptT String (Writer [Change]) a }
    deriving (a -> CheckM b -> CheckM a
(a -> b) -> CheckM a -> CheckM b
(forall a b. (a -> b) -> CheckM a -> CheckM b)
-> (forall a b. a -> CheckM b -> CheckM a) -> Functor CheckM
forall a b. a -> CheckM b -> CheckM a
forall a b. (a -> b) -> CheckM a -> CheckM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CheckM b -> CheckM a
$c<$ :: forall a b. a -> CheckM b -> CheckM a
fmap :: (a -> b) -> CheckM a -> CheckM b
$cfmap :: forall a b. (a -> b) -> CheckM a -> CheckM b
Functor, Functor CheckM
a -> CheckM a
Functor CheckM
-> (forall a. a -> CheckM a)
-> (forall a b. CheckM (a -> b) -> CheckM a -> CheckM b)
-> (forall a b c.
    (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c)
-> (forall a b. CheckM a -> CheckM b -> CheckM b)
-> (forall a b. CheckM a -> CheckM b -> CheckM a)
-> Applicative CheckM
CheckM a -> CheckM b -> CheckM b
CheckM a -> CheckM b -> CheckM a
CheckM (a -> b) -> CheckM a -> CheckM b
(a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
forall a. a -> CheckM a
forall a b. CheckM a -> CheckM b -> CheckM a
forall a b. CheckM a -> CheckM b -> CheckM b
forall a b. CheckM (a -> b) -> CheckM a -> CheckM b
forall a b c. (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CheckM a -> CheckM b -> CheckM a
$c<* :: forall a b. CheckM a -> CheckM b -> CheckM a
*> :: CheckM a -> CheckM b -> CheckM b
$c*> :: forall a b. CheckM a -> CheckM b -> CheckM b
liftA2 :: (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
$cliftA2 :: forall a b c. (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
<*> :: CheckM (a -> b) -> CheckM a -> CheckM b
$c<*> :: forall a b. CheckM (a -> b) -> CheckM a -> CheckM b
pure :: a -> CheckM a
$cpure :: forall a. a -> CheckM a
$cp1Applicative :: Functor CheckM
Applicative)

runCheck :: CheckM () -> Either String [Change]
runCheck :: CheckM () -> Either String [Change]
runCheck CheckM ()
c = case Writer [Change] (Either String ()) -> (Either String (), [Change])
forall w a. Writer w a -> (a, w)
runWriter (Writer [Change] (Either String ())
 -> (Either String (), [Change]))
-> (CheckM () -> Writer [Change] (Either String ()))
-> CheckM ()
-> (Either String (), [Change])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String (Writer [Change]) ()
-> Writer [Change] (Either String ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (Writer [Change]) ()
 -> Writer [Change] (Either String ()))
-> (CheckM () -> ExceptT String (Writer [Change]) ())
-> CheckM ()
-> Writer [Change] (Either String ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckM () -> ExceptT String (Writer [Change]) ()
forall a. CheckM a -> ExceptT String (Writer [Change]) a
unCheckM (CheckM () -> (Either String (), [Change]))
-> CheckM () -> (Either String (), [Change])
forall a b. (a -> b) -> a -> b
$ CheckM ()
c of
               (Left String
err, [Change]
_      ) -> String -> Either String [Change]
forall a b. a -> Either a b
Left String
err
               (Right (), [Change]
changes)
                 | (Change -> Severity) -> [Change] -> Severity
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Change -> Severity
changeSeverity [Change]
changes Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
Trivial -> [Change] -> Either String [Change]
forall a b. b -> Either a b
Right [Change]
changes
                 | Bool
otherwise ->
                   String -> Either String [Change]
forall a b. a -> Either a b
Left String
"Only trivial changes, don't bother making this revision."

changeSeverity :: Change -> Severity
changeSeverity :: Change -> Severity
changeSeverity (Change Severity
s String
_ String
_ String
_) = Severity
s

instance Monad CheckM where
  return :: a -> CheckM a
return         = a -> CheckM a
forall (f :: * -> *) a. Applicative f => a -> f a
Control.Applicative.pure
  CheckM ExceptT String (Writer [Change]) a
m >>= :: CheckM a -> (a -> CheckM b) -> CheckM b
>>= a -> CheckM b
f = ExceptT String (Writer [Change]) b -> CheckM b
forall a. ExceptT String (Writer [Change]) a -> CheckM a
CheckM (ExceptT String (Writer [Change]) a
m ExceptT String (Writer [Change]) a
-> (a -> ExceptT String (Writer [Change]) b)
-> ExceptT String (Writer [Change]) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CheckM b -> ExceptT String (Writer [Change]) b
forall a. CheckM a -> ExceptT String (Writer [Change]) a
unCheckM (CheckM b -> ExceptT String (Writer [Change]) b)
-> (a -> CheckM b) -> a -> ExceptT String (Writer [Change]) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CheckM b
f)

#if !MIN_VERSION_base(4,13,0)
  fail = Fail.fail
#endif

instance Fail.MonadFail CheckM where
  fail :: String -> CheckM a
fail           = ExceptT String (Writer [Change]) a -> CheckM a
forall a. ExceptT String (Writer [Change]) a -> CheckM a
CheckM (ExceptT String (Writer [Change]) a -> CheckM a)
-> (String -> ExceptT String (Writer [Change]) a)
-> String
-> CheckM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String (Writer [Change]) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
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 (Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c== :: Severity -> Severity -> Bool
Eq, Eq Severity
Eq Severity
-> (Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmax :: Severity -> Severity -> Severity
>= :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c< :: Severity -> Severity -> Bool
compare :: Severity -> Severity -> Ordering
$ccompare :: Severity -> Severity -> Ordering
$cp1Ord :: Eq Severity
Ord, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show, Int -> Severity
Severity -> Int
Severity -> [Severity]
Severity -> Severity
Severity -> Severity -> [Severity]
Severity -> Severity -> Severity -> [Severity]
(Severity -> Severity)
-> (Severity -> Severity)
-> (Int -> Severity)
-> (Severity -> Int)
-> (Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> Severity -> [Severity])
-> Enum Severity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
$cenumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
enumFromTo :: Severity -> Severity -> [Severity]
$cenumFromTo :: Severity -> Severity -> [Severity]
enumFromThen :: Severity -> Severity -> [Severity]
$cenumFromThen :: Severity -> Severity -> [Severity]
enumFrom :: Severity -> [Severity]
$cenumFrom :: Severity -> [Severity]
fromEnum :: Severity -> Int
$cfromEnum :: Severity -> Int
toEnum :: Int -> Severity
$ctoEnum :: Int -> Severity
pred :: Severity -> Severity
$cpred :: Severity -> Severity
succ :: Severity -> Severity
$csucc :: Severity -> Severity
Enum, Severity
Severity -> Severity -> Bounded Severity
forall a. a -> a -> Bounded a
maxBound :: Severity
$cmaxBound :: Severity
minBound :: Severity
$cminBound :: Severity
Bounded)

instance S.Semigroup Severity where
    Severity
Normal  <> :: Severity -> Severity -> Severity
<> Severity
_ = Severity
Normal
    Severity
Trivial <> Severity
x = Severity
x

-- | "Max" monoid.
instance M.Monoid Severity where
    mempty :: Severity
mempty = Severity
Trivial
    mappend :: Severity -> Severity -> Severity
mappend = Severity -> Severity -> Severity
forall a. Semigroup a => a -> a -> a
(S.<>)

data Change = Change Severity String String String -- severity, what, from, to
  deriving Int -> Change -> ShowS
[Change] -> ShowS
Change -> String
(Int -> Change -> ShowS)
-> (Change -> String) -> ([Change] -> ShowS) -> Show Change
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Change] -> ShowS
$cshowList :: [Change] -> ShowS
show :: Change -> String
$cshow :: Change -> String
showsPrec :: Int -> Change -> ShowS
$cshowsPrec :: Int -> Change -> ShowS
Show



logChange :: Change -> CheckM ()
logChange :: Change -> CheckM ()
logChange Change
change = ExceptT String (Writer [Change]) () -> CheckM ()
forall a. ExceptT String (Writer [Change]) a -> CheckM a
CheckM ([Change] -> ExceptT String (Writer [Change]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Change
change])

type Check a = a -> a -> CheckM ()

checkCabalFileRevision :: Bool -> Check BS.ByteString
checkCabalFileRevision :: Bool -> Check ByteString
checkCabalFileRevision Bool
checkXRevision ByteString
old ByteString
new = do
    (GenericPackageDescription
pkg,  [PWarning]
warns)  <- ByteString -> CheckM (GenericPackageDescription, [PWarning])
forall (m :: * -> *).
MonadFail m =>
ByteString -> m (GenericPackageDescription, [PWarning])
parseCabalFile ByteString
old
    (GenericPackageDescription
pkg', [PWarning]
warns') <- ByteString -> CheckM (GenericPackageDescription, [PWarning])
forall (m :: * -> *).
MonadFail m =>
ByteString -> m (GenericPackageDescription, [PWarning])
parseCabalFile ByteString
new

    let pkgid :: PackageIdentifier
pkgid    = GenericPackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
pkg
        filename :: String
filename = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".cabal"

    Bool -> Check GenericPackageDescription
checkGenericPackageDescription Bool
checkXRevision GenericPackageDescription
pkg GenericPackageDescription
pkg'
    String -> Check [PWarning]
checkParserWarnings String
filename [PWarning]
warns [PWarning]
warns'
    Check GenericPackageDescription
forall (m :: * -> *).
MonadFail m =>
GenericPackageDescription -> GenericPackageDescription -> m ()
checkPackageChecks  GenericPackageDescription
pkg   GenericPackageDescription
pkg'

  where
    parseCabalFile :: ByteString -> m (GenericPackageDescription, [PWarning])
parseCabalFile ByteString
fileContent =
      case ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ParseResult GenericPackageDescription
 -> ([PWarning],
     Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription ByteString
fileContent of
        ([PWarning]
warnings,  Right GenericPackageDescription
pkg) -> (GenericPackageDescription, [PWarning])
-> m (GenericPackageDescription, [PWarning])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription
pkg, [PWarning]
warnings)
        ([PWarning]
_warnings, Left (Maybe Version
_mver, NonEmpty PError
errs)) -> do
            NonEmpty PError -> (PError -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty PError
errs ((PError -> m Any) -> m ()) -> (PError -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \PError
err -> String -> m Any
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PError -> String
showPError String
"-" PError
err)
            String -> m (GenericPackageDescription, [PWarning])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no better error"

    -- new PWarning isn't Eq
    differenceBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
    differenceBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
differenceBy a -> a -> Bool
eq = ([a] -> a -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> [a] -> [a]) -> [a] -> a -> [a])
-> (a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> a -> [a] -> [a]
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy a -> a -> Bool
eq)

    -- things can move, pos can change
    eqPWarning :: PWarning -> PWarning -> Bool
    eqPWarning :: PWarning -> PWarning -> Bool
eqPWarning (PWarning PWarnType
t Position
_pos String
s) (PWarning PWarnType
t' Position
_pos' String
s') =
        PWarnType
t PWarnType -> PWarnType -> Bool
forall a. Eq a => a -> a -> Bool
== PWarnType
t' Bool -> Bool -> Bool
&& String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'

    checkParserWarnings :: FilePath -> Check [PWarning]
    checkParserWarnings :: String -> Check [PWarning]
checkParserWarnings String
filename [PWarning]
warns [PWarning]
warns' =
      case (PWarning -> PWarning -> Bool)
-> [PWarning] -> [PWarning] -> [PWarning]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
differenceBy PWarning -> PWarning -> Bool
eqPWarning [PWarning]
warns' [PWarning]
warns of
        []       -> () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [PWarning]
newwarns -> String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> CheckM ()) -> String -> CheckM ()
forall a b. (a -> b) -> a -> b
$ String
"New parse warning: "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
filename) [PWarning]
newwarns)

    checkPackageChecks :: GenericPackageDescription -> GenericPackageDescription -> m ()
checkPackageChecks GenericPackageDescription
pkg GenericPackageDescription
pkg' =
      let checks :: [PackageCheck]
checks  = GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
checkPackage GenericPackageDescription
pkg  Maybe PackageDescription
forall a. Maybe a
Nothing
          checks' :: [PackageCheck]
checks' = GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
checkPackage GenericPackageDescription
pkg' Maybe PackageDescription
forall a. Maybe a
Nothing
       in case [PackageCheck]
checks' [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. Eq a => [a] -> [a] -> [a]
\\ [PackageCheck]
checks of
            []        -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [PackageCheck]
newchecks -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ((PackageCheck -> String) -> [PackageCheck] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageCheck -> String
explanation [PackageCheck]
newchecks)

checkGenericPackageDescription :: Bool -> Check GenericPackageDescription
checkGenericPackageDescription :: Bool -> Check GenericPackageDescription
checkGenericPackageDescription Bool
checkXRevision
    (GenericPackageDescription PackageDescription
descrA Maybe Version
_versionA [PackageFlag]
flagsA Maybe (CondTree ConfVar [Dependency] Library)
libsA [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
sublibsA [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
flibsA [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exesA [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
testsA [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benchsA)
    (GenericPackageDescription PackageDescription
descrB Maybe Version
_versionB [PackageFlag]
flagsB Maybe (CondTree ConfVar [Dependency] Library)
libsB [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
sublibsB [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
flibsB [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exesB [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
testsB [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benchsB) = do

    Bool -> Check PackageDescription
checkPackageDescriptions Bool
checkXRevision PackageDescription
descrA PackageDescription
descrB

    String -> Check PackageFlag -> Check [PackageFlag]
forall a. String -> Check a -> Check [a]
checkList String
"Cannot add or remove flags" Check PackageFlag
checkFlag [PackageFlag]
flagsA [PackageFlag]
flagsB

    String
-> Check (ComponentName, CondTree ConfVar [Dependency] Library)
-> Check
     (Maybe (ComponentName, CondTree ConfVar [Dependency] Library))
forall a. String -> Check a -> Check (Maybe a)
checkMaybe String
"Cannot add or remove library sections"
      ((ComponentName -> Check Library)
-> Check (ComponentName, CondTree ConfVar [Dependency] Library)
forall a.
(ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check Library
checkLibrary)
      (ComponentName
-> CondTree ConfVar [Dependency] Library
-> (ComponentName, CondTree ConfVar [Dependency] Library)
forall a b. a -> b -> (a, b)
withComponentName' (LibraryName -> ComponentName
CLibName LibraryName
LMainLibName) (CondTree ConfVar [Dependency] Library
 -> (ComponentName, CondTree ConfVar [Dependency] Library))
-> Maybe (CondTree ConfVar [Dependency] Library)
-> Maybe (ComponentName, CondTree ConfVar [Dependency] Library)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CondTree ConfVar [Dependency] Library)
libsA)
      (ComponentName
-> CondTree ConfVar [Dependency] Library
-> (ComponentName, CondTree ConfVar [Dependency] Library)
forall a b. a -> b -> (a, b)
withComponentName' (LibraryName -> ComponentName
CLibName LibraryName
LMainLibName) (CondTree ConfVar [Dependency] Library
 -> (ComponentName, CondTree ConfVar [Dependency] Library))
-> Maybe (CondTree ConfVar [Dependency] Library)
-> Maybe (ComponentName, CondTree ConfVar [Dependency] Library)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CondTree ConfVar [Dependency] Library)
libsB)

    String
-> Check (ComponentName, CondTree ConfVar [Dependency] Library)
-> Check
     [(UnqualComponentName,
       (ComponentName, CondTree ConfVar [Dependency] Library))]
forall b a. Eq b => String -> Check a -> Check [(b, a)]
checkListAssoc String
"Cannot add or remove sub-library sections"
      ((ComponentName -> Check Library)
-> Check (ComponentName, CondTree ConfVar [Dependency] Library)
forall a.
(ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check Library
checkLibrary)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] Library))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName (LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName)
-> (UnqualComponentName -> LibraryName)
-> UnqualComponentName
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> LibraryName
LSubLibName) ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Library)))
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Library))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
sublibsA)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] Library))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName (LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName)
-> (UnqualComponentName -> LibraryName)
-> UnqualComponentName
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> LibraryName
LSubLibName) ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Library)))
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Library))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
sublibsB)

    String
-> Check (ComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> Check
     [(UnqualComponentName,
       (ComponentName, CondTree ConfVar [Dependency] ForeignLib))]
forall b a. Eq b => String -> Check a -> Check [(b, a)]
checkListAssoc String
"Cannot add or remove foreign-library sections"
      ((ComponentName -> Check ForeignLib)
-> Check (ComponentName, CondTree ConfVar [Dependency] ForeignLib)
forall a.
(ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check ForeignLib
checkForeignLib)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] ForeignLib))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CFLibName ((UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] ForeignLib)))
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] ForeignLib))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
flibsA)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] ForeignLib))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CFLibName ((UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] ForeignLib)))
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] ForeignLib))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
flibsB)

    String
-> Check (ComponentName, CondTree ConfVar [Dependency] Executable)
-> Check
     [(UnqualComponentName,
       (ComponentName, CondTree ConfVar [Dependency] Executable))]
forall b a. Eq b => String -> Check a -> Check [(b, a)]
checkListAssoc String
"Cannot add or remove executable sections"
      ((ComponentName -> Check Executable)
-> Check (ComponentName, CondTree ConfVar [Dependency] Executable)
forall a.
(ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check Executable
checkExecutable)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] Executable))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CExeName ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Executable)))
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Executable))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exesA)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] Executable))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CExeName ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Executable)))
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Executable))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exesB)

    String
-> Check (ComponentName, CondTree ConfVar [Dependency] TestSuite)
-> Check
     [(UnqualComponentName,
       (ComponentName, CondTree ConfVar [Dependency] TestSuite))]
forall b a. Eq b => String -> Check a -> Check [(b, a)]
checkListAssoc String
"Cannot add or remove test-suite sections"
      ((ComponentName -> Check TestSuite)
-> Check (ComponentName, CondTree ConfVar [Dependency] TestSuite)
forall a.
(ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check TestSuite
checkTestSuite)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] TestSuite))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CTestName ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] TestSuite)))
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] TestSuite))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
testsA)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] TestSuite))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CTestName ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] TestSuite)))
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] TestSuite))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
testsB)

    String
-> Check (ComponentName, CondTree ConfVar [Dependency] Benchmark)
-> Check
     [(UnqualComponentName,
       (ComponentName, CondTree ConfVar [Dependency] Benchmark))]
forall b a. Eq b => String -> Check a -> Check [(b, a)]
checkListAssoc String
"Cannot add or remove benchmark sections"
      ((ComponentName -> Check Benchmark)
-> Check (ComponentName, CondTree ConfVar [Dependency] Benchmark)
forall a.
(ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check Benchmark
checkBenchmark)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] Benchmark))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CBenchName ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Benchmark)))
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Benchmark))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benchsA)
      ((UnqualComponentName -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> (UnqualComponentName,
    (ComponentName, CondTree ConfVar [Dependency] Benchmark))
forall t a b. (t -> a) -> (t, b) -> (t, (a, b))
withComponentName UnqualComponentName -> ComponentName
CBenchName ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> (UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Benchmark)))
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [(UnqualComponentName,
     (ComponentName, CondTree ConfVar [Dependency] Benchmark))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benchsB)
  where
    withComponentName :: (t -> a) -> (t, b) -> (t, (a, b))
withComponentName  t -> a
f (t
name, b
condTree) = (t
name, (t -> a
f t
name, b
condTree))
    withComponentName' :: a -> b -> (a, b)
withComponentName' a
f        b
condTree  = (a
f,             b
condTree)


checkFlag :: Check PackageFlag
checkFlag :: Check PackageFlag
checkFlag PackageFlag
flagOld PackageFlag
flagNew = do
    -- This check is applied via 'checkList' and for simplicity we
    -- disallow renaming/reordering flags (even though reordering
    -- would be fine semantically)
    String -> Check FlagName
forall a. Eq a => String -> Check a
checkSame String
"Cannot change ordering of flags"
              (PackageFlag -> FlagName
flagName PackageFlag
flagOld) (PackageFlag -> FlagName
flagName PackageFlag
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
    Bool -> CheckM () -> CheckM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageFlag -> Bool
flagManual PackageFlag
flagOld) (CheckM () -> CheckM ()) -> CheckM () -> CheckM ()
forall a b. (a -> b) -> a -> b
$ do
        String -> Check Bool
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the default of a manual flag"
                  (PackageFlag -> Bool
flagDefault PackageFlag
flagOld) (PackageFlag -> Bool
flagDefault PackageFlag
flagNew)

        String -> Check Bool
forall a. Eq a => String -> Check a
checkSame String
"Cannot change a manual flag into an automatic flag"
                  (PackageFlag -> Bool
flagManual PackageFlag
flagOld) (PackageFlag -> Bool
flagManual PackageFlag
flagNew)

    let fname :: String
fname = FlagName -> String
unFlagName (PackageFlag -> FlagName
flagName PackageFlag
flagOld)

    String -> (Bool -> String) -> Check Bool
forall a. Eq a => String -> (a -> String) -> Check a
changesOk (String
"type of flag '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'")
              (\Bool
b -> if Bool
b then String
"manual" else String
"automatic")
              (PackageFlag -> Bool
flagManual PackageFlag
flagOld) (PackageFlag -> Bool
flagManual PackageFlag
flagNew)

    String -> (Bool -> String) -> Check Bool
forall a. Eq a => String -> (a -> String) -> Check a
changesOk (String
"default of flag '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") Bool -> String
forall a. Pretty a => a -> String
prettyShow
              (PackageFlag -> Bool
flagDefault PackageFlag
flagOld) (PackageFlag -> Bool
flagDefault PackageFlag
flagNew)

    String -> ShowS -> Check String
forall a. Eq a => String -> (a -> String) -> Check a
changesOk (String
"description of flag '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") ShowS
forall a. a -> a
id
              (PackageFlag -> String
flagDescription PackageFlag
flagOld) (PackageFlag -> String
flagDescription PackageFlag
flagNew)

checkPackageDescriptions :: Bool -> Check PackageDescription
checkPackageDescriptions :: Bool -> Check PackageDescription
checkPackageDescriptions Bool
checkXRevision
  pdA :: PackageDescription
pdA@(PackageDescription
     { specVersion :: PackageDescription -> CabalSpecVersion
specVersion     = CabalSpecVersion
_specVersionA
     , package :: PackageDescription -> PackageIdentifier
package         = PackageIdentifier
packageIdA
     , licenseRaw :: PackageDescription -> Either License License
licenseRaw      = Either License License
licenseRawA
     , licenseFiles :: PackageDescription -> [SymbolicPath PackageDir LicenseFile]
licenseFiles    = [SymbolicPath PackageDir LicenseFile]
licenseFilesA
     , copyright :: PackageDescription -> ShortText
copyright       = ShortText
copyrightA
     , maintainer :: PackageDescription -> ShortText
maintainer      = ShortText
maintainerA
     , author :: PackageDescription -> ShortText
author          = ShortText
authorA
     , stability :: PackageDescription -> ShortText
stability       = ShortText
stabilityA
     , testedWith :: PackageDescription -> [(CompilerFlavor, VersionRange)]
testedWith      = [(CompilerFlavor, VersionRange)]
testedWithA
     , homepage :: PackageDescription -> ShortText
homepage        = ShortText
homepageA
     , pkgUrl :: PackageDescription -> ShortText
pkgUrl          = ShortText
pkgUrlA
     , bugReports :: PackageDescription -> ShortText
bugReports      = ShortText
bugReportsA
     , sourceRepos :: PackageDescription -> [SourceRepo]
sourceRepos     = [SourceRepo]
sourceReposA
     , synopsis :: PackageDescription -> ShortText
synopsis        = ShortText
synopsisA
     , description :: PackageDescription -> ShortText
description     = ShortText
descriptionA
     , category :: PackageDescription -> ShortText
category        = ShortText
categoryA
     , customFieldsPD :: PackageDescription -> [(String, String)]
customFieldsPD  = [(String, String)]
customFieldsPDA
     , buildTypeRaw :: PackageDescription -> Maybe BuildType
buildTypeRaw    = Maybe BuildType
buildTypeRawA
     , setupBuildInfo :: PackageDescription -> Maybe SetupBuildInfo
setupBuildInfo  = Maybe SetupBuildInfo
setupBuildInfoA
     , library :: PackageDescription -> Maybe Library
library         = Maybe Library
_libraryA
     , subLibraries :: PackageDescription -> [Library]
subLibraries    = [Library]
_subLibrariesA
     , executables :: PackageDescription -> [Executable]
executables     = [Executable]
_executablesA
     , foreignLibs :: PackageDescription -> [ForeignLib]
foreignLibs     = [ForeignLib]
_foreignLibsA
     , testSuites :: PackageDescription -> [TestSuite]
testSuites      = [TestSuite]
_testSuitesA
     , benchmarks :: PackageDescription -> [Benchmark]
benchmarks      = [Benchmark]
_benchmarksA
     , dataFiles :: PackageDescription -> [String]
dataFiles       = [String]
dataFilesA
     , dataDir :: PackageDescription -> String
dataDir         = String
dataDirA
     , extraSrcFiles :: PackageDescription -> [String]
extraSrcFiles   = [String]
extraSrcFilesA
     , extraTmpFiles :: PackageDescription -> [String]
extraTmpFiles   = [String]
extraTmpFilesA
     , extraDocFiles :: PackageDescription -> [String]
extraDocFiles   = [String]
extraDocFilesA
     })
  pdB :: PackageDescription
pdB@(PackageDescription
     { specVersion :: PackageDescription -> CabalSpecVersion
specVersion     = CabalSpecVersion
_specVersionB
     , package :: PackageDescription -> PackageIdentifier
package         = PackageIdentifier
packageIdB
     , licenseRaw :: PackageDescription -> Either License License
licenseRaw      = Either License License
licenseRawB
     , licenseFiles :: PackageDescription -> [SymbolicPath PackageDir LicenseFile]
licenseFiles    = [SymbolicPath PackageDir LicenseFile]
licenseFilesB
     , copyright :: PackageDescription -> ShortText
copyright       = ShortText
copyrightB
     , maintainer :: PackageDescription -> ShortText
maintainer      = ShortText
maintainerB
     , author :: PackageDescription -> ShortText
author          = ShortText
authorB
     , stability :: PackageDescription -> ShortText
stability       = ShortText
stabilityB
     , testedWith :: PackageDescription -> [(CompilerFlavor, VersionRange)]
testedWith      = [(CompilerFlavor, VersionRange)]
testedWithB
     , homepage :: PackageDescription -> ShortText
homepage        = ShortText
homepageB
     , pkgUrl :: PackageDescription -> ShortText
pkgUrl          = ShortText
pkgUrlB
     , bugReports :: PackageDescription -> ShortText
bugReports      = ShortText
bugReportsB
     , sourceRepos :: PackageDescription -> [SourceRepo]
sourceRepos     = [SourceRepo]
sourceReposB
     , synopsis :: PackageDescription -> ShortText
synopsis        = ShortText
synopsisB
     , description :: PackageDescription -> ShortText
description     = ShortText
descriptionB
     , category :: PackageDescription -> ShortText
category        = ShortText
categoryB
     , customFieldsPD :: PackageDescription -> [(String, String)]
customFieldsPD  = [(String, String)]
customFieldsPDB
     , buildTypeRaw :: PackageDescription -> Maybe BuildType
buildTypeRaw    = Maybe BuildType
buildTypeRawB
     , setupBuildInfo :: PackageDescription -> Maybe SetupBuildInfo
setupBuildInfo  = Maybe SetupBuildInfo
setupBuildInfoB
     , library :: PackageDescription -> Maybe Library
library         = Maybe Library
_libraryB
     , subLibraries :: PackageDescription -> [Library]
subLibraries    = [Library]
_subLibrariesB
     , executables :: PackageDescription -> [Executable]
executables     = [Executable]
_executablesB
     , foreignLibs :: PackageDescription -> [ForeignLib]
foreignLibs     = [ForeignLib]
_foreignLibsB
     , testSuites :: PackageDescription -> [TestSuite]
testSuites      = [TestSuite]
_testSuitesB
     , benchmarks :: PackageDescription -> [Benchmark]
benchmarks      = [Benchmark]
_benchmarksB
     , dataFiles :: PackageDescription -> [String]
dataFiles       = [String]
dataFilesB
     , dataDir :: PackageDescription -> String
dataDir         = String
dataDirB
     , extraSrcFiles :: PackageDescription -> [String]
extraSrcFiles   = [String]
extraSrcFilesB
     , extraTmpFiles :: PackageDescription -> [String]
extraTmpFiles   = [String]
extraTmpFilesB
     , extraDocFiles :: PackageDescription -> [String]
extraDocFiles   = [String]
extraDocFilesB
     })
  = do
  String -> Check PackageName
forall a. Eq a => String -> Check a
checkSame String
"Don't be silly! You can't change the package name!"
            (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
packageIdA) (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
packageIdB)
  String -> Check Version
forall a. Eq a => String -> Check a
checkSame String
"You can't change the package version!"
            (PackageIdentifier -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion PackageIdentifier
packageIdA) (PackageIdentifier -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion PackageIdentifier
packageIdB)
  String
-> Check
     (Either License License, [SymbolicPath PackageDir LicenseFile])
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the license"
            (Either License License
licenseRawA, [SymbolicPath PackageDir LicenseFile]
licenseFilesA) (Either License License
licenseRawB, [SymbolicPath PackageDir LicenseFile]
licenseFilesB)
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"copyright"  ShortText -> String
fromShortText ShortText
copyrightA ShortText
copyrightB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"maintainer" ShortText -> String
fromShortText ShortText
maintainerA ShortText
maintainerB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"author"     ShortText -> String
fromShortText ShortText
authorA ShortText
authorB
  String -> Check ShortText
forall a. Eq a => String -> Check a
checkSame String
"The stability field is unused, don't bother changing it."
            ShortText
stabilityA ShortText
stabilityB
  Severity
-> String
-> ([(CompilerFlavor, VersionRange)] -> String)
-> Check [(CompilerFlavor, VersionRange)]
forall a. Eq a => Severity -> String -> (a -> String) -> Check a
changesOk' Severity
Trivial String
"tested-with" (Doc -> String
forall a. Show a => a -> String
show (Doc -> String)
-> ([(CompilerFlavor, VersionRange)] -> Doc)
-> [(CompilerFlavor, VersionRange)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CompilerFlavor, VersionRange)] -> Doc
ppTestedWith) [(CompilerFlavor, VersionRange)]
testedWithA [(CompilerFlavor, VersionRange)]
testedWithB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"homepage" ShortText -> String
fromShortText ShortText
homepageA ShortText
homepageB
  String -> Check ShortText
forall a. Eq a => String -> Check a
checkSame String
"The package-url field is unused, don't bother changing it."
            ShortText
pkgUrlA ShortText
pkgUrlB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"bug-reports" ShortText -> String
fromShortText ShortText
bugReportsA ShortText
bugReportsB
  (String -> (SourceRepo -> String) -> Check SourceRepo)
-> String -> (SourceRepo -> String) -> Check [SourceRepo]
forall a.
(String -> (a -> String) -> Check a)
-> String -> (a -> String) -> Check [a]
changesOkList String -> (SourceRepo -> String) -> Check SourceRepo
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"source-repository" ((() -> [String]) -> [PrettyField ()] -> String
forall ann. (ann -> [String]) -> [PrettyField ann] -> String
showFields ([String] -> () -> [String]
forall a b. a -> b -> a
const []) ([PrettyField ()] -> String)
-> (SourceRepo -> [PrettyField ()]) -> SourceRepo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrettyField () -> [PrettyField ()] -> [PrettyField ()]
forall a. a -> [a] -> [a]
:[]) (PrettyField () -> [PrettyField ()])
-> (SourceRepo -> PrettyField ()) -> SourceRepo -> [PrettyField ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceRepo -> PrettyField ()
ppSourceRepo)
            [SourceRepo]
sourceReposA [SourceRepo]
sourceReposB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"synopsis"    ShortText -> String
fromShortText ShortText
synopsisA ShortText
synopsisB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"description" ShortText -> String
fromShortText ShortText
descriptionA ShortText
descriptionB
  String -> (ShortText -> String) -> Check ShortText
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"category"    ShortText -> String
fromShortText ShortText
categoryA ShortText
categoryB
  String -> Check (Maybe BuildType)
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the build-type"
            Maybe BuildType
buildTypeRawA Maybe BuildType
buildTypeRawB
  String -> Check ([String], String)
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the data files"
            ([String]
dataFilesA, String
dataDirA) ([String]
dataFilesB, String
dataDirB)
  String -> Check [String]
forall a. Eq a => String -> Check a
checkSame String
"Changing extra-tmp-files is a bit pointless at this stage"
            [String]
extraTmpFilesA [String]
extraTmpFilesB
  String -> Check [String]
forall a. Eq a => String -> Check a
checkSame String
"Changing extra-source-files would not make sense!"
            [String]
extraSrcFilesA [String]
extraSrcFilesB
  String -> Check [String]
forall a. Eq a => String -> Check a
checkSame String
"You can't change the extra-doc-files."
            [String]
extraDocFilesA [String]
extraDocFilesB

  String -> Check [(String, String)]
forall a. Eq a => String -> Check a
checkSame String
"Cannot change custom/extension fields"
            (((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
f,String
_) -> Bool -> Bool
not (String
f String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"x-revision",String
"x-curation"])) [(String, String)]
customFieldsPDA)
            (((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
f,String
_) -> Bool -> Bool
not (String
f String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"x-revision",String
"x-curation"])) [(String, String)]
customFieldsPDB)

  Check PackageDescription
checkSpecVersionRaw PackageDescription
pdA PackageDescription
pdB
  Check (Maybe SetupBuildInfo)
checkSetupBuildInfo Maybe SetupBuildInfo
setupBuildInfoA Maybe SetupBuildInfo
setupBuildInfoB

  Bool -> CheckM () -> CheckM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkXRevision (CheckM () -> CheckM ()) -> CheckM () -> CheckM ()
forall a b. (a -> b) -> a -> b
$ Check [(String, String)]
checkRevision [(String, String)]
customFieldsPDA [(String, String)]
customFieldsPDB
  Check [(String, String)]
checkCuration [(String, String)]
customFieldsPDA [(String, String)]
customFieldsPDB

checkSpecVersionRaw :: Check PackageDescription
checkSpecVersionRaw :: Check PackageDescription
checkSpecVersionRaw PackageDescription
pdA PackageDescription
pdB
  | CabalSpecVersion -> Bool
range110To120 CabalSpecVersion
specVersionA
  , CabalSpecVersion -> Bool
range110To120 CabalSpecVersion
specVersionB
  = String -> (CabalSpecVersion -> String) -> Check CabalSpecVersion
forall a. Eq a => String -> (a -> String) -> Check a
changesOk String
"cabal-version" CabalSpecVersion -> String
showCabalSpecVersion CabalSpecVersion
specVersionA CabalSpecVersion
specVersionB

  | Bool
otherwise
  = String -> Check CabalSpecVersion
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the Cabal spec version"
              CabalSpecVersion
specVersionA CabalSpecVersion
specVersionB
  where
    specVersionA :: CabalSpecVersion
specVersionA = PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pdA
    specVersionB :: CabalSpecVersion
specVersionB = PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pdB

    -- nothing interesting changed within the  Cabal >=1.10 && <1.21 range
    -- therefore we allow to change the spec version within this interval
    range110To120 :: CabalSpecVersion -> Bool
range110To120 CabalSpecVersion
v = CabalSpecVersion
CabalSpecV1_10 CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
v Bool -> Bool -> Bool
&& CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= CabalSpecVersion
CabalSpecV1_20

checkRevision :: Check [(String, String)]
checkRevision :: Check [(String, String)]
checkRevision [(String, String)]
customFieldsA [(String, String)]
customFieldsB =
    String -> Check Int
forall a. Eq a => String -> Check a
checkSame (String
"The new x-revision must be " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expectedRevision)
              Int
newRevision Int
expectedRevision
  where
    oldRevision :: Int
oldRevision = [(String, String)] -> Int
forall a. (Eq a, IsString a) => [(a, String)] -> Int
getRevision [(String, String)]
customFieldsA
    newRevision :: Int
newRevision = [(String, String)] -> Int
forall a. (Eq a, IsString a) => [(a, String)] -> Int
getRevision [(String, String)]
customFieldsB
    expectedRevision :: Int
expectedRevision = Int
oldRevision Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    getRevision :: [(a, String)] -> Int
getRevision [(a, String)]
customFields =
      case a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"x-revision" [(a, String)]
customFields of
        Just String
s  | [(Int
n,String
"")] <- ReadS Int
forall a. Read a => ReadS a
reads String
s -> Int
n :: Int
        Maybe String
_                             -> Int
0

checkCuration :: Check [(String, String)]
checkCuration :: Check [(String, String)]
checkCuration [(String, String)]
customFieldsA [(String, String)]
customFieldsB =
    String -> Check (Maybe String)
checkNotPresent String
"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." Maybe String
oldCuration Maybe String
newCuration
  where
    oldCuration :: Maybe String
oldCuration = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"x-curation" [(String, String)]
customFieldsA
    newCuration :: Maybe String
newCuration = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"x-curation" [(String, String)]
customFieldsB



checkCondTree :: (ComponentName -> Check a) -> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree :: (ComponentName -> Check a)
-> Check (ComponentName, CondTree ConfVar [Dependency] a)
checkCondTree ComponentName -> Check a
checkElem (ComponentName
componentName, CondTree ConfVar [Dependency] a
condNodeA)
                        (ComponentName
_            , CondTree ConfVar [Dependency] a
condNodeB) =
    CondTree ConfVar [Dependency] a
-> CondTree ConfVar [Dependency] a -> CheckM ()
checkCondNode CondTree ConfVar [Dependency] a
condNodeA CondTree ConfVar [Dependency] a
condNodeB
  where
    checkCondNode :: CondTree ConfVar [Dependency] a
-> CondTree ConfVar [Dependency] a -> CheckM ()
checkCondNode (CondNode a
dataA [Dependency]
constraintsA [CondBranch ConfVar [Dependency] a]
componentsA)
                  (CondNode a
dataB [Dependency]
constraintsB [CondBranch ConfVar [Dependency] a]
componentsB) = do
      ComponentName -> Check [Dependency]
forall d vr.
(Pretty d, IsDependency vr d) =>
ComponentName -> Check [d]
checkDependencies ComponentName
componentName [Dependency]
constraintsA [Dependency]
constraintsB
      String
-> Check (CondBranch ConfVar [Dependency] a)
-> Check [CondBranch ConfVar [Dependency] a]
forall a. String -> Check a -> Check [a]
checkList String
"Cannot add or remove 'if' conditionals"
                Check (CondBranch ConfVar [Dependency] a)
checkComponent [CondBranch ConfVar [Dependency] a]
componentsA [CondBranch ConfVar [Dependency] a]
componentsB
      ComponentName -> Check a
checkElem ComponentName
componentName a
dataA a
dataB

    checkComponent :: Check (CondBranch ConfVar [Dependency] a)
checkComponent (CondBranch Condition ConfVar
condA CondTree ConfVar [Dependency] a
ifPartA Maybe (CondTree ConfVar [Dependency] a)
thenPartA)
                   (CondBranch Condition ConfVar
condB CondTree ConfVar [Dependency] a
ifPartB Maybe (CondTree ConfVar [Dependency] a)
thenPartB) = do
      String -> Check (Condition ConfVar)
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the 'if' condition expressions"
                Condition ConfVar
condA Condition ConfVar
condB
      CondTree ConfVar [Dependency] a
-> CondTree ConfVar [Dependency] a -> CheckM ()
checkCondNode CondTree ConfVar [Dependency] a
ifPartA CondTree ConfVar [Dependency] a
ifPartB
      String
-> (CondTree ConfVar [Dependency] a
    -> CondTree ConfVar [Dependency] a -> CheckM ())
-> Check (Maybe (CondTree ConfVar [Dependency] a))
forall a. String -> Check a -> Check (Maybe a)
checkMaybe String
"Cannot add or remove the 'else' part in conditionals"
                 CondTree ConfVar [Dependency] a
-> CondTree ConfVar [Dependency] a -> CheckM ()
checkCondNode Maybe (CondTree ConfVar [Dependency] a)
thenPartA Maybe (CondTree ConfVar [Dependency] a)
thenPartB

checkDependencies :: forall d vr. (Pretty d, IsDependency vr d) => ComponentName -> Check [d]
checkDependencies :: ComponentName -> Check [d]
checkDependencies ComponentName
componentName [d]
ds1 [d]
ds2 = do
    [d] -> (d -> CheckM Any) -> CheckM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [d]
removed ((d -> CheckM Any) -> CheckM ()) -> (d -> CheckM Any) -> CheckM ()
forall a b. (a -> b) -> a -> b
$ \d
dep -> do
        String -> CheckM Any
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ([String] -> String
unwords [ String
"Cannot remove existing", String
depKind, String
"on"
                      , Proxy d -> DepKey d -> String
forall vr d. IsDependency vr d => Proxy d -> DepKey d -> String
depKeyShow Proxy d
dproxy (d -> DepKey d
forall vr d. IsDependency vr d => d -> DepKey d
depKey d
dep), String
"in", String
cnameStr, String
" component"])

    [d] -> (d -> CheckM ()) -> CheckM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [d]
added ((d -> CheckM ()) -> CheckM ()) -> (d -> CheckM ()) -> CheckM ()
forall a b. (a -> b) -> a -> b
$ \d
dep ->
        if d -> Bool
forall vr d. IsDependency vr d => d -> Bool
depInAddWhitelist d
dep
           then Change -> CheckM ()
logChange (Severity -> String -> String -> String -> Change
Change Severity
Normal ([String] -> String
unwords [String
"added the", String
cnameStr, String
"component's"
                                                  , String
depKind, String
"on"]) String
"" (d -> String
forall a. Pretty a => a -> String
prettyShow d
dep))
           else String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ([String] -> String
unwords [ String
"Cannot add new", String
depKind, String
"on"
                              , Proxy d -> DepKey d -> String
forall vr d. IsDependency vr d => Proxy d -> DepKey d -> String
depKeyShow Proxy d
dproxy (d -> DepKey d
forall vr d. IsDependency vr d => d -> DepKey d
depKey d
dep)
                              , String
"in", String
cnameStr, String
"component"])

    [(DepKey d, (vr, vr))]
-> ((DepKey d, (vr, vr)) -> CheckM ()) -> CheckM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(DepKey d, (vr, vr))]
changed (((DepKey d, (vr, vr)) -> CheckM ()) -> CheckM ())
-> ((DepKey d, (vr, vr)) -> CheckM ()) -> CheckM ()
forall a b. (a -> b) -> a -> b
$ \(DepKey d
depk, (vr
verA, vr
verB)) -> do
        String -> (vr -> String) -> Check vr
forall a. Eq a => String -> (a -> String) -> Check a
changesOk ([String] -> String
unwords [String
"the", String
cnameStr, String
"component's", String
depKind, String
"on"
                           , Proxy d -> DepKey d -> String
forall vr d. IsDependency vr d => Proxy d -> DepKey d -> String
depKeyShow Proxy d
dproxy DepKey d
depk])
                   vr -> String
forall a. Pretty a => a -> String
prettyShow vr
verA vr
verB
  where
    ([d]
removed, [(DepKey d, (vr, vr))]
changed, [d]
added) = [d] -> [d] -> ([d], [(DepKey d, (vr, vr))], [d])
forall vr d.
IsDependency vr d =>
[d] -> [d] -> ([d], [(DepKey d, (vr, vr))], [d])
computeCanonDepChange [d]
ds1 [d]
ds2

    dproxy :: Proxy d
    dproxy :: Proxy d
dproxy = Proxy d
forall k (t :: k). Proxy t
Proxy

    cnameStr :: String
cnameStr = ComponentName -> String
showComponentName ComponentName
componentName

    depKind :: String
depKind = Proxy d -> String
forall vr d. IsDependency vr d => Proxy d -> String
depTypeName Proxy d
dproxy String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" 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 d
_ = Bool
False

    intersectVr :: Proxy d -> vr -> vr -> vr

instance IsDependency VersionRange Dependency where
    type DepKey Dependency = PackageName

    depTypeName :: Proxy Dependency -> String
depTypeName Proxy Dependency
Proxy             = String
"library"
    depKey :: Dependency -> DepKey Dependency
depKey (Dependency PackageName
pkgname VersionRange
_ NonEmptySet LibraryName
_) = PackageName
DepKey Dependency
pkgname
    depKeyShow :: Proxy Dependency -> DepKey Dependency -> String
depKeyShow Proxy Dependency
Proxy              = DepKey Dependency -> String
forall a. Pretty a => a -> String
prettyShow''
    depVerRg :: Dependency -> VersionRange
depVerRg (Dependency PackageName
_ VersionRange
vr NonEmptySet LibraryName
_)  = VersionRange
vr
    reconstructDep :: DepKey Dependency -> VersionRange -> Dependency
reconstructDep                = \DepKey Dependency
n VersionRange
vr -> PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
DepKey Dependency
n VersionRange
vr NonEmptySet LibraryName
mainLibSet

    depInAddWhitelist :: Dependency -> Bool
depInAddWhitelist (Dependency PackageName
pn VersionRange
_ NonEmptySet LibraryName
_) = PackageName
pn PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`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`
            [ String -> PackageName
mkPackageName String
"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
    --
            , String -> PackageName
mkPackageName String
"base-orphans"
            ]

    intersectVr :: Proxy Dependency -> VersionRange -> VersionRange -> VersionRange
intersectVr Proxy Dependency
_ = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges


instance IsDependency VersionRange ExeDependency where
    type DepKey ExeDependency = (PackageName,UnqualComponentName)

    depTypeName :: Proxy ExeDependency -> String
depTypeName Proxy ExeDependency
Proxy                   = String
"tool"
    depKey :: ExeDependency -> DepKey ExeDependency
depKey (ExeDependency PackageName
pkgname UnqualComponentName
cn VersionRange
_) = (PackageName
pkgname,UnqualComponentName
cn)
    depKeyShow :: Proxy ExeDependency -> DepKey ExeDependency -> String
depKeyShow Proxy ExeDependency
Proxy (pkgname,cn)       = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"'", PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
pkgname, String
":", UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
cn, String
"'"]
    depVerRg :: ExeDependency -> VersionRange
depVerRg (ExeDependency PackageName
_ UnqualComponentName
_ VersionRange
vr)     = VersionRange
vr
    reconstructDep :: DepKey ExeDependency -> VersionRange -> ExeDependency
reconstructDep (pkgname,cn)         = PackageName -> UnqualComponentName -> VersionRange -> ExeDependency
ExeDependency PackageName
pkgname UnqualComponentName
cn

    intersectVr :: Proxy ExeDependency -> VersionRange -> VersionRange -> VersionRange
intersectVr Proxy ExeDependency
_ = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges

instance IsDependency VersionRange LegacyExeDependency where
    type DepKey LegacyExeDependency = String

    depTypeName :: Proxy LegacyExeDependency -> String
depTypeName Proxy LegacyExeDependency
Proxy                      = String
"legacy-tool"
    depKey :: LegacyExeDependency -> DepKey LegacyExeDependency
depKey (LegacyExeDependency String
tname VersionRange
_)   = String
DepKey LegacyExeDependency
tname
    depKeyShow :: Proxy LegacyExeDependency -> DepKey LegacyExeDependency -> String
depKeyShow Proxy LegacyExeDependency
Proxy DepKey LegacyExeDependency
tname                 = String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
DepKey LegacyExeDependency
tname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
    depVerRg :: LegacyExeDependency -> VersionRange
depVerRg (LegacyExeDependency String
_ VersionRange
vr)    = VersionRange
vr
    reconstructDep :: DepKey LegacyExeDependency -> VersionRange -> LegacyExeDependency
reconstructDep                         = String -> VersionRange -> LegacyExeDependency
DepKey LegacyExeDependency -> VersionRange -> LegacyExeDependency
LegacyExeDependency

    intersectVr :: Proxy LegacyExeDependency
-> VersionRange -> VersionRange -> VersionRange
intersectVr Proxy LegacyExeDependency
_ = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges

    depInAddWhitelist :: LegacyExeDependency -> Bool
depInAddWhitelist (LegacyExeDependency String
pn VersionRange
_) = String
pn String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`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"
            [ String
"alex"
            , String
"c2hs"
            , String
"cpphs"
            , String
"greencard"
            , String
"happy"
            , String
"hsc2hs"
            ]

instance IsDependency PkgconfigVersionRange PkgconfigDependency where
    type DepKey PkgconfigDependency = PkgconfigName

    depTypeName :: Proxy PkgconfigDependency -> String
depTypeName Proxy PkgconfigDependency
Proxy                      = String
"pkg-config"
    depKey :: PkgconfigDependency -> DepKey PkgconfigDependency
depKey (PkgconfigDependency PkgconfigName
pkgname PkgconfigVersionRange
_) = PkgconfigName
DepKey PkgconfigDependency
pkgname
    depKeyShow :: Proxy PkgconfigDependency -> DepKey PkgconfigDependency -> String
depKeyShow Proxy PkgconfigDependency
Proxy                       = DepKey PkgconfigDependency -> String
forall a. Pretty a => a -> String
prettyShow''
    depVerRg :: PkgconfigDependency -> PkgconfigVersionRange
depVerRg (PkgconfigDependency PkgconfigName
_ PkgconfigVersionRange
vr)    = PkgconfigVersionRange
vr
    reconstructDep :: DepKey PkgconfigDependency
-> PkgconfigVersionRange -> PkgconfigDependency
reconstructDep                         = PkgconfigName -> PkgconfigVersionRange -> PkgconfigDependency
DepKey PkgconfigDependency
-> PkgconfigVersionRange -> PkgconfigDependency
PkgconfigDependency

    intersectVr :: Proxy PkgconfigDependency
-> PkgconfigVersionRange
-> PkgconfigVersionRange
-> PkgconfigVersionRange
intersectVr Proxy PkgconfigDependency
_ = PkgconfigVersionRange
-> PkgconfigVersionRange -> PkgconfigVersionRange
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 :: [d] -> [d] -> ([d], [(DepKey d, (vr, vr))], [d])
computeCanonDepChange [d]
depsA [d]
depsB
    = ( Map (DepKey d) vr -> [d]
mapToDeps (Map (DepKey d) vr
a Map (DepKey d) vr -> Map (DepKey d) vr -> Map (DepKey d) vr
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map (DepKey d) vr
b)
      , Map (DepKey d) (vr, vr) -> [(DepKey d, (vr, vr))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (DepKey d) (vr, vr) -> [(DepKey d, (vr, vr))])
-> Map (DepKey d) (vr, vr) -> [(DepKey d, (vr, vr))]
forall a b. (a -> b) -> a -> b
$ (vr -> vr -> (vr, vr))
-> Map (DepKey d) vr
-> Map (DepKey d) vr
-> Map (DepKey d) (vr, vr)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map (DepKey d) vr
a Map (DepKey d) vr
b
      , Map (DepKey d) vr -> [d]
mapToDeps (Map (DepKey d) vr
b Map (DepKey d) vr -> Map (DepKey d) vr -> Map (DepKey d) vr
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map (DepKey d) vr
a)
      )
  where
    a :: Map (DepKey d) vr
a = [d] -> Map (DepKey d) vr
depsToMapWithCanonVerRange [d]
depsA
    b :: Map (DepKey d) vr
b = [d] -> Map (DepKey d) vr
depsToMapWithCanonVerRange [d]
depsB

    depsToMapWithCanonVerRange :: [d] -> Map (DepKey d) vr
depsToMapWithCanonVerRange
        = (vr -> vr -> vr) -> [(DepKey d, vr)] -> Map (DepKey d) vr
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((vr -> vr -> vr) -> vr -> vr -> vr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((vr -> vr -> vr) -> vr -> vr -> vr)
-> (vr -> vr -> vr) -> vr -> vr -> vr
forall a b. (a -> b) -> a -> b
$ Proxy d -> vr -> vr -> vr
forall vr d. IsDependency vr d => Proxy d -> vr -> vr -> vr
intersectVr (Proxy d
forall k (t :: k). Proxy t
Proxy :: Proxy d)) ([(DepKey d, vr)] -> Map (DepKey d) vr)
-> ([d] -> [(DepKey d, vr)]) -> [d] -> Map (DepKey d) vr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (d -> (DepKey d, vr)) -> [d] -> [(DepKey d, vr)]
forall a b. (a -> b) -> [a] -> [b]
map (\d
d -> (d -> DepKey d
forall vr d. IsDependency vr d => d -> DepKey d
depKey d
d, d -> vr
forall vr d. IsDependency vr d => d -> vr
depVerRg d
d))

    mapToDeps :: Map (DepKey d) vr -> [d]
mapToDeps
        = ((DepKey d, vr) -> d) -> [(DepKey d, vr)] -> [d]
forall a b. (a -> b) -> [a] -> [b]
map (\(DepKey d
pkgname, vr
verrange) -> DepKey d -> vr -> d
forall vr d. IsDependency vr d => DepKey d -> vr -> d
reconstructDep DepKey d
pkgname vr
verrange) ([(DepKey d, vr)] -> [d])
-> (Map (DepKey d) vr -> [(DepKey d, vr)])
-> Map (DepKey d) vr
-> [d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (DepKey d) vr -> [(DepKey d, vr)]
forall k a. Map k a -> [(k, a)]
Map.toList


checkSetupBuildInfo :: Check (Maybe SetupBuildInfo)
checkSetupBuildInfo :: Check (Maybe SetupBuildInfo)
checkSetupBuildInfo Maybe SetupBuildInfo
Nothing  Maybe SetupBuildInfo
Nothing = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSetupBuildInfo (Just SetupBuildInfo
_) Maybe SetupBuildInfo
Nothing =
    String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot remove a 'custom-setup' section"

checkSetupBuildInfo Maybe SetupBuildInfo
Nothing (Just (SetupBuildInfo [Dependency]
setupDependsA Bool
_internalA)) =
    Change -> CheckM ()
logChange (Change -> CheckM ()) -> Change -> CheckM ()
forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Change
Change Severity
Normal
                       (String
"added a 'custom-setup' section with 'setup-depends'")
                       String
"[implicit]" (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Dependency -> String) -> [Dependency] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> String
forall a. Pretty a => a -> String
prettyShow [Dependency]
setupDependsA))

checkSetupBuildInfo (Just (SetupBuildInfo [Dependency]
setupDependsA Bool
_internalA))
                    (Just (SetupBuildInfo [Dependency]
setupDependsB Bool
_internalB)) = do
    [Dependency] -> (Dependency -> CheckM ()) -> CheckM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Dependency]
removed ((Dependency -> CheckM ()) -> CheckM ())
-> (Dependency -> CheckM ()) -> CheckM ()
forall a b. (a -> b) -> a -> b
$ \Dependency
dep ->
      Change -> CheckM ()
logChange (Change -> CheckM ()) -> Change -> CheckM ()
forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Change
Change Severity
Normal (String
"removed 'custom-setup' dependency on") (Dependency -> String
forall a. Pretty a => a -> String
prettyShow Dependency
dep) String
""
    [Dependency] -> (Dependency -> CheckM ()) -> CheckM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Dependency]
added ((Dependency -> CheckM ()) -> CheckM ())
-> (Dependency -> CheckM ()) -> CheckM ()
forall a b. (a -> b) -> a -> b
$ \Dependency
dep ->
      Change -> CheckM ()
logChange (Change -> CheckM ()) -> Change -> CheckM ()
forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Change
Change Severity
Normal (String
"added 'custom-setup' dependency on") String
"" (Dependency -> String
forall a. Pretty a => a -> String
prettyShow Dependency
dep)
    [(PackageName, (VersionRange, VersionRange))]
-> ((PackageName, (VersionRange, VersionRange)) -> CheckM ())
-> CheckM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PackageName, (VersionRange, VersionRange))]
changed (((PackageName, (VersionRange, VersionRange)) -> CheckM ())
 -> CheckM ())
-> ((PackageName, (VersionRange, VersionRange)) -> CheckM ())
-> CheckM ()
forall a b. (a -> b) -> a -> b
$ \(PackageName
pkgn, (VersionRange
verA, VersionRange
verB)) ->
        String -> (VersionRange -> String) -> Check VersionRange
forall a. Eq a => String -> (a -> String) -> Check a
changesOk (String
"the 'custom-setup' dependency on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow'' PackageName
pkgn)
                  VersionRange -> String
forall a. Pretty a => a -> String
prettyShow VersionRange
verA VersionRange
verB
  where
    ([Dependency]
removed, [(PackageName, (VersionRange, VersionRange))]
changed, [Dependency]
added) =
      [Dependency]
-> [Dependency]
-> ([Dependency],
    [(DepKey Dependency, (VersionRange, VersionRange))], [Dependency])
forall vr d.
IsDependency vr d =>
[d] -> [d] -> ([d], [(DepKey d, (vr, vr))], [d])
computeCanonDepChange [Dependency]
setupDependsA [Dependency]
setupDependsB

checkLibrary :: ComponentName -> Check Library
checkLibrary :: ComponentName -> Check Library
checkLibrary ComponentName
componentName
             (Library LibraryName
modulesA [ModuleName]
reexportedA [ModuleReexport]
requiredSigsA [ModuleName]
exposedSigsA
                      Bool
exposedA LibraryVisibility
visibilityA BuildInfo
buildInfoA)
             (Library LibraryName
modulesB [ModuleName]
reexportedB [ModuleReexport]
requiredSigsB [ModuleName]
exposedSigsB
                      Bool
exposedB LibraryVisibility
visibilityB BuildInfo
buildInfoB) = do
  String -> Check LibraryName
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the exposed modules" LibraryName
modulesA LibraryName
modulesB
  String -> Check [ModuleName]
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the re-exported modules" [ModuleName]
reexportedA [ModuleName]
reexportedB
  String -> Check [ModuleReexport]
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the required signatures" [ModuleReexport]
requiredSigsA [ModuleReexport]
requiredSigsB
  String -> Check [ModuleName]
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the exposed signatures"  [ModuleName]
exposedSigsA  [ModuleName]
exposedSigsB
  String -> Check Bool
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the package exposed status" Bool
exposedA Bool
exposedB
  String -> Check LibraryVisibility
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the package visibility" LibraryVisibility
visibilityA LibraryVisibility
visibilityB
  ComponentName -> Check BuildInfo
checkBuildInfo ComponentName
componentName BuildInfo
buildInfoA BuildInfo
buildInfoB

checkForeignLib :: ComponentName -> Check ForeignLib
checkForeignLib :: ComponentName -> Check ForeignLib
checkForeignLib ComponentName
componentName
             (ForeignLib UnqualComponentName
nameA ForeignLibType
typeA [ForeignLibOption]
optionsA BuildInfo
buildInfoA Maybe LibVersionInfo
verA Maybe Version
verLinuxA [String]
modDefA)
             (ForeignLib UnqualComponentName
nameB ForeignLibType
typeB [ForeignLibOption]
optionsB BuildInfo
buildInfoB Maybe LibVersionInfo
verB Maybe Version
verLinuxB [String]
modDefB) = do
  String -> Check UnqualComponentName
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the foreign library name" UnqualComponentName
nameA UnqualComponentName
nameB
  String -> Check ForeignLibType
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the foreign library type" ForeignLibType
typeA ForeignLibType
typeB
  String -> Check [ForeignLibOption]
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the foreign library options" [ForeignLibOption]
optionsA [ForeignLibOption]
optionsB
  String -> Check (Maybe LibVersionInfo)
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the foreign library version" Maybe LibVersionInfo
verA Maybe LibVersionInfo
verB
  String -> Check (Maybe Version)
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the foreign library version for Linux" Maybe Version
verLinuxA Maybe Version
verLinuxB
  String -> Check [String]
forall a. Eq a => String -> Check a
checkSame String
"Cannot change the module definition files" [String]
modDefA [String]
modDefB
  ComponentName -> Check BuildInfo
checkBuildInfo ComponentName
componentName BuildInfo
buildInfoA BuildInfo
buildInfoB

checkExecutable :: ComponentName -> Check Executable
checkExecutable :: ComponentName -> Check Executable
checkExecutable ComponentName
componentName
                (Executable UnqualComponentName
_nameA String
pathA ExecutableScope
scopeA BuildInfo
buildInfoA)
                (Executable UnqualComponentName
_nameB String
pathB ExecutableScope
scopeB BuildInfo
buildInfoB) = do
  String -> Check String
forall a. Eq a => String -> Check a
checkSame String
"Cannot change build information" String
pathA String
pathB
  String -> Check ExecutableScope
forall a. Eq a => String -> Check a
checkSame String
"Cannot change executable scope" ExecutableScope
scopeA ExecutableScope
scopeB
  ComponentName -> Check BuildInfo
checkBuildInfo ComponentName
componentName BuildInfo
buildInfoA BuildInfo
buildInfoB

checkTestSuite :: ComponentName -> Check TestSuite
checkTestSuite :: ComponentName -> Check TestSuite
checkTestSuite ComponentName
componentName
               (TestSuite UnqualComponentName
_nameA TestSuiteInterface
interfaceA BuildInfo
buildInfoA)
               (TestSuite UnqualComponentName
_nameB TestSuiteInterface
interfaceB BuildInfo
buildInfoB) = do
  String -> Check TestSuiteInterface
forall a. Eq a => String -> Check a
checkSame String
"Cannot change test-suite type" TestSuiteInterface
interfaceA TestSuiteInterface
interfaceB
  ComponentName -> Check BuildInfo
checkBuildInfo ComponentName
componentName BuildInfo
buildInfoA BuildInfo
buildInfoB

checkBenchmark :: ComponentName -> Check Benchmark
checkBenchmark :: ComponentName -> Check Benchmark
checkBenchmark ComponentName
componentName
               (Benchmark UnqualComponentName
_nameA BenchmarkInterface
interfaceA BuildInfo
buildInfoA)
               (Benchmark UnqualComponentName
_nameB BenchmarkInterface
interfaceB BuildInfo
buildInfoB) = do
  String -> Check BenchmarkInterface
forall a. Eq a => String -> Check a
checkSame String
"Cannot change benchmark type" BenchmarkInterface
interfaceA BenchmarkInterface
interfaceB
  ComponentName -> Check BuildInfo
checkBuildInfo ComponentName
componentName BuildInfo
buildInfoA BuildInfo
buildInfoB

checkBuildInfo :: ComponentName -> Check BuildInfo
checkBuildInfo :: ComponentName -> Check BuildInfo
checkBuildInfo ComponentName
componentName BuildInfo
biA BuildInfo
biB = do
    -- @other-extension@
    String -> (Extension -> String) -> Check (Set Extension)
forall a. Ord a => String -> (a -> String) -> Check (Set a)
changesOkSet (String
"'other-extensions' in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName ComponentName
componentName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" component")
              Extension -> String
forall a. Pretty a => a -> String
prettyShow
              ([Extension] -> Set Extension
forall a. Ord a => [a] -> Set a
Set.fromList ([Extension] -> Set Extension) -> [Extension] -> Set Extension
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [Extension]
otherExtensions BuildInfo
biA) ([Extension] -> Set Extension
forall a. Ord a => [a] -> Set a
Set.fromList ([Extension] -> Set Extension) -> [Extension] -> Set Extension
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [Extension]
otherExtensions BuildInfo
biB)

    -- @buildable@
    String -> (Bool -> String) -> Check Bool
forall a. Eq a => String -> (a -> String) -> Check a
changesOk (String
"'buildable' in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName ComponentName
componentName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" component") Bool -> String
forall a. Pretty a => a -> String
prettyShow
              (BuildInfo -> Bool
buildable BuildInfo
biA) (BuildInfo -> Bool
buildable BuildInfo
biB)

    -- @build-tool-depends@
    ComponentName -> Check [ExeDependency]
forall d vr.
(Pretty d, IsDependency vr d) =>
ComponentName -> Check [d]
checkDependencies ComponentName
componentName
        (BuildInfo -> [ExeDependency]
buildToolDepends BuildInfo
biA)
        (BuildInfo -> [ExeDependency]
buildToolDepends BuildInfo
biB)

    -- @build-tools@
    ComponentName -> Check [LegacyExeDependency]
forall d vr.
(Pretty d, IsDependency vr d) =>
ComponentName -> Check [d]
checkDependencies ComponentName
componentName
        (BuildInfo -> [LegacyExeDependency]
buildTools BuildInfo
biA)
        (BuildInfo -> [LegacyExeDependency]
buildTools BuildInfo
biB)

    -- @pkgconfig-depends@
    ComponentName -> Check [PkgconfigDependency]
forall d vr.
(Pretty d, IsDependency vr d) =>
ComponentName -> Check [d]
checkDependencies ComponentName
componentName
        (BuildInfo -> [PkgconfigDependency]
pkgconfigDepends BuildInfo
biA)
        (BuildInfo -> [PkgconfigDependency]
pkgconfigDepends BuildInfo
biB)

    String -> Check BuildInfo
forall a. Eq a => String -> Check a
checkSame String
"Cannot change build information (just the dependency version constraints)"
              (BuildInfo
biA { targetBuildDepends :: [Dependency]
targetBuildDepends = [], otherExtensions :: [Extension]
otherExtensions = [], buildTools :: [LegacyExeDependency]
buildTools = [], buildToolDepends :: [ExeDependency]
buildToolDepends = [], pkgconfigDepends :: [PkgconfigDependency]
pkgconfigDepends = [], buildable :: Bool
buildable = Bool
True })
              (BuildInfo
biB { targetBuildDepends :: [Dependency]
targetBuildDepends = [], otherExtensions :: [Extension]
otherExtensions = [], buildTools :: [LegacyExeDependency]
buildTools = [], buildToolDepends :: [ExeDependency]
buildToolDepends = [], pkgconfigDepends :: [PkgconfigDependency]
pkgconfigDepends = [], buildable :: Bool
buildable = Bool
True })

changesOk' :: Eq a => Severity -> String -> (a -> String) -> Check a
changesOk' :: Severity -> String -> (a -> String) -> Check a
changesOk' Severity
rel String
what a -> String
render a
a a
b
  | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b    = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = Change -> CheckM ()
logChange (Severity -> String -> String -> String -> Change
Change Severity
rel String
what (a -> String
render a
a) (a -> String
render a
b))

changesOk :: Eq a => String -> (a -> String) -> Check a
changesOk :: String -> (a -> String) -> Check a
changesOk = Severity -> String -> (a -> String) -> Check a
forall a. Eq a => Severity -> String -> (a -> String) -> Check a
changesOk' Severity
Normal

changesOkList :: (String -> (a -> String) -> Check a)
              -> String -> (a -> String) -> Check [a]
changesOkList :: (String -> (a -> String) -> Check a)
-> String -> (a -> String) -> Check [a]
changesOkList String -> (a -> String) -> Check a
changesOkElem String
what a -> String
render = Check [a]
go
  where
    go :: Check [a]
go []     []     = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go (a
a:[a]
_)  []     = Change -> CheckM ()
logChange (Severity -> String -> String -> String -> Change
Change Severity
Normal (String
"removed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what) (a -> String
render a
a) String
"")
    go []     (a
b:[a]
_)  = Change -> CheckM ()
logChange (Severity -> String -> String -> String -> Change
Change Severity
Normal (String
"added "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what) String
"" (a -> String
render a
b))
    go (a
a:[a]
as) (a
b:[a]
bs) = String -> (a -> String) -> Check a
changesOkElem String
what a -> String
render a
a a
b CheckM () -> CheckM () -> CheckM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Check [a]
go [a]
as [a]
bs

changesOkSet :: Ord a => String -> (a -> String) -> Check (Set.Set a)
changesOkSet :: String -> (a -> String) -> Check (Set a)
changesOkSet String
what a -> String
render Set a
old Set a
new = do
    Bool -> CheckM () -> CheckM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
removed) (CheckM () -> CheckM ()) -> CheckM () -> CheckM ()
forall a b. (a -> b) -> a -> b
$
        Change -> CheckM ()
logChange (Severity -> String -> String -> String -> Change
Change Severity
Normal (String
"removed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what) (Set a -> String
renderSet Set a
removed) String
"")
    Bool -> CheckM () -> CheckM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
added) (CheckM () -> CheckM ()) -> CheckM () -> CheckM ()
forall a b. (a -> b) -> a -> b
$
        Change -> CheckM ()
logChange (Severity -> String -> String -> String -> Change
Change Severity
Normal (String
"added " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what) String
"" (Set a -> String
renderSet Set a
added))
    () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    added :: Set a
added   = Set a
new Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
old
    removed :: Set a
removed = Set a
old Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
new
    renderSet :: Set a -> String
renderSet = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> (Set a -> [String]) -> Set a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
render ([a] -> [String]) -> (Set a -> [a]) -> Set a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList


-- | Single-quote-wrapping 'prettyShow'
prettyShow'' :: Pretty a => a -> String
prettyShow'' :: a -> String
prettyShow'' a
x = String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyShow a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"

checkSame :: Eq a => String -> Check a
checkSame :: String -> Check a
checkSame String
msg a
x a
y | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y    = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  | Bool
otherwise = String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg

checkList :: String -> Check a -> Check [a]
checkList :: String -> Check a -> Check [a]
checkList String
_   Check a
_         []     []     = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkList String
msg Check a
checkElem (a
x:[a]
xs) (a
y:[a]
ys) = Check a
checkElem a
x a
y
                                     CheckM () -> CheckM () -> CheckM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Check a -> Check [a]
forall a. String -> Check a -> Check [a]
checkList String
msg Check a
checkElem [a]
xs [a]
ys
checkList String
msg Check a
_         [a]
_      [a]
_      = String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg

checkListAssoc :: Eq b => String -> Check a -> Check [(b,a)]
checkListAssoc :: String -> Check a -> Check [(b, a)]
checkListAssoc String
_   Check a
_         [] [] = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkListAssoc String
msg Check a
checkElem ((b
kx,a
x):[(b, a)]
xs) ((b
ky,a
y):[(b, a)]
ys)
                       | b
kx b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
ky  = Check a
checkElem a
x a
y
                                  CheckM () -> CheckM () -> CheckM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Check a -> Check [(b, a)]
forall b a. Eq b => String -> Check a -> Check [(b, a)]
checkListAssoc String
msg Check a
checkElem [(b, a)]
xs [(b, a)]
ys
                       | Bool
otherwise = String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
checkListAssoc String
msg Check a
_         [(b, a)]
_  [(b, a)]
_  = String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg

checkNotPresent :: String -> Check (Maybe String)
checkNotPresent :: String -> Check (Maybe String)
checkNotPresent String
msg Maybe String
_ (Just String
_) = String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
checkNotPresent String
_ Maybe String
_ Maybe String
Nothing = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkMaybe :: String -> Check a -> Check (Maybe a)
checkMaybe :: String -> Check a -> Check (Maybe a)
checkMaybe String
_   Check a
_     Maybe a
Nothing  Maybe a
Nothing  = () -> CheckM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMaybe String
_   Check a
check (Just a
x) (Just a
y) = Check a
check a
x a
y
checkMaybe String
msg Check a
_     Maybe a
_        Maybe a
_        = String -> CheckM ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg

ppTestedWith :: [(CompilerFlavor, VersionRange)] -> Doc
ppTestedWith :: [(CompilerFlavor, VersionRange)] -> Doc
ppTestedWith = [Doc] -> Doc
hsep ([Doc] -> Doc)
-> ([(CompilerFlavor, VersionRange)] -> [Doc])
-> [(CompilerFlavor, VersionRange)]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
colon ([Doc] -> [Doc])
-> ([(CompilerFlavor, VersionRange)] -> [Doc])
-> [(CompilerFlavor, VersionRange)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CompilerFlavor, VersionRange) -> Doc)
-> [(CompilerFlavor, VersionRange)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((CompilerFlavor -> VersionRange -> Doc)
-> (CompilerFlavor, VersionRange) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CompilerFlavor -> VersionRange -> Doc
forall a a. (Pretty a, Pretty a) => a -> a -> Doc
ppPair)
  where
    ppPair :: a -> a -> Doc
ppPair a
compiler a
vr = String -> Doc
text (a -> String
forall a. Pretty a => a -> String
prettyShow a
compiler) Doc -> Doc -> Doc
<+> String -> Doc
text (a -> String
forall a. Pretty a => a -> String
prettyShow a
vr)

ppSourceRepo :: SourceRepo -> PrettyField ()
ppSourceRepo :: SourceRepo -> PrettyField ()
ppSourceRepo SourceRepo
repo = () -> ByteString -> [Doc] -> [PrettyField ()] -> PrettyField ()
forall ann.
ann -> ByteString -> [Doc] -> [PrettyField ann] -> PrettyField ann
PrettySection () ByteString
"source-repository" [RepoKind -> Doc
forall a. Pretty a => a -> Doc
pretty RepoKind
kind] ([PrettyField ()] -> PrettyField ())
-> [PrettyField ()] -> PrettyField ()
forall a b. (a -> b) -> a -> b
$
    CabalSpecVersion
-> PrettyFieldGrammar SourceRepo SourceRepo
-> SourceRepo
-> [PrettyField ()]
forall s a.
CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar CabalSpecVersion
cabalSpecLatest (RepoKind -> PrettyFieldGrammar SourceRepo SourceRepo
forall (c :: * -> Constraint) (g :: * -> * -> *).
(FieldGrammar c g, Applicative (g SourceRepo),
 c (Identity RepoType), c Token, c FilePathNT) =>
RepoKind -> g SourceRepo SourceRepo
sourceRepoFieldGrammar RepoKind
kind) SourceRepo
repo
  where
    kind :: RepoKind
kind = SourceRepo -> RepoKind
repoKind SourceRepo
repo

-- TODO: Verify that we don't need to worry about UTF8
-- | Insert or update \"x-revision:\" field
insertRevisionField :: Int -> ByteString -> ByteString
insertRevisionField :: Int -> ByteString -> ByteString
insertRevisionField Int
rev
    | Int
rev Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  = [ByteString] -> ByteString
LBS8.unlines ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
insertAfterVersion ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS8.lines
    | Bool
otherwise = [ByteString] -> ByteString
LBS8.unlines ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
replaceRevision    ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS8.lines
  where
    replaceRevision :: [ByteString] -> [ByteString]
replaceRevision [] = []
    replaceRevision (ByteString
ln:[ByteString]
lns)
      | ByteString -> ByteString -> Bool
isField (String -> ByteString
LBS8.pack String
"x-revision") ByteString
ln
      = String -> ByteString
LBS8.pack (String
"x-revision: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rev) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
lns

      | Bool
otherwise
      = ByteString
ln ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
replaceRevision [ByteString]
lns

    insertAfterVersion :: [ByteString] -> [ByteString]
insertAfterVersion [] = []
    insertAfterVersion (ByteString
ln:[ByteString]
lns)
      | ByteString -> ByteString -> Bool
isField (String -> ByteString
LBS8.pack String
"version") ByteString
ln
      = ByteString
ln ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: String -> ByteString
LBS8.pack (String
"x-revision: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rev) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
lns

      | Bool
otherwise
      = ByteString
ln ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
insertAfterVersion [ByteString]
lns

    isField :: ByteString -> ByteString -> Bool
isField ByteString
nm ByteString
ln
      | ByteString -> ByteString -> Bool
LBS8.isPrefixOf ByteString
nm ((Char -> Char) -> ByteString -> ByteString
LBS8.map Char -> Char
Char.toLower ByteString
ln)
      , let (ByteString
_, ByteString
t) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
LBS8.span (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t')
                             (Int64 -> ByteString -> ByteString
LBS8.drop (ByteString -> Int64
LBS8.length ByteString
nm) ByteString
ln)
      , Just (Char
':',ByteString
_) <- ByteString -> Maybe (Char, ByteString)
LBS8.uncons ByteString
t
                  = Bool
True
      | Bool
otherwise = Bool
False