{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Copyright:   (c) 2023 Bodigrim
-- License:     BSD-3-Clause
--
-- Building blocks of @cabal-add@ executable.
module Distribution.Client.Add (
  parseCabalFile,
  resolveComponent,
  CommonStanza (..),
  validateDependency,
  AddConfig (..),
  executeAddConfig,
  validateChanges,
  TargetField (..),
) where

import Control.Applicative ((<|>))
import Control.Monad (guard)
import Control.Monad.Error.Class (MonadError, throwError)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Internal (isSpaceChar8)
import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as S
import Distribution.CabalSpecVersion (CabalSpecVersion (CabalSpecV1_0, CabalSpecV3_0))
import Distribution.Client.Common (CommonStanza (..), TargetField (..), getTargetName, isComponent, splitAtPosition)
import Distribution.Fields (
  Field (..),
  FieldLine (..),
  Name (..),
  SectionArg (..),
  readFields,
 )
import Distribution.PackageDescription (
  ComponentName (..),
  Dependency,
  GenericPackageDescription (..),
  LibraryName (..),
  PackageDescription (..),
  componentNameString,
  pkgName,
  unPackageName,
  unUnqualComponentName,
 )
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription.Parsec (
  parseGenericPackageDescription,
  parseGenericPackageDescriptionMaybe,
  runParseResult,
 )
import Distribution.Parsec (
  Position (..),
  eitherParsec,
  showPError,
 )
import Distribution.Simple.BuildTarget (
  BuildTarget (BuildTargetComponent),
  readUserBuildTargets,
  resolveBuildTargets,
 )

-- | An input for 'executeAddConfig'.
data AddConfig = AddConfig
  { AddConfig -> ByteString
cnfOrigContents :: !ByteString
  -- ^ Original Cabal file (with quirks patched,
  -- see "Distribution.PackageDescription.Quirks"),
  -- must be in sync with 'cnfFields'.
  , AddConfig -> [Field Position]
cnfFields :: ![Field Position]
  -- ^ Parsed (by 'Distribution.Fields.readFields' or, more specifically, by 'parseCabalFile')
  -- representation of the Cabal file,
  -- must be in sync with 'cnfOrigContents'.
  , AddConfig -> Either CommonStanza ComponentName
cnfComponent :: !(Either CommonStanza ComponentName)
  -- ^ Which component to update?
  -- Usually constructed by 'resolveComponent'.
  , AddConfig -> TargetField
cnfTargetField :: !TargetField
  -- ^ Which field to add the provided content to?
  , AddConfig -> NonEmpty ByteString
cnfAdditions :: !(NonEmpty ByteString)
  -- ^ Which content to add to the target field?
  -- Usually constructed by 'validateDependency'.
  }
  deriving (AddConfig -> AddConfig -> Bool
(AddConfig -> AddConfig -> Bool)
-> (AddConfig -> AddConfig -> Bool) -> Eq AddConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AddConfig -> AddConfig -> Bool
== :: AddConfig -> AddConfig -> Bool
$c/= :: AddConfig -> AddConfig -> Bool
/= :: AddConfig -> AddConfig -> Bool
Eq, Int -> AddConfig -> ShowS
[AddConfig] -> ShowS
AddConfig -> String
(Int -> AddConfig -> ShowS)
-> (AddConfig -> String)
-> ([AddConfig] -> ShowS)
-> Show AddConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddConfig -> ShowS
showsPrec :: Int -> AddConfig -> ShowS
$cshow :: AddConfig -> String
show :: AddConfig -> String
$cshowList :: [AddConfig] -> ShowS
showList :: [AddConfig] -> ShowS
Show)

requiresCommas :: TargetField -> Bool
requiresCommas :: TargetField -> Bool
requiresCommas = \case
  TargetField
BuildDepends -> Bool
True
  TargetField
_ -> Bool
False

extractComponentNames :: GenericPackageDescription -> Set ComponentName
extractComponentNames :: GenericPackageDescription -> Set ComponentName
extractComponentNames GenericPackageDescription {[(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
[(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
[(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
[(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
[(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
[PackageFlag]
Maybe Version
Maybe (CondTree ConfVar [Dependency] Library)
PackageDescription
packageDescription :: PackageDescription
gpdScannedVersion :: Maybe Version
genPackageFlags :: [PackageFlag]
condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
condSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
condExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks :: GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condTestSuites :: GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condExecutables :: GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
condForeignLibs :: GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
condSubLibraries :: GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condLibrary :: GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
genPackageFlags :: GenericPackageDescription -> [PackageFlag]
gpdScannedVersion :: GenericPackageDescription -> Maybe Version
packageDescription :: GenericPackageDescription -> PackageDescription
..} =
  (CondTree ConfVar [Dependency] Library -> Set ComponentName)
-> Maybe (CondTree ConfVar [Dependency] Library)
-> Set ComponentName
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Set ComponentName
-> CondTree ConfVar [Dependency] Library -> Set ComponentName
forall a b. a -> b -> a
const (Set ComponentName
 -> CondTree ConfVar [Dependency] Library -> Set ComponentName)
-> Set ComponentName
-> CondTree ConfVar [Dependency] Library
-> Set ComponentName
forall a b. (a -> b) -> a -> b
$ ComponentName -> Set ComponentName
forall a. a -> Set a
S.singleton (ComponentName -> Set ComponentName)
-> ComponentName -> Set ComponentName
forall a b. (a -> b) -> a -> b
$ LibraryName -> ComponentName
CLibName LibraryName
LMainLibName) Maybe (CondTree ConfVar [Dependency] Library)
condLibrary
    Set ComponentName -> Set ComponentName -> Set ComponentName
forall a. Semigroup a => a -> a -> a
<> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> Set ComponentName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> Set ComponentName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ComponentName -> Set ComponentName
forall a. a -> Set a
S.singleton (ComponentName -> Set ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
    -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> Set ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
    -> LibraryName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> LibraryName
LSubLibName (UnqualComponentName -> LibraryName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> LibraryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries
    Set ComponentName -> Set ComponentName -> Set ComponentName
forall a. Semigroup a => a -> a -> a
<> ((UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
 -> Set ComponentName)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
-> Set ComponentName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ComponentName -> Set ComponentName
forall a. a -> Set a
S.singleton (ComponentName -> Set ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
    -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> Set ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> ComponentName
CFLibName (UnqualComponentName -> ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
condForeignLibs
    Set ComponentName -> Set ComponentName -> Set ComponentName
forall a. Semigroup a => a -> a -> a
<> ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> Set ComponentName)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> Set ComponentName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ComponentName -> Set ComponentName
forall a. a -> Set a
S.singleton (ComponentName -> Set ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
    -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> Set ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> ComponentName
CExeName (UnqualComponentName -> ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condExecutables
    Set ComponentName -> Set ComponentName -> Set ComponentName
forall a. Semigroup a => a -> a -> a
<> ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> Set ComponentName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> Set ComponentName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ComponentName -> Set ComponentName
forall a. a -> Set a
S.singleton (ComponentName -> Set ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
    -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> Set ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> ComponentName
CTestName (UnqualComponentName -> ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites
    Set ComponentName -> Set ComponentName -> Set ComponentName
forall a. Semigroup a => a -> a -> a
<> ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> Set ComponentName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> Set ComponentName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ComponentName -> Set ComponentName
forall a. a -> Set a
S.singleton (ComponentName -> Set ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
    -> ComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> Set ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> ComponentName
CBenchName (UnqualComponentName -> ComponentName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks

extractCommonStanzas :: [Field ann] -> Set CommonStanza
extractCommonStanzas :: forall ann. [Field ann] -> Set CommonStanza
extractCommonStanzas = (Field ann -> Set CommonStanza) -> [Field ann] -> Set CommonStanza
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Field ann -> Set CommonStanza
forall {ann}. Field ann -> Set CommonStanza
go
  where
    go :: Field ann -> Set CommonStanza
go = \case
      Section (Name ann
_ ByteString
"common") [SecArgName ann
_pos ByteString
sectionArg] [Field ann]
_subFields ->
        CommonStanza -> Set CommonStanza
forall a. a -> Set a
S.singleton (CommonStanza -> Set CommonStanza)
-> CommonStanza -> Set CommonStanza
forall a b. (a -> b) -> a -> b
$ ByteString -> CommonStanza
CommonStanza ByteString
sectionArg
      Section (Name ann
_ ByteString
"common") [SecArgStr ann
_pos ByteString
sectionArg] [Field ann]
_subFields ->
        CommonStanza -> Set CommonStanza
forall a. a -> Set a
S.singleton (CommonStanza -> Set CommonStanza)
-> CommonStanza -> Set CommonStanza
forall a b. (a -> b) -> a -> b
$ ByteString -> CommonStanza
CommonStanza ByteString
sectionArg
      Field ann
_ -> Set CommonStanza
forall a. Monoid a => a
mempty

data Resolution a = NotFound | Resolved a | Ambiguous
  deriving ((forall a b. (a -> b) -> Resolution a -> Resolution b)
-> (forall a b. a -> Resolution b -> Resolution a)
-> Functor Resolution
forall a b. a -> Resolution b -> Resolution a
forall a b. (a -> b) -> Resolution a -> Resolution b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Resolution a -> Resolution b
fmap :: forall a b. (a -> b) -> Resolution a -> Resolution b
$c<$ :: forall a b. a -> Resolution b -> Resolution a
<$ :: forall a b. a -> Resolution b -> Resolution a
Functor)

instance Semigroup (Resolution a) where
  a :: Resolution a
a@Resolved {} <> :: Resolution a -> Resolution a -> Resolution a
<> Resolution a
_ = Resolution a
a
  Resolution a
_ <> a :: Resolution a
a@Resolved {} = Resolution a
a
  Resolution a
Ambiguous <> Resolution a
_ = Resolution a
forall a. Resolution a
Ambiguous
  Resolution a
_ <> Resolution a
Ambiguous = Resolution a
forall a. Resolution a
Ambiguous
  Resolution a
NotFound <> Resolution a
NotFound = Resolution a
forall a. Resolution a
NotFound

resolveMainLib :: Set ComponentName -> Resolution ComponentName
resolveMainLib :: Set ComponentName -> Resolution ComponentName
resolveMainLib Set ComponentName
knownNames
  | LibraryName -> ComponentName
CLibName LibraryName
LMainLibName ComponentName -> Set ComponentName -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set ComponentName
knownNames = ComponentName -> Resolution ComponentName
forall a. a -> Resolution a
Resolved (ComponentName -> Resolution ComponentName)
-> ComponentName -> Resolution ComponentName
forall a b. (a -> b) -> a -> b
$ LibraryName -> ComponentName
CLibName LibraryName
LMainLibName
  | Bool
otherwise = Resolution ComponentName
forall a. Resolution a
NotFound

resolveDefaultComponent :: Set ComponentName -> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent :: Set ComponentName
-> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent Set ComponentName
knownNames ComponentName -> Bool
predicate =
  case (ComponentName -> Bool) -> [ComponentName] -> [ComponentName]
forall a. (a -> Bool) -> [a] -> [a]
filter ComponentName -> Bool
predicate (Set ComponentName -> [ComponentName]
forall a. Set a -> [a]
S.toList Set ComponentName
knownNames) of
    [] -> Resolution ComponentName
forall a. Resolution a
NotFound
    [ComponentName
x] -> ComponentName -> Resolution ComponentName
forall a. a -> Resolution a
Resolved ComponentName
x
    [ComponentName]
_ -> Resolution ComponentName
forall a. Resolution a
Ambiguous

isCLibName :: ComponentName -> Bool
isCLibName :: ComponentName -> Bool
isCLibName = \case
  CLibName {} -> Bool
True
  ComponentName
_ -> Bool
False

isCFLibName :: ComponentName -> Bool
isCFLibName :: ComponentName -> Bool
isCFLibName = \case
  CFLibName {} -> Bool
True
  ComponentName
_ -> Bool
False

isCExeName :: ComponentName -> Bool
isCExeName :: ComponentName -> Bool
isCExeName = \case
  CExeName {} -> Bool
True
  ComponentName
_ -> Bool
False

isCTestName :: ComponentName -> Bool
isCTestName :: ComponentName -> Bool
isCTestName = \case
  CTestName {} -> Bool
True
  ComponentName
_ -> Bool
False

isCBenchName :: ComponentName -> Bool
isCBenchName :: ComponentName -> Bool
isCBenchName = \case
  CBenchName {} -> Bool
True
  ComponentName
_ -> Bool
False

resolveToComponentName :: Set ComponentName -> Maybe String -> Resolution ComponentName
resolveToComponentName :: Set ComponentName -> Maybe String -> Resolution ComponentName
resolveToComponentName Set ComponentName
knownNames = \case
  Maybe String
Nothing -> case Set ComponentName -> Maybe (ComponentName, Set ComponentName)
forall a. Set a -> Maybe (a, Set a)
S.minView Set ComponentName
knownNames of
    Just (ComponentName
knownName, Set ComponentName
rest)
      | Set ComponentName -> Bool
forall a. Set a -> Bool
S.null Set ComponentName
rest -> ComponentName -> Resolution ComponentName
forall a. a -> Resolution a
Resolved ComponentName
knownName
    Maybe (ComponentName, Set ComponentName)
_ -> Set ComponentName -> Resolution ComponentName
resolveMainLib Set ComponentName
knownNames
  Just String
name
    -- Cf. Distribution.Simple.BuildTarget.matchComponentKind
    | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"lib", String
"library"] ->
        Set ComponentName -> Resolution ComponentName
resolveMainLib Set ComponentName
knownNames
    | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"flib", String
"foreign-library"] ->
        Set ComponentName
-> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent Set ComponentName
knownNames ComponentName -> Bool
isCFLibName
    | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"exe", String
"executable"] ->
        Set ComponentName
-> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent Set ComponentName
knownNames ComponentName -> Bool
isCExeName
    | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"tst", String
"test", String
"test-suite"] ->
        Set ComponentName
-> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent Set ComponentName
knownNames ComponentName -> Bool
isCTestName
    | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"bench", String
"benchmark"] ->
        Set ComponentName
-> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent Set ComponentName
knownNames ComponentName -> Bool
isCBenchName
    | Bool
otherwise ->
        Set ComponentName
-> (ComponentName -> Bool) -> Resolution ComponentName
resolveDefaultComponent Set ComponentName
knownNames ((ComponentName -> Bool) -> Resolution ComponentName)
-> (ComponentName -> Bool) -> Resolution ComponentName
forall a b. (a -> b) -> a -> b
$ \ComponentName
x -> case ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
x of
          Maybe UnqualComponentName
Nothing -> Bool
False
          Just UnqualComponentName
xs -> UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name

specialComponents :: Set ComponentName -> Set String
specialComponents :: Set ComponentName -> Set String
specialComponents Set ComponentName
knownNames =
  [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$
    (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
isResolvable [String
"lib", String
"flib", String
"exe", String
"test", String
"bench"]
  where
    isResolvable :: String -> Maybe String
isResolvable String
xs = case Set ComponentName -> Maybe String -> Resolution ComponentName
resolveToComponentName Set ComponentName
knownNames (String -> Maybe String
forall a. a -> Maybe a
Just String
xs) of
      Resolved {} -> String -> Maybe String
forall a. a -> Maybe a
Just String
xs
      Resolution ComponentName
_ -> Maybe String
forall a. Maybe a
Nothing

resolveToCommonStanza :: Set CommonStanza -> Maybe String -> Resolution CommonStanza
resolveToCommonStanza :: Set CommonStanza -> Maybe String -> Resolution CommonStanza
resolveToCommonStanza Set CommonStanza
knownNames (Just (ByteString -> CommonStanza
CommonStanza (ByteString -> CommonStanza)
-> (String -> ByteString) -> String -> CommonStanza
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack -> CommonStanza
name))
  | CommonStanza -> Set CommonStanza -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member CommonStanza
name Set CommonStanza
knownNames = CommonStanza -> Resolution CommonStanza
forall a. a -> Resolution a
Resolved CommonStanza
name
resolveToCommonStanza Set CommonStanza
_ Maybe String
_ = Resolution CommonStanza
forall a. Resolution a
NotFound

isSection :: Field ann -> Bool
isSection :: forall ann. Field ann -> Bool
isSection = \case
  Field {} -> Bool
False
  Section {} -> Bool
True

-- | Parse Cabal file into two representations.
parseCabalFile
  :: MonadError String m
  => FilePath
  -- ^ File name, just for error reporting.
  -> ByteString
  -- ^ Contents of the Cabal file.
  -> m ([Field Position], GenericPackageDescription)
  -- ^ Parsed data, suitable for 'resolveComponent'.
parseCabalFile :: forall (m :: * -> *).
MonadError String m =>
String
-> ByteString -> m ([Field Position], GenericPackageDescription)
parseCabalFile String
fileName ByteString
contents = do
  let legacyErr :: String
legacyErr = String
"Legacy, unsectioned Cabal files are unsupported"
      errorWithCtx :: String -> m a
errorWithCtx String
msg =
        String -> m a
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
          String
"Cannot parse input Cabal file "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileName
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" because:\n"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

  [Field Position]
fields <- case ByteString -> Either ParseError [Field Position]
readFields ByteString
contents of
    Left ParseError
err -> String -> m [Field Position]
forall {m :: * -> *} {a}. MonadError String m => String -> m a
errorWithCtx (String -> m [Field Position]) -> String -> m [Field Position]
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right [Field Position]
fs
      | (Field Position -> Bool) -> [Field Position] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Field Position -> Bool
forall ann. Field ann -> Bool
isSection [Field Position]
fs -> [Field Position] -> m [Field Position]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Field Position]
fs
      | Bool
otherwise -> String -> m [Field Position]
forall {m :: * -> *} {a}. MonadError String m => String -> m a
errorWithCtx String
legacyErr

  GenericPackageDescription
packDescr <- case ([PWarning],
 Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
forall a b. (a, b) -> b
snd (([PWarning],
  Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
 -> Either
      (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ 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
contents of
    Left (Maybe Version
_, NonEmpty PError
err) ->
      String -> m GenericPackageDescription
forall {m :: * -> *} {a}. MonadError String m => String -> m a
errorWithCtx (String -> m GenericPackageDescription)
-> String -> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ [String] -> String
L.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PError -> String
showPError String
fileName) ([PError] -> [String]) -> [PError] -> [String]
forall a b. (a -> b) -> a -> b
$ NonEmpty PError -> [PError]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PError
err
    Right GenericPackageDescription {packageDescription :: GenericPackageDescription -> PackageDescription
packageDescription = PackageDescription {specVersion :: PackageDescription -> CabalSpecVersion
specVersion = CabalSpecVersion
CabalSpecV1_0}} ->
      String -> m GenericPackageDescription
forall {m :: * -> *} {a}. MonadError String m => String -> m a
errorWithCtx String
legacyErr
    Right GenericPackageDescription
pd -> GenericPackageDescription -> m GenericPackageDescription
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
pd

  ([Field Position], GenericPackageDescription)
-> m ([Field Position], GenericPackageDescription)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Field Position]
fields, GenericPackageDescription
packDescr)

readBuildTarget :: PackageDescription -> String -> Maybe ComponentName
readBuildTarget :: PackageDescription -> String -> Maybe ComponentName
readBuildTarget PackageDescription
pkg String
targetStr =
  PackageDescription -> String -> Maybe ComponentName
readBuildTarget' PackageDescription
pkg String
targetStr Maybe ComponentName -> Maybe ComponentName -> Maybe ComponentName
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PackageDescription -> String -> Maybe ComponentName
readBuildTarget'' PackageDescription
pkg String
targetStr

readBuildTarget' :: PackageDescription -> String -> Maybe ComponentName
readBuildTarget' :: PackageDescription -> String -> Maybe ComponentName
readBuildTarget' PackageDescription
pkg String
targetStr = do
  let ([UserBuildTargetProblem]
_, [UserBuildTarget]
utargets) = [String] -> ([UserBuildTargetProblem], [UserBuildTarget])
readUserBuildTargets [String
targetStr]
  [UserBuildTarget
utarget] <- [UserBuildTarget] -> Maybe [UserBuildTarget]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UserBuildTarget]
utargets
  let ([BuildTargetProblem]
_, [BuildTarget]
btargets) = PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets PackageDescription
pkg [(UserBuildTarget
utarget, Bool
False)]
  [BuildTargetComponent ComponentName
btarget] <- [BuildTarget] -> Maybe [BuildTarget]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BuildTarget]
btargets
  ComponentName -> Maybe ComponentName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ComponentName
btarget

-- | Surprisingly, 'resolveBuildTargets' does not support package component.
-- Let's work around this limitation manually for now.
readBuildTarget'' :: PackageDescription -> String -> Maybe ComponentName
readBuildTarget'' :: PackageDescription -> String -> Maybe ComponentName
readBuildTarget'' PackageDescription
pkg String
targetStr = do
  (String
pref, Char
':' : String
suff) <- (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
targetStr
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName (PackageDescription -> PackageIdentifier
package PackageDescription
pkg)) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pref
  PackageDescription -> String -> Maybe ComponentName
readBuildTarget' PackageDescription
pkg String
suff

-- | Resolve a raw component name.
resolveComponent
  :: MonadError String m
  => FilePath
  -- ^ File name, just for error reporting.
  -> ([Field a], GenericPackageDescription)
  -- ^ Parsed Cabal file, as returned by 'parseCabalFile'.
  -> Maybe String
  -- ^ Component name (or default component if 'Nothing'),
  -- roughly adhering to the syntax
  -- of [component targets](https://cabal.readthedocs.io/en/3.12/cabal-commands.html#target-forms).
  -> m (Either CommonStanza ComponentName)
  -- ^ Resolved component.
resolveComponent :: forall (m :: * -> *) a.
MonadError String m =>
String
-> ([Field a], GenericPackageDescription)
-> Maybe String
-> m (Either CommonStanza ComponentName)
resolveComponent String
_ ([Field a]
_, GenericPackageDescription
gpd) (Just String
component)
  | Just ComponentName
cmp <- PackageDescription -> String -> Maybe ComponentName
readBuildTarget (GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd) String
component =
      Either CommonStanza ComponentName
-> m (Either CommonStanza ComponentName)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CommonStanza ComponentName
 -> m (Either CommonStanza ComponentName))
-> Either CommonStanza ComponentName
-> m (Either CommonStanza ComponentName)
forall a b. (a -> b) -> a -> b
$ ComponentName -> Either CommonStanza ComponentName
forall a b. b -> Either a b
Right ComponentName
cmp
resolveComponent
  String
fileName
  ([Field a] -> Set CommonStanza
forall ann. [Field ann] -> Set CommonStanza
extractCommonStanzas -> Set CommonStanza
commonStanzas, GenericPackageDescription -> Set ComponentName
extractComponentNames -> Set ComponentName
componentNames)
  Maybe String
component = case Resolution (Either CommonStanza ComponentName)
resolution of
    Resolution (Either CommonStanza ComponentName)
NotFound -> String -> m (Either CommonStanza ComponentName)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m (Either CommonStanza ComponentName))
-> String -> m (Either CommonStanza ComponentName)
forall a b. (a -> b) -> a -> b
$ case Maybe String
component of
      Maybe String
Nothing ->
        String
"Default target component not found in "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileName
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".\n"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
knownTargetsHint
      Just String
cmp ->
        String
"Target component '"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cmp
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' not found in "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileName
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".\n"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
knownTargetsHint
    Resolved Either CommonStanza ComponentName
cmp -> Either CommonStanza ComponentName
-> m (Either CommonStanza ComponentName)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either CommonStanza ComponentName
cmp
    Resolution (Either CommonStanza ComponentName)
Ambiguous ->
      String -> m (Either CommonStanza ComponentName)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m (Either CommonStanza ComponentName))
-> String -> m (Either CommonStanza ComponentName)
forall a b. (a -> b) -> a -> b
$
        String
"Target component is ambiguous.\n"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
knownTargetsHint
    where
      allTargets :: Set String
      allTargets :: Set String
allTargets =
        [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ((ComponentName -> Maybe String) -> [ComponentName] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((UnqualComponentName -> String)
-> Maybe UnqualComponentName -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnqualComponentName -> String
unUnqualComponentName (Maybe UnqualComponentName -> Maybe String)
-> (ComponentName -> Maybe UnqualComponentName)
-> ComponentName
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> Maybe UnqualComponentName
componentNameString) (Set ComponentName -> [ComponentName]
forall a. Set a -> [a]
S.toList Set ComponentName
componentNames))
          Set String -> Set String -> Set String
forall a. Semigroup a => a -> a -> a
<> (CommonStanza -> String) -> Set CommonStanza -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (ByteString -> String
B.unpack (ByteString -> String)
-> (CommonStanza -> ByteString) -> CommonStanza -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommonStanza -> ByteString
unCommonStanza) Set CommonStanza
commonStanzas
          Set String -> Set String -> Set String
forall a. Semigroup a => a -> a -> a
<> Set ComponentName -> Set String
specialComponents Set ComponentName
componentNames

      knownTargetsHint :: String
      knownTargetsHint :: String
knownTargetsHint =
        String
"Specify one with -c: "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " (Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
allTargets)
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."

      resolution :: Resolution (Either CommonStanza ComponentName)
      resolution :: Resolution (Either CommonStanza ComponentName)
resolution =
        (ComponentName -> Either CommonStanza ComponentName)
-> Resolution ComponentName
-> Resolution (Either CommonStanza ComponentName)
forall a b. (a -> b) -> Resolution a -> Resolution b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ComponentName -> Either CommonStanza ComponentName
forall a b. b -> Either a b
Right (Set ComponentName -> Maybe String -> Resolution ComponentName
resolveToComponentName Set ComponentName
componentNames Maybe String
component)
          Resolution (Either CommonStanza ComponentName)
-> Resolution (Either CommonStanza ComponentName)
-> Resolution (Either CommonStanza ComponentName)
forall a. Semigroup a => a -> a -> a
<> (CommonStanza -> Either CommonStanza ComponentName)
-> Resolution CommonStanza
-> Resolution (Either CommonStanza ComponentName)
forall a b. (a -> b) -> Resolution a -> Resolution b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommonStanza -> Either CommonStanza ComponentName
forall a b. a -> Either a b
Left (Set CommonStanza -> Maybe String -> Resolution CommonStanza
resolveToCommonStanza Set CommonStanza
commonStanzas Maybe String
component)

-- | Validate [dependency syntax](https://cabal.readthedocs.io/en/3.12/cabal-package-description-file.html#pkg-field-build-depends),
-- checking whether Cabal would be able to parse it.
validateDependency
  :: MonadError String m
  => CabalSpecVersion
  -- ^ Cabal format version to adhere to.
  -> String
  -- ^ Raw dependency to add.
  -> m ByteString
  -- ^ Validated dependency as 'ByteString' (or an error).
validateDependency :: forall (m :: * -> *).
MonadError String m =>
CabalSpecVersion -> String -> m ByteString
validateDependency CabalSpecVersion
specVer String
d = case String -> Either String Dependency
forall a. Parsec a => String -> Either String a
eitherParsec String
d of
  Right (Dependency
_ :: Dependency)
    | CabalSpecVersion
specVer CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
< CabalSpecVersion
CabalSpecV3_0 Bool -> Bool -> Bool
&& Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
':' String
d ->
        String -> m ByteString
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$
          String
"Cannot use the specified dependency '"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' because cabal-version must be at least 3.0."
    | Bool
otherwise -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
d
  Left String
err ->
    String -> m ByteString
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$
      String
"Cannot parse the specified dependency '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' because:\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err

splitAtPositionLine :: Position -> ByteString -> (ByteString, ByteString)
splitAtPositionLine :: Position -> ByteString -> (ByteString, ByteString)
splitAtPositionLine (Position Int
line Int
_row) = Position -> ByteString -> (ByteString, ByteString)
splitAtPosition (Int -> Int -> Position
Position Int
line Int
1)

findNonImportField :: [Field Position] -> Maybe Position
findNonImportField :: [Field Position] -> Maybe Position
findNonImportField (Section Name Position
_ [SectionArg Position]
_ [Field Position]
subFields : [Field Position]
rest) =
  case (Field Position -> Bool) -> [Field Position] -> [Field Position]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Field Position -> Bool) -> Field Position -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field Position -> Bool
forall ann. Field ann -> Bool
isImportField) [Field Position]
subFields of
    Field Position
fld : [Field Position]
_ -> Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ Field Position -> Position
forall ann. Field ann -> ann
getFieldNameAnn Field Position
fld
    [] -> case [Field Position]
rest of
      Field Position
fld : [Field Position]
_ -> case Field Position -> Position
forall ann. Field ann -> ann
getFieldNameAnn Field Position
fld of
        Position Int
line Int
_ -> Position -> Maybe Position
forall a. a -> Maybe a
Just (Int -> Int -> Position
Position Int
line Int
defaultRow)
      [] -> Position -> Maybe Position
forall a. a -> Maybe a
Just (Int -> Int -> Position
Position Int
forall a. Bounded a => a
maxBound Int
defaultRow)
  where
    defaultRow :: Int
defaultRow = case [Field Position] -> [Field Position]
forall a. [a] -> [a]
reverse [Field Position]
subFields of
      [] -> Int
3
      Field Position
fld : [Field Position]
_ -> case Field Position -> Position
forall ann. Field ann -> ann
getFieldNameAnn Field Position
fld of
        Position Int
_ Int
row -> Int
row
findNonImportField [Field Position]
_ = Maybe Position
forall a. Maybe a
Nothing

isImportField :: Field a -> Bool
isImportField :: forall ann. Field ann -> Bool
isImportField = \case
  Field (Name a
_ ByteString
fieldName) [FieldLine a]
_ -> ByteString
fieldName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"import"
  Section {} -> Bool
False

getFieldNameAnn :: Field ann -> ann
getFieldNameAnn :: forall ann. Field ann -> ann
getFieldNameAnn = \case
  Field (Name ann
ann ByteString
_) [FieldLine ann]
_ -> ann
ann
  Section (Name ann
ann ByteString
_) [SectionArg ann]
_ [Field ann]
_ -> ann
ann

isTargetField :: ByteString -> Field ann -> Bool
isTargetField :: forall ann. ByteString -> Field ann -> Bool
isTargetField ByteString
name = \case
  Field (Name ann
_ ByteString
fieldName) [FieldLine ann]
_ -> ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
fieldName
  Field ann
_ -> Bool
False

detectLeadingSeparator :: ByteString -> Maybe ByteString
detectLeadingSeparator :: ByteString -> Maybe ByteString
detectLeadingSeparator ByteString
xs = case ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
xs of
  Just (Char
',', ByteString
ys) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> ByteString
B.cons Char
',' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
ys
  Just (Char
' ', ByteString
ys) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
ys
  Maybe (Char, ByteString)
_ -> Maybe ByteString
forall a. Maybe a
Nothing

isCommaSeparated :: ByteString -> Bool
isCommaSeparated :: ByteString -> Bool
isCommaSeparated ByteString
xs = Char
',' Char -> ByteString -> Bool
`B.elem` ByteString
xs

dropRepeatingSpaces :: ByteString -> ByteString
dropRepeatingSpaces :: ByteString -> ByteString
dropRepeatingSpaces ByteString
xs = case ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
xs of
  Just (Char
' ', ByteString
ys) -> Char -> ByteString -> ByteString
B.cons Char
' ' ((Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
ys)
  Maybe (Char, ByteString)
_ -> ByteString
xs

-- | Find a target section and insert new
-- fields at the beginning, trying our best
-- to preserve formatting. This often breaks however
-- if there are comments in between target fields.
fancyAddAlgorithm :: AddConfig -> Maybe ByteString
fancyAddAlgorithm :: AddConfig -> Maybe ByteString
fancyAddAlgorithm AddConfig {[Field Position]
cnfFields :: AddConfig -> [Field Position]
cnfFields :: [Field Position]
cnfFields, Either CommonStanza ComponentName
cnfComponent :: AddConfig -> Either CommonStanza ComponentName
cnfComponent :: Either CommonStanza ComponentName
cnfComponent, ByteString
cnfOrigContents :: AddConfig -> ByteString
cnfOrigContents :: ByteString
cnfOrigContents, NonEmpty ByteString
cnfAdditions :: AddConfig -> NonEmpty ByteString
cnfAdditions :: NonEmpty ByteString
cnfAdditions, TargetField
cnfTargetField :: AddConfig -> TargetField
cnfTargetField :: TargetField
cnfTargetField} = do
  [Field Position]
subFields : [[Field Position]]
_ <- [[Field Position]] -> Maybe [[Field Position]]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Field Position]] -> Maybe [[Field Position]])
-> [[Field Position]] -> Maybe [[Field Position]]
forall a b. (a -> b) -> a -> b
$ (Field Position -> Maybe [Field Position])
-> [Field Position] -> [[Field Position]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Either CommonStanza ComponentName
-> Field Position -> Maybe [Field Position]
forall a.
Either CommonStanza ComponentName -> Field a -> Maybe [Field a]
isComponent Either CommonStanza ComponentName
cnfComponent) [Field Position]
cnfFields
  Field Position
targetField <- (Field Position -> Bool)
-> [Field Position] -> Maybe (Field Position)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (ByteString -> Field Position -> Bool
forall ann. ByteString -> Field ann -> Bool
isTargetField (ByteString -> Field Position -> Bool)
-> ByteString -> Field Position -> Bool
forall a b. (a -> b) -> a -> b
$ TargetField -> ByteString
getTargetName TargetField
cnfTargetField) [Field Position]
subFields
  Field Name Position
_ (FieldLine Position
firstDepPos ByteString
_dep : [FieldLine Position]
restDeps) <- Field Position -> Maybe (Field Position)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Field Position
targetField

  -- This is not really the second dependency:
  -- it's a dependency on the next line.
  let secondDepPos :: Maybe Position
secondDepPos = case [FieldLine Position]
restDeps of
        FieldLine Position
pos ByteString
_dep : [FieldLine Position]
_ -> Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pos
        [FieldLine Position]
_ -> Maybe Position
forall a. Maybe a
Nothing
      fillerPred :: Char -> Bool
fillerPred Char
c = Char -> Bool
isSpaceChar8 Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
','

  let (ByteString
rawPref, ByteString
rawSuff) = Position -> ByteString -> (ByteString, ByteString)
splitAtPosition Position
firstDepPos ByteString
cnfOrigContents
      pref :: ByteString
pref = (Char -> Bool) -> ByteString -> ByteString
B.takeWhileEnd Char -> Bool
fillerPred ByteString
rawPref
      suff :: ByteString
suff = (Char -> Bool) -> ByteString -> ByteString
B.takeWhile Char -> Bool
fillerPred ByteString
rawSuff
      prefSuff :: ByteString
prefSuff = ByteString
pref ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
suff
      commaSeparation :: Bool
commaSeparation = ByteString -> Bool
isCommaSeparated ByteString
rawSuff Bool -> Bool -> Bool
|| TargetField -> Bool
requiresCommas TargetField
cnfTargetField
      (ByteString
afterLast, ByteString
inBetween, ByteString
beforeFirst) = case Maybe Position
secondDepPos of
        Maybe Position
Nothing ->
          ( if (Char -> Bool) -> ByteString -> Bool
B.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ByteString
prefSuff Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
commaSeparation then ByteString
pref' else ByteString
"," ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pref'
          , if (Char -> Bool) -> ByteString -> Bool
B.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ByteString
prefSuff Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
commaSeparation then ByteString
prefSuff' else ByteString
"," ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
prefSuff'
          , ByteString
suff
          )
          where
            prefSuff' :: ByteString
prefSuff' = ByteString -> ByteString
dropRepeatingSpaces ByteString
prefSuff
            pref' :: ByteString
pref' = ByteString -> ByteString
dropRepeatingSpaces ByteString
pref
        Just Position
pos ->
          ( if (Char -> Bool) -> ByteString -> Bool
B.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ByteString
suff then ByteString
pref1 else ByteString
prefSuff1
          , ByteString
prefSuff1
          , ByteString
suff
          )
          where
            prefSuff1 :: ByteString
prefSuff1 = ByteString
pref1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
suff1
            ((Char -> Bool) -> ByteString -> ByteString
B.takeWhileEnd Char -> Bool
fillerPred -> ByteString
pref1, (Char -> Bool) -> ByteString -> ByteString
B.takeWhile Char -> Bool
fillerPred -> ByteString
suff1) =
              Position -> ByteString -> (ByteString, ByteString)
splitAtPosition Position
pos ByteString
cnfOrigContents

  let (ByteString
beforeFirstDep, ByteString
afterFirstDep) = Position -> ByteString -> (ByteString, ByteString)
splitAtPosition Position
firstDepPos ByteString
cnfOrigContents
      newFieldContents :: ByteString
newFieldContents = ByteString
beforeFirst ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
inBetween (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ByteString
cnfAdditions) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
afterLast

  let ret :: ByteString
ret = ByteString
beforeFirstDep ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
newFieldContents ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
afterFirstDep
  ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
ret

-- | Find a target section and insert new
-- fields at the beginning. Very limited effort
-- is put into preserving formatting.
niceAddAlgorithm :: AddConfig -> Maybe ByteString
niceAddAlgorithm :: AddConfig -> Maybe ByteString
niceAddAlgorithm AddConfig {[Field Position]
cnfFields :: AddConfig -> [Field Position]
cnfFields :: [Field Position]
cnfFields, Either CommonStanza ComponentName
cnfComponent :: AddConfig -> Either CommonStanza ComponentName
cnfComponent :: Either CommonStanza ComponentName
cnfComponent, ByteString
cnfOrigContents :: AddConfig -> ByteString
cnfOrigContents :: ByteString
cnfOrigContents, NonEmpty ByteString
cnfAdditions :: AddConfig -> NonEmpty ByteString
cnfAdditions :: NonEmpty ByteString
cnfAdditions, TargetField
cnfTargetField :: AddConfig -> TargetField
cnfTargetField :: TargetField
cnfTargetField} = do
  [Field Position]
subFields : [[Field Position]]
_ <- [[Field Position]] -> Maybe [[Field Position]]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Field Position]] -> Maybe [[Field Position]])
-> [[Field Position]] -> Maybe [[Field Position]]
forall a b. (a -> b) -> a -> b
$ (Field Position -> Maybe [Field Position])
-> [Field Position] -> [[Field Position]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Either CommonStanza ComponentName
-> Field Position -> Maybe [Field Position]
forall a.
Either CommonStanza ComponentName -> Field a -> Maybe [Field a]
isComponent Either CommonStanza ComponentName
cnfComponent) [Field Position]
cnfFields
  Field Position
targetField <- (Field Position -> Bool)
-> [Field Position] -> Maybe (Field Position)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (ByteString -> Field Position -> Bool
forall ann. ByteString -> Field ann -> Bool
isTargetField (TargetField -> ByteString
getTargetName TargetField
cnfTargetField)) [Field Position]
subFields
  Field Name Position
_ (FieldLine Position
pos ByteString
_dep : [FieldLine Position]
_) <- Field Position -> Maybe (Field Position)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Field Position
targetField

  let (ByteString
before, ByteString
after) = Position -> ByteString -> (ByteString, ByteString)
splitAtPosition Position
pos ByteString
cnfOrigContents
      (ByteString
_, ByteString
targetHeader) = Position -> ByteString -> (ByteString, ByteString)
splitAtPosition (Field Position -> Position
forall ann. Field ann -> ann
getFieldNameAnn Field Position
targetField) ByteString
before
      leadingSeparatorStyle :: Maybe ByteString
leadingSeparatorStyle = ByteString -> Maybe ByteString
detectLeadingSeparator ByteString
after
      filler :: ByteString
filler = ByteString -> ByteString
dropRepeatingSpaces (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') ByteString
targetHeader
      defaultSep :: ByteString
defaultSep = if ByteString -> Bool
isCommaSeparated ByteString
after Bool -> Bool -> Bool
|| TargetField
cnfTargetField TargetField -> TargetField -> Bool
forall a. Eq a => a -> a -> Bool
== TargetField
BuildDepends then ByteString
"," else ByteString
""
      filler' :: ByteString
filler' = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
defaultSep ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
filler) (ByteString
filler <>) Maybe ByteString
leadingSeparatorStyle
      newFieldContents :: ByteString
newFieldContents =
        ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
leadingSeparatorStyle
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
filler' (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ByteString
cnfAdditions)
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (if Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
leadingSeparatorStyle then ByteString
filler else ByteString
filler')
  ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
    ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
newFieldContents ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
after

-- | Introduce a new target section
-- after the last common stanza import.
-- This is not fancy, but very robust.
roughAddAlgorithm :: AddConfig -> Maybe ByteString
roughAddAlgorithm :: AddConfig -> Maybe ByteString
roughAddAlgorithm AddConfig {[Field Position]
cnfFields :: AddConfig -> [Field Position]
cnfFields :: [Field Position]
cnfFields, Either CommonStanza ComponentName
cnfComponent :: AddConfig -> Either CommonStanza ComponentName
cnfComponent :: Either CommonStanza ComponentName
cnfComponent, ByteString
cnfOrigContents :: AddConfig -> ByteString
cnfOrigContents :: ByteString
cnfOrigContents, NonEmpty ByteString
cnfAdditions :: AddConfig -> NonEmpty ByteString
cnfAdditions :: NonEmpty ByteString
cnfAdditions, TargetField
cnfTargetField :: AddConfig -> TargetField
cnfTargetField :: TargetField
cnfTargetField} = do
  let componentAndRest :: [Field Position]
componentAndRest = (Field Position -> Bool) -> [Field Position] -> [Field Position]
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile (Maybe [Field Position] -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe [Field Position] -> Bool)
-> (Field Position -> Maybe [Field Position])
-> Field Position
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either CommonStanza ComponentName
-> Field Position -> Maybe [Field Position]
forall a.
Either CommonStanza ComponentName -> Field a -> Maybe [Field a]
isComponent Either CommonStanza ComponentName
cnfComponent) [Field Position]
cnfFields
  pos :: Position
pos@(Position Int
_ Int
row) <- [Field Position] -> Maybe Position
findNonImportField [Field Position]
componentAndRest
  let (ByteString
before, ByteString
after) = Position -> ByteString -> (ByteString, ByteString)
splitAtPositionLine Position
pos ByteString
cnfOrigContents
      lineEnding' :: ByteString
lineEnding' = (Char -> Bool) -> ByteString -> ByteString
B.takeWhileEnd Char -> Bool
isSpaceChar8 ByteString
before
      lineEnding :: ByteString
lineEnding = if ByteString -> Bool
B.null ByteString
lineEnding' then ByteString
"\n" else ByteString
lineEnding'
      needsNewlineBefore :: Bool
needsNewlineBefore = Bool
-> ((ByteString, Char) -> Bool) -> Maybe (ByteString, Char) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (Char -> Bool)
-> ((ByteString, Char) -> Char) -> (ByteString, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Char) -> Char
forall a b. (a, b) -> b
snd) (ByteString -> Maybe (ByteString, Char)
B.unsnoc ByteString
before)
      buildDeps :: ByteString
buildDeps =
        (if Bool
needsNewlineBefore then ByteString
lineEnding else ByteString
"")
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
B.replicate (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' '
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (TargetField -> ByteString
getTargetName TargetField
cnfTargetField ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
": ")
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
", " (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ByteString
cnfAdditions)
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
lineEnding
  ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
    ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
buildDeps ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
after

-- | The main workhorse, adding fields to a specified component
-- in the Cabal file.
executeAddConfig
  :: (Either CommonStanza ComponentName -> ByteString -> Bool)
  -- ^ How to validate results? See 'validateChanges'.
  -> AddConfig
  -- ^ Input arguments.
  -> Maybe ByteString
  -- ^ Updated contents, if validated successfully.
executeAddConfig :: (Either CommonStanza ComponentName -> ByteString -> Bool)
-> AddConfig -> Maybe ByteString
executeAddConfig Either CommonStanza ComponentName -> ByteString -> Bool
validator cnf :: AddConfig
cnf@AddConfig {Either CommonStanza ComponentName
cnfComponent :: AddConfig -> Either CommonStanza ComponentName
cnfComponent :: Either CommonStanza ComponentName
cnfComponent} =
  (ByteString -> Bool) -> [ByteString] -> Maybe ByteString
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Either CommonStanza ComponentName -> ByteString -> Bool
validator Either CommonStanza ComponentName
cnfComponent) ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
    ((AddConfig -> Maybe ByteString) -> Maybe ByteString)
-> [AddConfig -> Maybe ByteString] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((AddConfig -> Maybe ByteString) -> AddConfig -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ AddConfig
cnf) [AddConfig -> Maybe ByteString
fancyAddAlgorithm, AddConfig -> Maybe ByteString
niceAddAlgorithm, AddConfig -> Maybe ByteString
roughAddAlgorithm]

-- | Validate that updates did not cause unexpected effects on other sections
-- of the Cabal file.
validateChanges
  :: GenericPackageDescription
  -- ^ Original package description.
  -> Either CommonStanza ComponentName
  -- ^ Which component was supposed to be updated?
  -- Usually constructed by 'resolveComponent'.
  -> ByteString
  -- ^ Updated Cabal file.
  -> Bool
  -- ^ Was the update successful?
validateChanges :: GenericPackageDescription
-> Either CommonStanza ComponentName -> ByteString -> Bool
validateChanges GenericPackageDescription
origPackDesc (Left CommonStanza
_commonStanza) ByteString
newContents =
  case ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
newContents of
    Maybe GenericPackageDescription
Nothing -> Bool
False
    Just GenericPackageDescription
newPackDesc ->
      GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
origPackDesc PackageDescription -> PackageDescription -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
newPackDesc
        Bool -> Bool -> Bool
&& GenericPackageDescription -> Maybe Version
gpdScannedVersion GenericPackageDescription
origPackDesc Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Maybe Version
gpdScannedVersion GenericPackageDescription
newPackDesc
        Bool -> Bool -> Bool
&& GenericPackageDescription -> [PackageFlag]
genPackageFlags GenericPackageDescription
origPackDesc [PackageFlag] -> [PackageFlag] -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> [PackageFlag]
genPackageFlags GenericPackageDescription
newPackDesc
validateChanges GenericPackageDescription
origPackDesc (Right ComponentName
component) ByteString
newContents =
  case ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
newContents of
    Maybe GenericPackageDescription
Nothing -> Bool
False
    Just GenericPackageDescription
newPackDesc ->
      GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
origPackDesc PackageDescription -> PackageDescription -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
newPackDesc
        Bool -> Bool -> Bool
&& GenericPackageDescription -> Maybe Version
gpdScannedVersion GenericPackageDescription
origPackDesc Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Maybe Version
gpdScannedVersion GenericPackageDescription
newPackDesc
        Bool -> Bool -> Bool
&& GenericPackageDescription -> [PackageFlag]
genPackageFlags GenericPackageDescription
origPackDesc [PackageFlag] -> [PackageFlag] -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> [PackageFlag]
genPackageFlags GenericPackageDescription
newPackDesc
        Bool -> Bool -> Bool
&& Bool
mainLibMatch
        Bool -> Bool -> Bool
&& Bool
subLibsMatch
        Bool -> Bool -> Bool
&& Bool
foreignLibsMatch
        Bool -> Bool -> Bool
&& Bool
executablesMatch
        Bool -> Bool -> Bool
&& Bool
testsMatch
        Bool -> Bool -> Bool
&& Bool
benchmarksMatch
      where
        mainLibMatch :: Bool
mainLibMatch = case (GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
origPackDesc, GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
newPackDesc) of
          (Maybe (CondTree ConfVar [Dependency] Library)
Nothing, Maybe (CondTree ConfVar [Dependency] Library)
Nothing) -> Bool
True
          (Just CondTree ConfVar [Dependency] Library
x, Just CondTree ConfVar [Dependency] Library
y) -> ComponentName
component ComponentName -> ComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== LibraryName -> ComponentName
CLibName LibraryName
LMainLibName Bool -> Bool -> Bool
|| CondTree ConfVar [Dependency] Library
x CondTree ConfVar [Dependency] Library
-> CondTree ConfVar [Dependency] Library -> Bool
forall a. Eq a => a -> a -> Bool
== CondTree ConfVar [Dependency] Library
y
          (Maybe (CondTree ConfVar [Dependency] Library),
 Maybe (CondTree ConfVar [Dependency] Library))
_ -> Bool
False

        subLibsMatch :: Bool
subLibsMatch = [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
ys Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> Bool)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> Bool
forall {b}.
Eq b =>
(UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
xs [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
ys)
          where
            xs :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
xs = GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
origPackDesc
            ys :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
ys = GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
newPackDesc
            predicate :: (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate (UnqualComponentName, b)
x (UnqualComponentName, b)
y = (UnqualComponentName, b)
x (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b)
y Bool -> Bool -> Bool
|| ComponentName -> Bool
isCLibName ComponentName
component Bool -> Bool -> Bool
&& (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
y Bool -> Bool -> Bool
&& ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
component Maybe UnqualComponentName -> Maybe UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just ((UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x)

        foreignLibsMatch :: Bool
foreignLibsMatch = [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
ys Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
 -> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
 -> Bool)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> (UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)
-> Bool
forall {b}.
Eq b =>
(UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
xs [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
ys)
          where
            xs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
xs = GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
condForeignLibs GenericPackageDescription
origPackDesc
            ys :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
ys = GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
condForeignLibs GenericPackageDescription
newPackDesc
            predicate :: (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate (UnqualComponentName, b)
x (UnqualComponentName, b)
y = (UnqualComponentName, b)
x (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b)
y Bool -> Bool -> Bool
|| ComponentName -> Bool
isCFLibName ComponentName
component Bool -> Bool -> Bool
&& (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
y Bool -> Bool -> Bool
&& ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
component Maybe UnqualComponentName -> Maybe UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just ((UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x)

        executablesMatch :: Bool
executablesMatch = [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
ys Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> Bool)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> Bool
forall {b}.
Eq b =>
(UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
xs [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
ys)
          where
            xs :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
xs = GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
condExecutables GenericPackageDescription
origPackDesc
            ys :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
ys = GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
condExecutables GenericPackageDescription
newPackDesc
            predicate :: (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate (UnqualComponentName, b)
x (UnqualComponentName, b)
y = (UnqualComponentName, b)
x (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b)
y Bool -> Bool -> Bool
|| ComponentName -> Bool
isCExeName ComponentName
component Bool -> Bool -> Bool
&& (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
y Bool -> Bool -> Bool
&& ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
component Maybe UnqualComponentName -> Maybe UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just ((UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x)

        testsMatch :: Bool
testsMatch = [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
ys Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> Bool)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> Bool
forall {b}.
Eq b =>
(UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
xs [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
ys)
          where
            xs :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
xs = GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites GenericPackageDescription
origPackDesc
            ys :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
ys = GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites GenericPackageDescription
newPackDesc
            predicate :: (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate (UnqualComponentName, b)
x (UnqualComponentName, b)
y = (UnqualComponentName, b)
x (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b)
y Bool -> Bool -> Bool
|| ComponentName -> Bool
isCTestName ComponentName
component Bool -> Bool -> Bool
&& (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
y Bool -> Bool -> Bool
&& ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
component Maybe UnqualComponentName -> Maybe UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just ((UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x)

        benchmarksMatch :: Bool
benchmarksMatch = [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
ys Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> Bool)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> Bool
forall {b}.
Eq b =>
(UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
xs [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
ys)
          where
            xs :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
xs = GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks GenericPackageDescription
origPackDesc
            ys :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
ys = GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks GenericPackageDescription
newPackDesc
            predicate :: (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
predicate (UnqualComponentName, b)
x (UnqualComponentName, b)
y = (UnqualComponentName, b)
x (UnqualComponentName, b) -> (UnqualComponentName, b) -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b)
y Bool -> Bool -> Bool
|| ComponentName -> Bool
isCBenchName ComponentName
component Bool -> Bool -> Bool
&& (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== (UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
y Bool -> Bool -> Bool
&& ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
component Maybe UnqualComponentName -> Maybe UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just ((UnqualComponentName, b) -> UnqualComponentName
forall a b. (a, b) -> a
fst (UnqualComponentName, b)
x)