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 +5/−0
- app/Main.hs +59/−30
- cabal-add.cabal +30/−25
- src/Distribution/Client/Add.hs +77/−93
- src/Distribution/Client/Common.hs +80/−0
- src/Distribution/Client/Rename.hs +144/−0
- tests/Main.hs +75/−2
- tests/UnitTests.hs +676/−0
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+ ]