packages feed

cabal-add 0.1 → 0.2

raw patch · 8 files changed

+1146/−150 lines, 8 filesdep ~Cabaldep ~Cabal-syntaxdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, Cabal-syntax, bytestring, directory, process

API changes (from Hackage documentation)

- Distribution.Client.Add: Config :: !ByteString -> ![Field Position] -> !Either CommonStanza ComponentName -> !NonEmpty ByteString -> Config
- Distribution.Client.Add: [cnfDependencies] :: Config -> !NonEmpty ByteString
- Distribution.Client.Add: data Config
- Distribution.Client.Add: executeConfig :: (Either CommonStanza ComponentName -> ByteString -> Bool) -> Config -> Maybe ByteString
- Distribution.Client.Add: instance GHC.Classes.Eq Distribution.Client.Add.CommonStanza
- Distribution.Client.Add: instance GHC.Classes.Eq Distribution.Client.Add.Config
- Distribution.Client.Add: instance GHC.Classes.Ord Distribution.Client.Add.CommonStanza
- Distribution.Client.Add: instance GHC.Show.Show Distribution.Client.Add.CommonStanza
- Distribution.Client.Add: instance GHC.Show.Show Distribution.Client.Add.Config
+ Distribution.Client.Add: AddConfig :: !ByteString -> ![Field Position] -> !Either CommonStanza ComponentName -> !TargetField -> !NonEmpty ByteString -> AddConfig
+ Distribution.Client.Add: BuildDepends :: TargetField
+ Distribution.Client.Add: ExposedModules :: TargetField
+ Distribution.Client.Add: OtherModules :: TargetField
+ Distribution.Client.Add: [cnfAdditions] :: AddConfig -> !NonEmpty ByteString
+ Distribution.Client.Add: [cnfTargetField] :: AddConfig -> !TargetField
+ Distribution.Client.Add: data AddConfig
+ Distribution.Client.Add: data TargetField
+ Distribution.Client.Add: executeAddConfig :: (Either CommonStanza ComponentName -> ByteString -> Bool) -> AddConfig -> Maybe ByteString
+ Distribution.Client.Add: instance GHC.Classes.Eq Distribution.Client.Add.AddConfig
+ Distribution.Client.Add: instance GHC.Show.Show Distribution.Client.Add.AddConfig
+ Distribution.Client.Rename: BuildDepends :: TargetField
+ Distribution.Client.Rename: CommonStanza :: ByteString -> CommonStanza
+ Distribution.Client.Rename: ExposedModules :: TargetField
+ Distribution.Client.Rename: OtherModules :: TargetField
+ Distribution.Client.Rename: RenameConfig :: !ByteString -> ![Field Position] -> !Either CommonStanza ComponentName -> !TargetField -> !ByteString -> !ByteString -> RenameConfig
+ Distribution.Client.Rename: [cnfComponent] :: RenameConfig -> !Either CommonStanza ComponentName
+ Distribution.Client.Rename: [cnfFields] :: RenameConfig -> ![Field Position]
+ Distribution.Client.Rename: [cnfOrigContents] :: RenameConfig -> !ByteString
+ Distribution.Client.Rename: [cnfRenameFrom] :: RenameConfig -> !ByteString
+ Distribution.Client.Rename: [cnfRenameTo] :: RenameConfig -> !ByteString
+ Distribution.Client.Rename: [cnfTargetField] :: RenameConfig -> !TargetField
+ Distribution.Client.Rename: [unCommonStanza] :: CommonStanza -> ByteString
+ Distribution.Client.Rename: data RenameConfig
+ Distribution.Client.Rename: data TargetField
+ Distribution.Client.Rename: executeRenameConfig :: (Either CommonStanza ComponentName -> ByteString -> Bool) -> RenameConfig -> Maybe ByteString
+ Distribution.Client.Rename: instance GHC.Classes.Eq Distribution.Client.Rename.RenameConfig
+ Distribution.Client.Rename: instance GHC.Show.Show Distribution.Client.Rename.RenameConfig
+ Distribution.Client.Rename: newtype CommonStanza
+ Distribution.Client.Rename: parseCabalFile :: MonadError String m => FilePath -> ByteString -> m ([Field Position], GenericPackageDescription)
+ Distribution.Client.Rename: resolveComponent :: MonadError String m => FilePath -> ([Field a], GenericPackageDescription) -> Maybe String -> m (Either CommonStanza ComponentName)
+ Distribution.Client.Rename: validateChanges :: GenericPackageDescription -> Either CommonStanza ComponentName -> ByteString -> Bool
+ Distribution.Client.Rename: validateDependency :: MonadError String m => CabalSpecVersion -> String -> m ByteString
- Distribution.Client.Add: [cnfComponent] :: Config -> !Either CommonStanza ComponentName
+ Distribution.Client.Add: [cnfComponent] :: AddConfig -> !Either CommonStanza ComponentName
- Distribution.Client.Add: [cnfFields] :: Config -> ![Field Position]
+ Distribution.Client.Add: [cnfFields] :: AddConfig -> ![Field Position]
- Distribution.Client.Add: [cnfOrigContents] :: Config -> !ByteString
+ Distribution.Client.Add: [cnfOrigContents] :: AddConfig -> !ByteString
- Distribution.Client.Add: resolveComponent :: MonadError String m => FilePath -> ([Field Position], GenericPackageDescription) -> Maybe String -> m (Either CommonStanza ComponentName)
+ Distribution.Client.Add: resolveComponent :: MonadError String m => FilePath -> ([Field a], GenericPackageDescription) -> Maybe String -> m (Either CommonStanza ComponentName)

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+## 0.2++* Allow add not only dependencies, but also modules.+* Allow to rename dependencies and modules.+ ## 0.1  * Initial release.
app/Main.hs view
@@ -12,15 +12,15 @@ import Cabal.Project (parseProject, prjPackages, resolveProject) import Control.Exception (throwIO) import Control.Monad (filterM)+import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as B import Data.Either (partitionEithers) import Data.List qualified as L import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, isJust) import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Client.Add-import Distribution.Fields (Field) import Distribution.PackageDescription (   ComponentName,   GenericPackageDescription,@@ -28,7 +28,6 @@   specVersion,  ) import Distribution.PackageDescription.Quirks (patchQuirks)-import Distribution.Parsec (Position) import Options.Applicative (   Parser,   execParser,@@ -45,7 +44,7 @@  ) import Options.Applicative.NonEmpty (some1) import System.Directory (doesFileExist, listDirectory)-import System.Environment (getArgs, withArgs)+import System.Environment (getArgs, lookupEnv, withArgs) import System.Exit (die) import System.FilePath (takeDirectory, (</>)) @@ -128,23 +127,27 @@ stripAdd ("add" : xs) = xs stripAdd xs = xs -type Input =-  ( FilePath-  , ByteString-  , [Field Position]-  , GenericPackageDescription-  , Either-      CommonStanza-      ComponentName-  , NonEmpty ByteString-  )+data Input = Input+  { inpFilePath :: FilePath+  , inpPackageDescription :: GenericPackageDescription+  , inpConfig :: AddConfig+  }+  deriving (Show)  mkInputs   :: Bool+  -- ^ Must the first argument be a component name?+  -- As opposed to interpreting it as one of dependencies to add.   -> FilePath+  -- ^ Cabal file name, primarily for error reporting.+  -- Note that 'mkInputs' does not do any 'IO'.   -> ByteString+  -- ^ Cabal file content.   -> NonEmpty String+  -- ^ List of arguments. The first one is either a component name+  -- or a dependency (see 'Bool' flag above), the rest are dependencies.   -> Either String Input+  -- ^ Either an error or a tuple of input data. mkInputs isCmpRequired cabalFile origContents args = do   (fields, packDescr) <- parseCabalFile cabalFile origContents   let specVer :: CabalSpecVersion@@ -157,35 +160,48 @@     x :| (y : ys)       | Right c <- mkCmp (Just x) ->           (c,) <$> mkDeps (y :| ys)+      | isCmpRequired -> Left $ "Target component '" ++ x ++ "' is not found"     _ ->       if isCmpRequired-        then Left "Component is required"+        then Left "Target component is required"         else (,) <$> mkCmp Nothing <*> mkDeps args-  pure (cabalFile, origContents, fields, packDescr, cmp, deps)+  pure $+    Input+      cabalFile+      packDescr+      AddConfig+        { cnfOrigContents = origContents+        , cnfFields = fields+        , cnfComponent = cmp+        , cnfTargetField = BuildDepends+        , cnfAdditions = deps+        }  disambiguateInputs   :: Maybe FilePath-  -> [FilePath]-  -> [Either a Input]+  -> [(FilePath, Either String Input)]   -> Either String Input-disambiguateInputs mProjectFile cabalFiles inputs = case partitionEithers inputs of+disambiguateInputs mProjectFile inputs = case inputs' of   ([], []) -> Left $ case mProjectFile of     Nothing -> "No Cabal files or projects are found in the current folder, please specify --project-file."     Just projFn -> "No Cabal files are found in " ++ projFn-  (_errs, []) ->+  (errs, []) ->     Left $-      "No matching targets found amongst: "-        ++ L.intercalate ", " cabalFiles-  (_, [inp]) -> pure inp+      L.intercalate "\n" $+        map (\(fn, err) -> "Cannot add a dependency to " ++ fn ++ " because: " ++ err) errs+  (_, [inp]) -> pure $ snd inp   (_, _inps) ->     Left-      "Target component is ambiguous, please specify it as package:type:component. See https://cabal.readthedocs.io/en/latest/cabal-commands.html#target-forms for reference"+      "Cannot add a dependency, because target component is ambiguous. Please specify it as package:type:component. See https://cabal.readthedocs.io/en/latest/cabal-commands.html#target-forms for reference"+  where+    inputs' = partitionEithers $ map (\(fn, e) -> bimap (fn,) (fn,) e) inputs  main :: IO () main = do+  isCabalEnvVarSet <- isJust <$> lookupEnv "CABAL"   rawArgs <- getArgs   RawConfig {..} <--    withArgs (stripAdd rawArgs) $+    withArgs ((if isCabalEnvVarSet then stripAdd else id) rawArgs) $       execParser $         info           (helper <*> parseRawConfig)@@ -196,14 +212,27 @@     catMaybes       <$> traverse (\fn -> fmap (fn,) <$> readCabalFile fn) cabalFiles   let getInput isCmpRequired =-        disambiguateInputs rcnfMProjectFile (fmap fst cabalFilesAndContent) $-          map (\(fn, cnt) -> mkInputs isCmpRequired fn cnt rcnfArgs) cabalFilesAndContent+        disambiguateInputs rcnfMProjectFile $+          map+            (\(fn, cnt) -> (fn, mkInputs isCmpRequired fn cnt rcnfArgs))+            cabalFilesAndContent -  input <- either (const $ either die pure $ getInput True) pure (getInput False)+  input <- case getInput False of+    Right i -> pure i+    Left errFalse -> case rcnfArgs of+      _ :| [] -> die errFalse+      _ -> case getInput True of+        Right i -> pure i+        Left errTrue ->+          die $+            "If the first argument is interpreted as a dependency:\n"+              ++ errFalse+              ++ "\n\nIf the first argument is interpreted as a target component:\n"+              ++ errTrue -  let (cabalFile, cnfOrigContents, cnfFields, origPackDescr, cnfComponent, cnfDependencies) = input+  let Input cabalFile origPackDescr cnf = input -  case executeConfig (validateChanges origPackDescr) (Config {..}) of+  case executeAddConfig (validateChanges origPackDescr) cnf of     Nothing ->       die $         "Cannot extend build-depends in "
cabal-add.cabal view
@@ -1,12 +1,12 @@ cabal-version:   3.0 name:            cabal-add-version:         0.1+version:         0.2 license:         BSD-3-Clause license-file:    LICENSE maintainer:      andrew.lelechenko@gmail.com author:          Bodigrim tested-with:-    ghc ==9.10.1 ghc ==9.8.2 ghc ==9.6.6 ghc ==9.4.8 ghc ==9.2.8+    ghc ==9.12.2 ghc ==9.10.2 ghc ==9.8.4 ghc ==9.6.7 ghc ==9.4.8  synopsis:        Extend Cabal build-depends from the command line description:@@ -25,31 +25,23 @@     type:     git     location: https://github.com/Bodigrim/cabal-add.git -flag cabal-syntax-    default: False- library-    exposed-modules:  Distribution.Client.Add+    exposed-modules:+        Distribution.Client.Add+        Distribution.Client.Rename+     hs-source-dirs:   src+    other-modules:    Distribution.Client.Common     default-language: GHC2021     ghc-options:      -Wall     build-depends:         base <5,         bytestring <0.13,-        Cabal >=3.6 && <3.13,-        containers <0.8,+        Cabal >=3.8 && <3.15,+        Cabal-syntax >=3.8 && <3.15,+        containers <0.9,         mtl <2.4 -    if flag(cabal-syntax)-        build-depends:-            Cabal-syntax >=3.8 && <3.13,-            Cabal >=3.8--    else-        build-depends:-            Cabal-syntax <3.7,-            Cabal <3.7- executable cabal-add     main-is:          Main.hs     hs-source-dirs:   app@@ -60,17 +52,12 @@         bytestring <0.13,         cabal-add,         cabal-install-parsers >=0.4.1 && <0.7,+        Cabal-syntax,         directory <1.4,         filepath <1.6,-        optparse-applicative >=0.16 && <0.19,+        optparse-applicative >=0.16 && <0.20,         process <1.7 -    if flag(cabal-syntax)-        build-depends: Cabal-syntax--    else-        build-depends: Cabal- test-suite cabal-add-tests     type:               exitcode-stdio-1.0     main-is:            Main.hs@@ -80,6 +67,24 @@     ghc-options:        -Wall     build-depends:         base <5,+        Diff >=0.4,+        directory,+        process,+        string-qq,+        tasty,+        temporary++test-suite cabal-add-unit-tests+    type:             exitcode-stdio-1.0+    main-is:          UnitTests.hs+    hs-source-dirs:   tests/+    default-language: GHC2021+    ghc-options:      -Wall+    build-depends:+        base <5,+        bytestring,+        Cabal,+        cabal-add,         Diff >=0.4,         directory,         process,
src/Distribution/Client/Add.hs view
@@ -14,9 +14,10 @@   resolveComponent,   CommonStanza (..),   validateDependency,-  Config (..),-  executeConfig,+  AddConfig (..),+  executeAddConfig,   validateChanges,+  TargetField (..), ) where  import Control.Applicative ((<|>))@@ -28,10 +29,11 @@ import Data.List qualified as L import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (fromMaybe, isJust, mapMaybe)+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 (..),@@ -45,7 +47,6 @@   GenericPackageDescription (..),   LibraryName (..),   PackageDescription (..),-  componentNameStanza,   componentNameString,   pkgName,   unPackageName,@@ -68,29 +69,32 @@   resolveBuildTargets,  ) --- | Just a newtype wrapper, since @Cabal-syntax@ does not provide any.-newtype CommonStanza = CommonStanza {unCommonStanza :: ByteString}-  deriving (Eq, Ord, Show)---- | An input for 'executeConfig'.-data Config = Config+-- | An input for 'executeAddConfig'.+data AddConfig = AddConfig   { cnfOrigContents :: !ByteString   -- ^ Original Cabal file (with quirks patched,   -- see "Distribution.PackageDescription.Quirks"),   -- must be in sync with 'cnfFields'.   , cnfFields :: ![Field Position]-  -- ^ Parsed (by 'readFields' or, more specifically, by 'parseCabalFile')+  -- ^ Parsed (by 'Distribution.Fields.readFields' or, more specifically, by 'parseCabalFile')   -- representation of the Cabal file,   -- must be in sync with 'cnfOrigContents'.   , cnfComponent :: !(Either CommonStanza ComponentName)   -- ^ Which component to update?   -- Usually constructed by 'resolveComponent'.-  , cnfDependencies :: !(NonEmpty ByteString)-  -- ^ Which dependencies to add?+  , cnfTargetField :: !TargetField+  -- ^ Which field to add the provided content to?+  , cnfAdditions :: !(NonEmpty ByteString)+  -- ^ Which content to add to the target field?   -- Usually constructed by 'validateDependency'.   }   deriving (Eq, Show) +requiresCommas :: TargetField -> Bool+requiresCommas = \case+  BuildDepends -> True+  _ -> False+ extractComponentNames :: GenericPackageDescription -> Set ComponentName extractComponentNames GenericPackageDescription {..} =   foldMap (const $ S.singleton $ CLibName LMainLibName) condLibrary@@ -257,7 +261,7 @@   :: MonadError String m   => FilePath   -- ^ File name, just for error reporting.-  -> ([Field Position], GenericPackageDescription)+  -> ([Field a], GenericPackageDescription)   -- ^ Parsed Cabal file, as returned by 'parseCabalFile'.   -> Maybe String   -- ^ Component name (or default component if 'Nothing'),@@ -291,14 +295,19 @@         "Target component is ambiguous.\n"           ++ knownTargetsHint     where+      allTargets :: Set String       allTargets =         S.fromList (mapMaybe (fmap unUnqualComponentName . componentNameString) (S.toList componentNames))           <> S.map (B.unpack . unCommonStanza) commonStanzas           <> specialComponents componentNames++      knownTargetsHint :: String       knownTargetsHint =         "Specify one with -c: "           ++ L.intercalate ", " (S.toList allTargets)           ++ "."++      resolution :: Resolution (Either CommonStanza ComponentName)       resolution =         fmap Right (resolveToComponentName componentNames component)           <> fmap Left (resolveToCommonStanza commonStanzas component)@@ -328,38 +337,9 @@         ++ "' because:\n"         ++ err --- Both lines and rows are 1-based.-splitAtPosition :: Position -> ByteString -> (ByteString, ByteString)-splitAtPosition (Position line row) bs-  | line <= 1 = B.splitAt (row - 1) bs-  | otherwise = case L.drop (line - 2) nls of-      [] -> (bs, mempty)-      nl : _ -> B.splitAt (nl + row) bs-  where-    nls = B.elemIndices '\n' bs- splitAtPositionLine :: Position -> ByteString -> (ByteString, ByteString) splitAtPositionLine (Position line _row) = splitAtPosition (Position line 1) -isComponent :: Either CommonStanza ComponentName -> Field a -> Bool-isComponent (Right cmp) = \case-  Section (Name _ "library") [] _subFields-    | cmp == CLibName LMainLibName ->-        True-  Section (Name _ sectionName) [SecArgName _pos sectionArg] _subFields-    | sectionName <> " " <> sectionArg == B.pack (componentNameStanza cmp) ->-        True-  Section (Name _ sectionName) [SecArgStr _pos sectionArg] _subFields-    | sectionName <> " " <> sectionArg == B.pack (componentNameStanza cmp) ->-        True-  _ -> False-isComponent (Left (CommonStanza commonName)) = \case-  Section (Name _ "common") [SecArgName _pos sectionArg] _subFields ->-    sectionArg == commonName-  Section (Name _ "common") [SecArgStr _pos sectionArg] _subFields ->-    sectionArg == commonName-  _ -> False- findNonImportField :: [Field Position] -> Maybe Position findNonImportField (Section _ _ subFields : rest) =   case filter (not . isImportField) subFields of@@ -385,31 +365,34 @@   Field (Name ann _) _ -> ann   Section (Name ann _) _ _ -> ann -isBuildDependsField :: Field ann -> Bool-isBuildDependsField = \case-  Field (Name _ "build-depends") _ -> True+isTargetField :: ByteString -> Field ann -> Bool+isTargetField name = \case+  Field (Name _ fieldName) _ -> name == fieldName   _ -> False -detectLeadingComma :: ByteString -> Maybe ByteString-detectLeadingComma xs = case B.uncons xs of+detectLeadingSeparator :: ByteString -> Maybe ByteString+detectLeadingSeparator xs = case B.uncons xs of   Just (',', ys) -> Just $ B.cons ',' $ B.takeWhile (== ' ') ys+  Just (' ', ys) -> Just $ B.takeWhile (== ' ') ys   _ -> Nothing +isCommaSeparated :: ByteString -> Bool+isCommaSeparated xs = ',' `B.elem` xs+ dropRepeatingSpaces :: ByteString -> ByteString dropRepeatingSpaces xs = case B.uncons xs of   Just (' ', ys) -> B.cons ' ' (B.dropWhile (== ' ') ys)   _ -> xs --- | Find build-depends section and insert new--- dependencies at the beginning, trying our best+-- | 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 build-depends.-fancyAlgorithm :: Config -> Maybe ByteString-fancyAlgorithm Config {cnfFields, cnfComponent, cnfOrigContents, cnfDependencies} = do-  component <- L.find (isComponent cnfComponent) cnfFields-  Section _ _ subFields <- pure component-  buildDependsField <- L.find isBuildDependsField subFields-  Field _ (FieldLine firstDepPos _dep : restDeps) <- pure buildDependsField+-- if there are comments in between target fields.+fancyAddAlgorithm :: AddConfig -> Maybe ByteString+fancyAddAlgorithm AddConfig {cnfFields, cnfComponent, cnfOrigContents, cnfAdditions, cnfTargetField} = do+  subFields : _ <- pure $ mapMaybe (isComponent cnfComponent) cnfFields+  targetField <- L.find (isTargetField $ getTargetName cnfTargetField) subFields+  Field _ (FieldLine firstDepPos _dep : restDeps) <- pure targetField    -- This is not really the second dependency:   -- it's a dependency on the next line.@@ -418,14 +401,15 @@         _ -> Nothing       fillerPred c = isSpaceChar8 c || c == ',' -  let (B.takeWhileEnd fillerPred -> pref, B.takeWhile fillerPred -> suff) =-        splitAtPosition firstDepPos cnfOrigContents+  let (rawPref, rawSuff) = splitAtPosition firstDepPos cnfOrigContents+      pref = B.takeWhileEnd fillerPred rawPref+      suff = B.takeWhile fillerPred rawSuff       prefSuff = pref <> suff-+      commaSeparation = isCommaSeparated rawSuff || requiresCommas cnfTargetField       (afterLast, inBetween, beforeFirst) = case secondDepPos of         Nothing ->-          ( if B.any (== ',') prefSuff then pref' else "," <> pref'-          , if B.any (== ',') prefSuff then prefSuff' else "," <> prefSuff'+          ( if B.any (== ',') prefSuff || not commaSeparation then pref' else "," <> pref'+          , if B.any (== ',') prefSuff || not commaSeparation then prefSuff' else "," <> prefSuff'           , suff           )           where@@ -442,39 +426,39 @@               splitAtPosition pos cnfOrigContents    let (beforeFirstDep, afterFirstDep) = splitAtPosition firstDepPos cnfOrigContents-      newBuildDeps = beforeFirst <> B.intercalate inBetween (NE.toList cnfDependencies) <> afterLast+      newFieldContents = beforeFirst <> B.intercalate inBetween (NE.toList cnfAdditions) <> afterLast -  let ret = beforeFirstDep <> newBuildDeps <> afterFirstDep+  let ret = beforeFirstDep <> newFieldContents <> afterFirstDep   pure ret --- | Find build-depends section and insert new--- dependencies at the beginning. Very limited effort+-- | Find a target section and insert new+-- fields at the beginning. Very limited effort -- is put into preserving formatting.-niceAlgorithm :: Config -> Maybe ByteString-niceAlgorithm Config {cnfFields, cnfComponent, cnfOrigContents, cnfDependencies} = do-  component <- L.find (isComponent cnfComponent) cnfFields-  Section _ _ subFields <- pure component-  buildDependsField <- L.find isBuildDependsField subFields-  Field _ (FieldLine pos _dep : _) <- pure buildDependsField+niceAddAlgorithm :: AddConfig -> Maybe ByteString+niceAddAlgorithm AddConfig {cnfFields, cnfComponent, cnfOrigContents, cnfAdditions, cnfTargetField} = do+  subFields : _ <- pure $ mapMaybe (isComponent cnfComponent) cnfFields+  targetField <- L.find (isTargetField (getTargetName cnfTargetField)) subFields+  Field _ (FieldLine pos _dep : _) <- pure targetField    let (before, after) = splitAtPosition pos cnfOrigContents-      (_, buildDepsHeader) = splitAtPosition (getFieldNameAnn buildDependsField) before-      filler = dropRepeatingSpaces $ B.drop 1 $ B.dropWhile (/= ':') buildDepsHeader-      leadingCommaStyle = detectLeadingComma after-      filler' = maybe ("," <> filler) (filler <>) leadingCommaStyle-      newBuildDeps =-        fromMaybe "" leadingCommaStyle-          <> B.intercalate filler' (NE.toList cnfDependencies)-          <> (if isJust leadingCommaStyle then filler else filler')+      (_, targetHeader) = splitAtPosition (getFieldNameAnn targetField) before+      leadingSeparatorStyle = detectLeadingSeparator after+      filler = dropRepeatingSpaces $ B.drop 1 $ B.dropWhile (/= ':') targetHeader+      defaultSep = if isCommaSeparated after || cnfTargetField == BuildDepends then "," else ""+      filler' = maybe (defaultSep <> filler) (filler <>) leadingSeparatorStyle+      newFieldContents =+        fromMaybe "" leadingSeparatorStyle+          <> B.intercalate filler' (NE.toList cnfAdditions)+          <> (if isJust leadingSeparatorStyle then filler else filler')   pure $-    before <> newBuildDeps <> after+    before <> newFieldContents <> after --- | Introduce a new build-depends section+-- | Introduce a new target section -- after the last common stanza import. -- This is not fancy, but very robust.-roughAlgorithm :: Config -> Maybe ByteString-roughAlgorithm Config {cnfFields, cnfComponent, cnfOrigContents, cnfDependencies} = do-  let componentAndRest = L.dropWhile (not . isComponent cnfComponent) cnfFields+roughAddAlgorithm :: AddConfig -> Maybe ByteString+roughAddAlgorithm AddConfig {cnfFields, cnfComponent, cnfOrigContents, cnfAdditions, cnfTargetField} = do+  let componentAndRest = L.dropWhile (isNothing . isComponent cnfComponent) cnfFields   pos@(Position _ row) <- findNonImportField componentAndRest   let (before, after) = splitAtPositionLine pos cnfOrigContents       lineEnding' = B.takeWhileEnd isSpaceChar8 before@@ -483,24 +467,24 @@       buildDeps =         (if needsNewlineBefore then lineEnding else "")           <> B.replicate (row - 1) ' '-          <> "build-depends: "-          <> B.intercalate ", " (NE.toList cnfDependencies)+          <> (getTargetName cnfTargetField <> ": ")+          <> B.intercalate ", " (NE.toList cnfAdditions)           <> lineEnding   pure $     before <> buildDeps <> after --- | The main workhorse, adding dependencies to a specified component+-- | The main workhorse, adding fields to a specified component -- in the Cabal file.-executeConfig+executeAddConfig   :: (Either CommonStanza ComponentName -> ByteString -> Bool)   -- ^ How to validate results? See 'validateChanges'.-  -> Config+  -> AddConfig   -- ^ Input arguments.   -> Maybe ByteString   -- ^ Updated contents, if validated successfully.-executeConfig validator cnf@Config {cnfComponent} =+executeAddConfig validator cnf@AddConfig {cnfComponent} =   L.find (validator cnfComponent) $-    mapMaybe ($ cnf) [fancyAlgorithm, niceAlgorithm, roughAlgorithm]+    mapMaybe ($ cnf) [fancyAddAlgorithm, niceAddAlgorithm, roughAddAlgorithm]  -- | Validate that updates did not cause unexpected effects on other sections -- of the Cabal file.@@ -511,7 +495,7 @@   -- ^ Which component was supposed to be updated?   -- Usually constructed by 'resolveComponent'.   -> ByteString-  -- ^ Update Cabal file.+  -- ^ Updated Cabal file.   -> Bool   -- ^ Was the update successful? validateChanges origPackDesc (Left _commonStanza) newContents =
+ src/Distribution/Client/Common.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Copyright:   (c) 2023 Bodigrim+-- License:     BSD-3-Clause+module Distribution.Client.Common (+  CommonStanza (..),+  isComponent,+  splitAtPosition,+  TargetField (..),+  getTargetName,+) where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.List qualified as L+import Distribution.Fields (+  Field (..),+  Name (..),+  SectionArg (..),+ )+import Distribution.PackageDescription (+  ComponentName (..),+  LibraryName (..),+  componentNameStanza,+ )+import Distribution.Parsec.Position (Position (..))++-- | Just a newtype wrapper, since @Cabal-syntax@ does not provide any.+newtype CommonStanza = CommonStanza {unCommonStanza :: ByteString}+  deriving (Eq, Ord, Show)++isComponent :: Either CommonStanza ComponentName -> Field a -> Maybe [Field a]+isComponent (Right cmp) = \case+  Section (Name _ "library") [] subFields+    | cmp == CLibName LMainLibName ->+        Just subFields+  Section (Name _ sectionName) [SecArgName _pos sectionArg] subFields+    | sectionName <> " " <> sectionArg == B.pack (componentNameStanza cmp) ->+        Just subFields+  Section (Name _ sectionName) [SecArgStr _pos sectionArg] subFields+    | sectionName <> " " <> sectionArg == B.pack (componentNameStanza cmp) ->+        Just subFields+  _ -> Nothing+isComponent (Left (CommonStanza commonName)) = \case+  Section (Name _ "common") [SecArgName _pos sectionArg] subFields+    | sectionArg == commonName ->+        Just subFields+  Section (Name _ "common") [SecArgStr _pos sectionArg] subFields+    | sectionArg == commonName ->+        Just subFields+  _ -> Nothing++-- Both lines and rows are 1-based.+splitAtPosition :: Position -> ByteString -> (ByteString, ByteString)+splitAtPosition (Position line row) bs+  | line <= 1 = B.splitAt (row - 1) bs+  | otherwise = case L.drop (line - 2) nls of+      [] -> (bs, mempty)+      nl : _ -> B.splitAt (nl + row) bs+  where+    nls = B.elemIndices '\n' bs++-- | A field in a cabal file, new content can be added to+data TargetField+  = -- | Corresponds to @build-depends@ in the cabal file+    BuildDepends+  | -- | Corresponds to @exposed-modules@ in the cabal file+    ExposedModules+  | -- | Corresponds to @other-modules@ in the cabal file+    OtherModules+  deriving (Eq, Show, Ord)++getTargetName :: TargetField -> ByteString+getTargetName = \case+  BuildDepends -> "build-depends"+  ExposedModules -> "exposed-modules"+  OtherModules -> "other-modules"
+ src/Distribution/Client/Rename.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}++-- |+-- Copyright:   (c) 2023 Bodigrim+-- License:     BSD-3-Clause+module Distribution.Client.Rename (+  parseCabalFile,+  resolveComponent,+  CommonStanza (..),+  validateDependency,+  RenameConfig (..),+  executeRenameConfig,+  validateChanges,+  TargetField (..),+) where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.Char (isPunctuation, isSpace)+import Data.Foldable (fold)+import Data.List qualified as L+import Distribution.Client.Add (+  TargetField (..),+  parseCabalFile,+  resolveComponent,+  validateChanges,+  validateDependency,+ )+import Distribution.Client.Common (CommonStanza (..), getTargetName, isComponent, splitAtPosition)+import Distribution.Fields (+  Field (..),+  FieldLine (..),+  Name (..),+  SectionArg (..),+ )+import Distribution.PackageDescription (+  ComponentName (..),+ )+import Distribution.Parsec (+  Position (..),+ )++-- | An input for 'executeRenameConfig'.+data RenameConfig = RenameConfig+  { cnfOrigContents :: !ByteString+  -- ^ Original Cabal file (with quirks patched,+  -- see "Distribution.PackageDescription.Quirks"),+  -- must be in sync with 'cnfFields'.+  , cnfFields :: ![Field Position]+  -- ^ Parsed (by 'Distribution.Fields.readFields' or, more specifically, by 'parseCabalFile')+  -- representation of the Cabal file,+  -- must be in sync with 'cnfOrigContents'.+  , cnfComponent :: !(Either CommonStanza ComponentName)+  -- ^ Which component to update?+  -- Usually constructed by 'resolveComponent'.+  , cnfTargetField :: !TargetField+  -- ^ In which field to rename the provided content?+  , cnfRenameFrom :: !ByteString+  -- ^ Rename what?+  , cnfRenameTo :: !ByteString+  -- ^ Rename to what?+  }+  deriving (Eq, Show)++-- | The main workhorse, renaming fields in a specified component+-- in the Cabal file.+executeRenameConfig+  :: (Either CommonStanza ComponentName -> ByteString -> Bool)+  -- ^ How to validate results? See 'validateChanges'.+  -> RenameConfig+  -- ^ Input arguments.+  -> Maybe ByteString+  -- ^ Updated contents, if validated successfully.+executeRenameConfig !_ RenameConfig {cnfRenameFrom}+  | B.null cnfRenameFrom = Nothing+executeRenameConfig validator RenameConfig {cnfFields, cnfComponent, cnfOrigContents, cnfRenameFrom, cnfRenameTo, cnfTargetField} = do+  let fieldsWithSource = annotateFieldsWithSource cnfOrigContents cnfFields+      fieldsWithSource' = map replaceInSection fieldsWithSource+      newContents = foldMap fold fieldsWithSource'+  if validator cnfComponent newContents then Just newContents else Nothing+  where+    replaceInBS :: ByteString -> ByteString+    replaceInBS hay+      | B.null rest =+          hay+      | not startsWithBoundary || not endsWithBoundary =+          pref <> cnfRenameFrom <> replaceInBS suff+      | otherwise =+          pref <> cnfRenameTo <> replaceInBS suff+      where+        (pref, rest) = B.breakSubstring cnfRenameFrom hay+        suff = B.drop (B.length cnfRenameFrom) rest+        isTokenBoundary c = (isSpace c || isPunctuation c || c `elem` "^>=<") && c /= '-' && c /= '.'+        startsWithBoundary = maybe True (isTokenBoundary . snd) (B.unsnoc pref)+        endsWithBoundary = maybe True (isTokenBoundary . fst) (B.uncons suff)++    replaceInFieldLine :: FieldLine ByteString -> FieldLine ByteString+    replaceInFieldLine (FieldLine ann cnt) = FieldLine (replaceInBS ann) (replaceInBS cnt)++    replaceInField :: Field ByteString -> Field ByteString+    replaceInField = \case+      Field name@(Name _ann fieldName) fls+        | fieldName == getTargetName cnfTargetField ->+            Field name (map replaceInFieldLine fls)+      fld@Field {} -> fld+      Section name args subFields -> Section name args (map replaceInField subFields)++    replaceInSection :: Field ByteString -> Field ByteString+    replaceInSection = \case+      sct@(Section name args subFields) -> Section name args (map func subFields)+        where+          func = case isComponent cnfComponent sct of+            Nothing -> replaceInSection+            Just {} -> replaceInField+      fld@Field {} -> fld++annotateFieldsWithSource :: ByteString -> [Field Position] -> [Field ByteString]+annotateFieldsWithSource bs = snd . L.mapAccumR annotateField maxBoundPos+  where+    annotateField :: Position -> Field Position -> (Position, Field ByteString)+    annotateField finishPos = \case+      Field (Name pos name) fls -> (pos, Field (Name (getSrcBetween pos finishPos') name) fls')+        where+          (finishPos', fls') = L.mapAccumR annotateFieldLine finishPos fls+      Section (Name pos name) args fs -> (pos, Section (Name (getSrcBetween pos finishPos'') name) args' fs')+        where+          (finishPos', fs') = L.mapAccumR annotateField finishPos fs+          (finishPos'', args') = L.mapAccumR annotateSectionArg finishPos' args++    annotateFieldLine :: Position -> FieldLine Position -> (Position, FieldLine ByteString)+    annotateFieldLine finishPos (FieldLine pos xs) = (pos, FieldLine (getSrcBetween pos finishPos) xs)++    annotateSectionArg :: Position -> SectionArg Position -> (Position, SectionArg ByteString)+    annotateSectionArg finishPos = \case+      SecArgName pos xs -> (pos, SecArgName (getSrcBetween pos finishPos) xs)+      SecArgStr pos xs -> (pos, SecArgStr (getSrcBetween pos finishPos) xs)+      SecArgOther pos xs -> (pos, SecArgOther (getSrcBetween pos finishPos) xs)++    getSrcBetween :: Position -> Position -> ByteString+    getSrcBetween from to = snd $ splitAtPosition from $ fst $ splitAtPosition to bs++    maxBoundPos :: Position+    maxBoundPos = Position maxBound maxBound
tests/Main.hs view
@@ -14,13 +14,14 @@ import System.Directory (findExecutable) import System.Exit (ExitCode (..)) import System.IO.Temp (withSystemTempDirectory)-import System.Process (cwd, proc, readCreateProcessWithExitCode)+import System.Process (cwd, env, proc, readCreateProcessWithExitCode) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Providers (IsTest (..), singleTest, testFailed, testPassed)  data CabalAddTest = CabalAddTest   { catName :: String   , catArgs :: [String]+  , catEnv :: [(String, String)]   , catInput :: String   , catOutput :: String   }@@ -36,7 +37,7 @@         withSystemTempDirectory template $ \tempDir -> do           let cabalFileName = tempDir ++ "/" ++ template ++ ".cabal"           writeFile cabalFileName catInput-          let crpr = (proc cabalAddExe catArgs) {cwd = Just tempDir}+          let crpr = (proc cabalAddExe catArgs) {cwd = Just tempDir, env = Just catEnv}           (code, _out, err) <- readCreateProcessWithExitCode crpr ""           case code of             ExitFailure {} -> pure $ testFailed err@@ -66,6 +67,7 @@     CabalAddTest       { catName = "add multiple dependencies 1"       , catArgs = ["foo < 1 && >0.7", "baz ^>= 2.0"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -98,6 +100,7 @@     CabalAddTest       { catName = "add multiple dependencies 2"       , catArgs = ["foo < 1 && >0.7", "baz ^>= 2.0"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -126,6 +129,7 @@     CabalAddTest       { catName = "add multiple dependencies 3"       , catArgs = ["foo < 1 && >0.7", "baz ^>= 2.0"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -158,6 +162,7 @@     CabalAddTest       { catName = "add multiple dependencies 4"       , catArgs = ["foo < 1 && >0.7", "baz ^>= 2.0"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -192,6 +197,7 @@     CabalAddTest       { catName = "word 'library' in description"       , catArgs = ["foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -228,6 +234,7 @@     CabalAddTest       { catName = "import fields 1"       , catArgs = ["foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 2.2@@ -265,6 +272,7 @@     CabalAddTest       { catName = "import fields 2"       , catArgs = ["foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 2.2@@ -302,6 +310,7 @@     CabalAddTest       { catName = "import fields 3"       , catArgs = ["foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 2.2@@ -337,6 +346,7 @@     CabalAddTest       { catName = "sublibrary target 1"       , catArgs = ["foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -369,6 +379,7 @@     CabalAddTest       { catName = "sublibrary target 2"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -409,6 +420,7 @@     CabalAddTest       { catName = "executable target 1"       , catArgs = ["exe", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -443,6 +455,7 @@     CabalAddTest       { catName = "executable target 2"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -477,6 +490,7 @@     CabalAddTest       { catName = "executable target 3"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -511,6 +525,7 @@     CabalAddTest       { catName = "executable target 4"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -551,6 +566,7 @@     CabalAddTest       { catName = "test target 1"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -593,6 +609,7 @@     CabalAddTest       { catName = "test target 2"       , catArgs = ["test:baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -635,6 +652,7 @@     CabalAddTest       { catName = "common stanza as a target 1"       , catArgs = ["foo", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -664,6 +682,7 @@     CabalAddTest       { catName = "common stanza as a target 2"       , catArgs = ["foo", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -700,6 +719,7 @@     CabalAddTest       { catName = "two spaces in stanza"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -734,6 +754,7 @@     CabalAddTest       { catName = "title case in stanza 1"       , catArgs = ["foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -766,6 +787,7 @@     CabalAddTest       { catName = "title case in stanza 2"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -800,6 +822,7 @@     CabalAddTest       { catName = "title case in build-depends"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -834,6 +857,7 @@     CabalAddTest       { catName = "shared component prefixes"       , catArgs = ["baz", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| name:          dummy@@ -878,6 +902,7 @@     CabalAddTest       { catName = "Windows line endings"       , catArgs = ["exe", "foo < 1 && >0.7", "quux < 1"]+      , catEnv = mempty       , catInput =           convertToWindowsLineEndings             [s|@@ -912,6 +937,7 @@     CabalAddTest       { catName = "build-depends start from comma 1"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -944,6 +970,7 @@     CabalAddTest       { catName = "build-depends start from comma 2"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -972,6 +999,7 @@     CabalAddTest       { catName = "build-depends start from comma 3"       , catArgs = ["baz ^>= 2.0", "quux > 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1004,6 +1032,7 @@     CabalAddTest       { catName = "build-depends are under condition"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1037,6 +1066,7 @@     CabalAddTest       { catName = "empty component 1"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1071,6 +1101,7 @@     CabalAddTest       { catName = "empty component 2"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1098,6 +1129,7 @@     CabalAddTest       { catName = "empty component 3"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1124,6 +1156,7 @@     CabalAddTest       { catName = "empty build-depends"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1153,6 +1186,7 @@     CabalAddTest       { catName = "component in figure braces"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1183,6 +1217,7 @@     CabalAddTest       { catName = "comments with commas"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1219,6 +1254,7 @@     CabalAddTest       { catName = "comments without commas"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1253,6 +1289,7 @@     CabalAddTest       { catName = "all build-deps on the same line"       , catArgs = ["baz ^>= 2.0", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1281,6 +1318,7 @@     CabalAddTest       { catName = "ignore add as the first command-line argument"       , catArgs = ["add", "baz ^>= 2.0", "quux < 1"]+      , catEnv = [("CABAL", "/fake/usr/bin/local/cabal")]       , catInput =           [s| cabal-version: 3.6@@ -1309,6 +1347,7 @@     CabalAddTest       { catName = "do not ignore add as the second command-line argument"       , catArgs = ["baz ^>= 2.0", "add", "quux < 1"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1337,6 +1376,7 @@     CabalAddTest       { catName = "sublibrary as a dependency"       , catArgs = ["foo:bar"]+      , catEnv = mempty       , catInput =           [s| cabal-version: 3.6@@ -1359,6 +1399,38 @@ |]       } +caseSpecialDependencyName1 :: TestTree+caseSpecialDependencyName1 =+  mkTest $+    CabalAddTest+      { catName = "add dependency named 'add'"+      , catArgs = ["add"]+      , catEnv = mempty+      , catInput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+|]+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    add,+    base >=4.15 && <5+|]+      }+ main :: IO () main =   defaultMain $@@ -1403,4 +1475,5 @@       , caseIgnoreAddArgument       , caseDoNotIgnoreAddArgument       , caseSublibraryDependency+      , caseSpecialDependencyName1       ]
+ tests/UnitTests.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Copyright:   (c) 2023 Bodigrim+-- License:     BSD-3-Clause+module Main (main) where++import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff)+import Data.ByteString.Char8 qualified as B+import Data.List.NonEmpty qualified as NE+import Data.Maybe (mapMaybe)+import Data.String.QQ (s)+import Distribution.Client.Add (AddConfig (..), TargetField (..), executeAddConfig, parseCabalFile)+import Distribution.Client.Rename (RenameConfig (..), executeRenameConfig)+import Distribution.Fields.Field (Field)+import Distribution.PackageDescription (ComponentName (..), LibraryName (..))+import Distribution.Parsec.Position (Position)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Providers (IsTest (..), singleTest, testFailed, testPassed)++data CabalAddTest = CabalAddTest+  { catName :: String+  , catConfig :: AddConfig+  , catOutput :: String+  }++instance IsTest CabalAddTest where+  testOptions = pure []++  run _opts CabalAddTest {..} _yieldProgress = do+    let outputM = executeAddConfig (const $ const True) catConfig+    case outputM of+      Nothing -> pure $ testFailed "config could not be applied"+      Just output ->+        pure $+          if B.unpack output == catOutput+            then testPassed ""+            else testFailed $ prettyDiff $ getDiff (lines catOutput) (lines (B.unpack output))++data CabalRenameTest = CabalRenameTest+  { crtName :: String+  , crtConfig :: RenameConfig+  , crtOutput :: String+  }++instance IsTest CabalRenameTest where+  testOptions = pure []++  run _opts CabalRenameTest {..} _yieldProgress = do+    let outputM = executeRenameConfig (const $ const True) crtConfig+    case outputM of+      Nothing -> pure $ testFailed "config could not be applied"+      Just output ->+        pure $+          if B.unpack output == crtOutput+            then testPassed ""+            else testFailed $ prettyDiff $ getDiff (lines crtOutput) (lines (B.unpack output))++parseCabalFileOrError :: B.ByteString -> [Field Position]+parseCabalFileOrError inContents = case parseCabalFile "" inContents of+  Right (fields, _) -> fields+  Left err -> error $ "Failed to parse cabal file with error: " <> err++caseMultipleBuildDependencies1 :: TestTree+caseMultipleBuildDependencies1 =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple dependencies 1"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfAdditions = NE.fromList ["foo < 1 && >0.7", "baz ^>= 2.0"]+            , cnfTargetField = BuildDepends+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    foo < 1 && >0.7,+    baz ^>= 2.0,+    base >=4.15 && <5+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+|]++caseMultipleExposedModules1 :: TestTree+caseMultipleExposedModules1 =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple exposed modules 1"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfAdditions = NE.fromList ["Test.Mod1", "Test.Mod2"]+            , cnfTargetField = ExposedModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2, Main, OtherModule.Mine+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Main, OtherModule.Mine+|]++caseMultipleExposedModulesUsingSpaces :: TestTree+caseMultipleExposedModulesUsingSpaces =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple exposed modules with spaces"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfAdditions = NE.fromList ["Test.Mod1", "Test.Mod2"]+            , cnfTargetField = ExposedModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1 Test.Mod2 Main OtherModule.Mine+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Main OtherModule.Mine+|]++caseMultipleOtherModules :: TestTree+caseMultipleOtherModules =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple other modules"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CTestName "testss"+            , cnfAdditions = NE.fromList ["Test.Mod1", "Mod3"]+            , cnfTargetField = OtherModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1 Test.Mod2+test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:+    Test.Mod1,+    Mod3,+    Dir.Mod1,+    Dir.Mod2+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1 Test.Mod2+test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:+    Dir.Mod1,+    Dir.Mod2+|]++caseMultipleOtherModulesUsingSpaces :: TestTree+caseMultipleOtherModulesUsingSpaces =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple other modules with space separators"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CTestName "testss"+            , cnfAdditions = NE.fromList ["Test.Mod1", "Mod3"]+            , cnfTargetField = OtherModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:+    Test.Mod1+    Mod3+    Dir.Mod1+    Dir.Mod2++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:+    Dir.Mod1+    Dir.Mod2++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2+|]++caseMultipleOtherModulesUsingLeadingCommas :: TestTree+caseMultipleOtherModulesUsingLeadingCommas =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple other modules preserving leading commas"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CTestName "testss"+            , cnfAdditions = NE.fromList ["Test.Mod1", "Mod3"]+            , cnfTargetField = OtherModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:  Test.Mod1+                , Mod3+                , Dir.Mod1+                , Dir.Mod2++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:  Dir.Mod1+                , Dir.Mod2++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2+|]++caseMultipleOtherModulesUsingLeadingSpaces :: TestTree+caseMultipleOtherModulesUsingLeadingSpaces =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple other modules preserving leading spaces"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CTestName "testss"+            , cnfAdditions = NE.fromList ["Test.Mod1", "Mod3"]+            , cnfTargetField = OtherModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:  Test.Mod1+                  Mod3+                  Dir.Mod1+                  Dir.Mod2++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++test-suite testss+  main-is: Main.hs+  type: exitcode-stdio-1.0+  other-modules:  Dir.Mod1+                  Dir.Mod2++library+  build-depends:+    base >=4.15 && <5+  exposed-modules: Test.Mod1, Test.Mod2+|]++caseMultipleOtherModulesWithImportFields :: TestTree+caseMultipleOtherModulesWithImportFields =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple other modules with import field"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfAdditions = NE.fromList ["This.Dir.Mod1", "Mod3"]+            , cnfTargetField = OtherModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+cabal-version: 2.2+name:          dummy+version:       0.13.0.0+build-type:    Simple++common foo+  build-depends: bar+  other-modules: Other++library+  import: foo+  other-modules: This.Dir.Mod1, Mod3+  build-depends: foo < 1 && >0.7, quux < 1+  exposed-modules: Foo+|]+      }+  where+    inContents =+      [s|+cabal-version: 2.2+name:          dummy+version:       0.13.0.0+build-type:    Simple++common foo+  build-depends: bar+  other-modules: Other++library+  import: foo+  build-depends: foo < 1 && >0.7, quux < 1+  exposed-modules: Foo+|]++caseMultipleOtherModulesWithImportFields2 :: TestTree+caseMultipleOtherModulesWithImportFields2 =+  mkAddTest $+    CabalAddTest+      { catName = "add multiple other modules with capitalised import field"+      , catConfig =+          AddConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfAdditions = NE.fromList ["This.Dir.Mod1", "Mod3"]+            , cnfTargetField = OtherModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            }+      , catOutput =+          [s|+cabal-version: 2.2+name:          dummy+version:       0.13.0.0+build-type:    Simple++common foo+  build-depends: bar+  other-modules: Other++library+  Import: foo+  other-modules: This.Dir.Mod1, Mod3+  build-depends: foo < 1 && >0.7, quux < 1+  exposed-modules: Foo+|]+      }+  where+    inContents =+      [s|+cabal-version: 2.2+name:          dummy+version:       0.13.0.0+build-type:    Simple++common foo+  build-depends: bar+  other-modules: Other++library+  Import: foo+  build-depends: foo < 1 && >0.7, quux < 1+  exposed-modules: Foo+|]++caseRenameDependency1 :: TestTree+caseRenameDependency1 =+  mkRenameTest $+    CabalRenameTest+      { crtName = "rename dependency 1"+      , crtConfig =+          RenameConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfTargetField = BuildDepends+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            , cnfRenameFrom = "base"+            , cnfRenameTo = "relude"+            }+      , crtOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    relude >=4.15 && <5,+    base-foo,+    foo-base++benchmark foo+  type: exitcode-stdio-1.0+  main-is: Main+  build-depends: base+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base >=4.15 && <5,+    base-foo,+    foo-base++benchmark foo+  type: exitcode-stdio-1.0+  main-is: Main+  build-depends: base+|]++caseRenameDependency2 :: TestTree+caseRenameDependency2 =+  mkRenameTest $+    CabalRenameTest+      { crtName = "rename dependency 2"+      , crtConfig =+          RenameConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfTargetField = BuildDepends+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            , cnfRenameFrom = "base"+            , cnfRenameTo = "relude"+            }+      , crtOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    relude>=4, relude<4, relude==4.9.0.0, relude^>=4.0, relude(>4 && <5)+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  build-depends:+    base>=4, base<4, base==4.9.0.0, base^>=4.0, base(>4 && <5)+|]++caseRenameExposedModule1 :: TestTree+caseRenameExposedModule1 =+  mkRenameTest $+    CabalRenameTest+      { crtName = "rename exposed module"+      , crtConfig =+          RenameConfig+            { cnfComponent = Right $ CLibName LMainLibName+            , cnfTargetField = ExposedModules+            , cnfFields = parseCabalFileOrError inContents+            , cnfOrigContents = inContents+            , cnfRenameFrom = "Data.Foo"+            , cnfRenameTo = "Data.Quux"+            }+      , crtOutput =+          [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  exposed-modules: Data.Quux, Data.Foo.Bar, Data.Foo.Baz++benchmark foo+  type: exitcode-stdio-1.0+  main-is: Main+  exposed-modules: Data.Foo+|]+      }+  where+    inContents =+      [s|+name:          dummy+version:       0.13.0.0+cabal-version: 2.0+build-type:    Simple++library+  exposed-modules: Data.Foo, Data.Foo.Bar, Data.Foo.Baz++benchmark foo+  type: exitcode-stdio-1.0+  main-is: Main+  exposed-modules: Data.Foo+|]++prettyDiff :: [Diff String] -> String+prettyDiff =+  unlines+    . mapMaybe+      ( \case+          First xs -> Just $ '-' : xs+          Second ys -> Just $ '+' : ys+          Both xs _ -> Just $ ' ' : xs+      )++mkAddTest :: CabalAddTest -> TestTree+mkAddTest cat = singleTest (catName cat) cat++mkRenameTest :: CabalRenameTest -> TestTree+mkRenameTest cat = singleTest (crtName cat) cat++main :: IO ()+main =+  defaultMain $+    testGroup+      "All Unit Tests"+      [ caseMultipleBuildDependencies1+      , caseMultipleExposedModules1+      , caseMultipleExposedModulesUsingSpaces+      , caseMultipleOtherModules+      , caseMultipleOtherModulesUsingSpaces+      , caseMultipleOtherModulesUsingLeadingCommas+      , caseMultipleOtherModulesUsingLeadingSpaces+      , caseMultipleOtherModulesWithImportFields+      , caseMultipleOtherModulesWithImportFields2+      , caseRenameDependency1+      , caseRenameDependency2+      , caseRenameExposedModule1+      ]