diff --git a/cabal-bounds.cabal b/cabal-bounds.cabal --- a/cabal-bounds.cabal +++ b/cabal-bounds.cabal @@ -1,5 +1,5 @@ name: cabal-bounds -version: 0.2.1 +version: 0.3 cabal-version: >=1.9.2 build-type: Simple license: BSD3 @@ -164,41 +164,35 @@ library build-depends: base >=3 && <5, cmdargs >=0.10.5 && <0.11, - lens >=4.0.1 && <4.1, strict >=0.3.2 && <0.4, - unordered-containers >=0.2.3.3 && <0.3, Cabal >=1.18.0 && <1.19 + lens >=4.0.1 && <4.2, strict >=0.3.2 && <0.4, + unordered-containers >=0.2.3.3 && <0.3, + transformers >=0.3.0.0 && <0.4, either >=4.1.1 && <4.2, + Cabal >=1.18.0 && <1.19 exposed-modules: CabalBounds.Args CabalBounds.Main CabalBounds.VersionComp exposed: True buildable: True cpp-options: -DCABAL - hs-source-dirs: src + hs-source-dirs: lib other-modules: Paths_cabal_bounds CabalBounds.Bound - CabalBounds.Targets CabalBounds.Dependencies CabalBounds.Drop + CabalBounds.Sections CabalBounds.Dependencies CabalBounds.Drop CabalBounds.Update CabalBounds.Lenses ghc-options: -W executable cabal-bounds - build-depends: base >=3 && <5, cmdargs >=0.10.5 && <0.11, - lens >=4.0.1 && <4.1, strict >=0.3.2 && <0.4, - unordered-containers >=0.2.3.3 && <0.3, Cabal >=1.18.0 && <1.19 + build-depends: base >=3 && <5, cabal-bounds -any main-is: Main.hs buildable: True - cpp-options: -DCABAL - hs-source-dirs: src - other-modules: Paths_cabal_bounds CabalBounds.Args - CabalBounds.Bound CabalBounds.Targets CabalBounds.Dependencies - CabalBounds.Drop CabalBounds.Update CabalBounds.Lenses - CabalBounds.VersionComp CabalBounds.Main + hs-source-dirs: exe ghc-options: -W test-suite cabal-bounds-tests - build-depends: base >=3 && <5, cmdargs >=0.10.5 && <0.11, - lens >=4.0.1 && <4.1, strict >=0.3.2 && <0.4, - unordered-containers >=0.2.3.3 && <0.3, Cabal >=1.18.0 && <1.19, - tasty ==0.7.*, tasty-golden >=2.2.0.2 && <2.3, - filepath >=1.3.0.1 && <1.4, cabal-bounds -any + build-depends: base >=3 && <5, tasty >=0.7 && <0.9, + tasty-golden >=2.2.0.2 && <2.3, filepath >=1.3.0.1 && <1.4, + cabal-bounds -any type: exitcode-stdio-1.0 - main-is: tests/Main.hs + main-is: Main.hs buildable: True + hs-source-dirs: tests ghc-options: -W diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,15 @@ + +module Main where + +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStrLn, stderr) +import qualified CabalBounds.Args as Args +import CabalBounds.Main (cabalBounds) + +main :: IO () +main = do + args <- Args.get + error <- cabalBounds args + case error of + Just err -> hPutStrLn stderr ("cabal-bounds: " ++ err) >> exitFailure + _ -> exitSuccess diff --git a/lib/CabalBounds/Args.hs b/lib/CabalBounds/Args.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Args.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} +{-# OPTIONS_GHC -w #-} + +module CabalBounds.Args + ( Args(..) + , get + , outputFile + , defaultDrop + , defaultUpdate + ) where + +import System.Console.CmdArgs hiding (ignore) +import CabalBounds.VersionComp (VersionComp(..)) + +#ifdef CABAL +import Data.Version (showVersion) +import Paths_cabal_bounds (version) +#endif + +data Args = Drop { upper :: Bool + , library :: Bool + , executable :: [String] + , testSuite :: [String] + , benchmark :: [String] + , only :: [String] + , ignore :: [String] + , output :: String + , cabalFile :: String + } + | Update { lower :: Bool + , upper :: Bool + , lowerComp :: Maybe VersionComp + , upperComp :: Maybe VersionComp + , library :: Bool + , executable :: [String] + , testSuite :: [String] + , benchmark :: [String] + , only :: [String] + , ignore :: [String] + , output :: String + , cabalFile :: String + , setupConfigFile :: String + } + deriving (Data, Typeable, Show, Eq) + + +get :: IO Args +get = cmdArgsRun . cmdArgsMode $ modes [dropArgs, updateArgs] + &= program "cabal-bounds" + &= summary summaryInfo + &= help "A command line program for managing the bounds/versions of the dependencies in a cabal file." + &= helpArg [explicit, name "help", name "h"] + &= versionArg [explicit, name "version", name "v", summary versionInfo] + where + summaryInfo = "" + + +outputFile :: Args -> FilePath +outputFile args + | null $ output args = cabalFile args + | otherwise = output args + + +defaultDrop :: Args +defaultDrop = Drop + { upper = def + , library = def + , executable = def + , testSuite = def + , benchmark = def + , only = def + , ignore = def + , output = def + , cabalFile = def + } + + +defaultUpdate :: Args +defaultUpdate = Update + { lower = def + , upper = def + , lowerComp = def + , upperComp = def + , library = def + , executable = def + , testSuite = def + , benchmark = def + , only = def + , ignore = def + , output = def + , cabalFile = def + , setupConfigFile = def + } + + +dropArgs :: Args +dropArgs = Drop + { upper = def &= explicit &= name "upper" &= name "U" &= help "Only the upper bound is dropped, otherwise both - the lower and upper - bounds are dropped." + , library = def &= explicit &= name "library" &= name "l" &= help "Only the bounds of the library are modified." + , executable = def &= typ "NAME" &= help "Only the bounds of the executable are modified." + , testSuite = def &= typ "NAME" &= help "Only the bounds of the test suite are modified." + , benchmark = def &= typ "NAME" &= help "Only the bounds of the benchmark are modified." + , only = def &= explicit &= typ "DEPENDENCY" &= name "only" &= name "O" &= help "Only the bounds of the dependency are modified." + , ignore = def &= explicit &= typ "DEPENDENCY" &= name "ignore" &= name "I" &= help "This dependency is ignored, not modified in any way." + , output = def &= explicit &= typ "FILE" &= name "output" &= name "o" &= help "Save modified cabal file to file, if empty, the cabal file is modified inplace." + , cabalFile = def &= argPos 0 &= typ "CABAL-FILE" + } + + +updateArgs :: Args +updateArgs = Update + { lower = def &= explicit &= name "lower" &= name "L" &= help "Only the lower bound is updated. The same as using '--lowercomp=minor'." + , upper = def &= explicit &= name "upper" &= name "U" &= help "Only the upper bound is updated. The same as using '--uppercomp=major2'." + , lowerComp = def &= explicit &= name "lowercomp" &= help "Only the lower bound is updated with the specified version component. (major1, major2 or minor)" + , upperComp = def &= explicit &= name "uppercomp" &= help "Only the upper bound is updated with the specified version component. (major1, major2 or minor)" + , setupConfigFile = def &= argPos 1 &= typ "SETUP-CONFIG-FILE" + } + + +versionInfo :: String +versionInfo = +#ifdef CABAL + "cabal-bounds version " ++ showVersion version +#else + "cabal-bounds version unknown (not built with cabal)" +#endif + + diff --git a/lib/CabalBounds/Bound.hs b/lib/CabalBounds/Bound.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Bound.hs @@ -0,0 +1,61 @@ +{-# Language PatternGuards #-} + +module CabalBounds.Bound + ( DropBound(..) + , UpdateBound(..) + , boundOfDrop + , boundOfUpdate + ) where + +import CabalBounds.Args (Args(Drop, Update)) +import qualified CabalBounds.Args as A +import CabalBounds.VersionComp (VersionComp(..), defaultLowerComp, defaultUpperComp) +import Data.Maybe (isJust) + +data DropBound = DropUpper + | DropBoth + deriving (Show, Eq) + +data UpdateBound = UpdateLower VersionComp + | UpdateUpper VersionComp + | UpdateBoth { lowerComp :: VersionComp, upperComp :: VersionComp } + deriving (Show, Eq) + + +boundOfDrop :: Args -> DropBound +boundOfDrop Drop {A.upper = upper} = if upper then DropUpper else DropBoth +boundOfDrop _ = error "Expected Drop Args!" + + +boundOfUpdate :: Args -> UpdateBound +boundOfUpdate upd@Update {} + | hasLower && hasUpper + = UpdateBoth lowerComp upperComp + + | hasLower + = UpdateLower lowerComp + + | hasUpper + = UpdateUpper upperComp + + | otherwise + = UpdateBoth lowerComp upperComp + where + lowerComp + | Just comp <- A.lowerComp upd + = comp + + | otherwise + = defaultLowerComp + + upperComp + | Just comp <- A.upperComp upd + = comp + + | otherwise + = defaultUpperComp + + hasLower = A.lower upd || (isJust . A.lowerComp $ upd) + hasUpper = A.upper upd || (isJust . A.upperComp $ upd) + +boundOfUpdate _ = error "Expected Update Args!" diff --git a/lib/CabalBounds/Dependencies.hs b/lib/CabalBounds/Dependencies.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Dependencies.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE PatternGuards, Rank2Types #-} + +module CabalBounds.Dependencies + ( Dependencies(..) + , dependencies + , filterDependencies + ) where + +import Control.Lens +import qualified CabalBounds.Args as A +import Distribution.Package (Dependency(..), PackageName(..)) + +data Dependencies = AllDependencies + | OnlyDependencies [String] + | IgnoreDependencies [String] + deriving (Show, Eq) + + +dependencies :: A.Args -> Dependencies +dependencies args + | ds@(_:_) <- A.only args + = OnlyDependencies ds + + | ds@(_:_) <- A.ignore args + = IgnoreDependencies ds + + | otherwise + = AllDependencies + + +filterDependencies :: Dependencies -> Traversal' [Dependency] Dependency +filterDependencies AllDependencies = + traversed + +filterDependencies (OnlyDependencies deps) = + traversed . filtered (\(Dependency (PackageName pkgName) _) -> any (== pkgName) deps) + +filterDependencies (IgnoreDependencies deps) = + traversed . filtered (\(Dependency (PackageName pkgName) _) -> all (/= pkgName) deps) diff --git a/lib/CabalBounds/Drop.hs b/lib/CabalBounds/Drop.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Drop.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE PatternGuards #-} + +module CabalBounds.Drop + ( drop + ) where + +import Prelude hiding (drop) +import Control.Lens +import CabalBounds.Bound (DropBound(..)) +import CabalBounds.Sections (Sections(..), dependenciesOf) +import CabalBounds.Dependencies (Dependencies, filterDependencies) +import qualified CabalBounds.Lenses as L +import Data.List (foldl') +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.Package (Dependency(..)) +import Distribution.Version (mkVersionIntervals, fromVersionIntervals, asVersionIntervals, UpperBound(..), anyVersion) + + +drop :: DropBound -> Sections -> Dependencies -> GenericPackageDescription -> GenericPackageDescription +drop bound AllSections deps pkgDescrp = + pkgDescrp & L.allDependencies . filterDeps %~ dropFromDep + where + filterDeps = filterDependencies deps + dropFromDep = dropFromDependency bound + + +drop bound (Sections sections) deps pkgDescrp = + foldl' dropFromSection pkgDescrp sections + where + dropFromSection pkgDescrp section = + pkgDescrp & (dependenciesOf section) . filterDeps %~ dropFromDep + + filterDeps = filterDependencies deps + dropFromDep = dropFromDependency bound + + +dropFromDependency :: DropBound -> Dependency -> Dependency +dropFromDependency DropUpper (Dependency pkgName versionRange) = Dependency pkgName versionRange' + where + versionRange' + | Just vi <- mkVersionIntervals intervals' + = fromVersionIntervals vi + + | otherwise + = versionRange + + intervals' = map (& _2 .~ NoUpperBound) (asVersionIntervals versionRange) + +dropFromDependency DropBoth (Dependency pkgName _) = Dependency pkgName anyVersion diff --git a/lib/CabalBounds/Lenses.hs b/lib/CabalBounds/Lenses.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Lenses.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell, Rank2Types #-} + +module CabalBounds.Lenses + ( vbranch + , vtags + , allDependencies + , dependenciesOfLib + , dependenciesOfAllExes + , dependenciesOfExe + , dependenciesOfAllTests + , dependenciesOfTest + , dependenciesOfAllBenchms + , dependenciesOfBenchm + ) where + +import Distribution.PackageDescription +import Distribution.Package +import Distribution.Version +import Control.Lens +import Data.Data.Lens + +makeLensesFor [ ("condLibrary" , "condLibraryL") + , ("condExecutables", "condExecutablesL") + , ("condTestSuites" , "condTestSuitesL") + , ("condBenchmarks" , "condBenchmarksL") + ] ''GenericPackageDescription + +makeLensesFor [ ("versionBranch", "vbranch") + , ("versionTags" , "vtags") + ] ''Version + + +allDependencies :: Traversal' GenericPackageDescription [Dependency] +allDependencies = biplate + +dependenciesOfLib :: Traversal' GenericPackageDescription [Dependency] +dependenciesOfLib = condLibraryL . _Just . biplate + +dependenciesOfAllExes :: Traversal' GenericPackageDescription [Dependency] +dependenciesOfAllExes = condExecutablesL . traversed . _2 . biplate + +dependenciesOfExe :: String -> Traversal' GenericPackageDescription [Dependency] +dependenciesOfExe exe = condExecutablesL . traversed . filtered ((== exe) . fst) . _2 . biplate + +dependenciesOfAllTests :: Traversal' GenericPackageDescription [Dependency] +dependenciesOfAllTests = condTestSuitesL . traversed . _2 . biplate + +dependenciesOfTest :: String -> Traversal' GenericPackageDescription [Dependency] +dependenciesOfTest test = condTestSuitesL . traversed . filtered ((== test) . fst) . _2 . biplate + +dependenciesOfAllBenchms :: Traversal' GenericPackageDescription [Dependency] +dependenciesOfAllBenchms = condBenchmarksL . traversed . _2 . biplate + +dependenciesOfBenchm :: String -> Traversal' GenericPackageDescription [Dependency] +dependenciesOfBenchm benchm = condBenchmarksL . traversed . filtered ((== benchm) . fst) . _2 . biplate diff --git a/lib/CabalBounds/Main.hs b/lib/CabalBounds/Main.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Main.hs @@ -0,0 +1,58 @@ +{-# Language StandaloneDeriving #-} + +module CabalBounds.Main + ( cabalBounds + ) where + +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult(..)) +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.Simple.Configure (ConfigStateFileErrorType(..), tryGetConfigStateFile) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) +import qualified CabalBounds.Args as A +import qualified CabalBounds.Bound as B +import qualified CabalBounds.Sections as S +import qualified CabalBounds.Dependencies as DP +import qualified CabalBounds.Drop as D +import qualified CabalBounds.Update as U +import qualified System.IO.Strict as SIO +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Either (EitherT, runEitherT, bimapEitherT, hoistEither, left, right) +import Control.Monad.IO.Class + +type Error = String + +cabalBounds :: A.Args -> IO (Maybe Error) +cabalBounds args@A.Drop {} = do + leftToJust <$> (runEitherT $ do + pkgDescrp <- packageDescription $ A.cabalFile args + let pkgDescrp' = D.drop (B.boundOfDrop args) (S.sections args) (DP.dependencies args) pkgDescrp + liftIO $ writeFile (A.outputFile args) (showGenericPackageDescription pkgDescrp')) + +cabalBounds args@A.Update {} = do + leftToJust <$> (runEitherT $ do + pkgDescrp <- packageDescription $ A.cabalFile args + buildInfo <- localBuildInfo $ A.setupConfigFile args + let pkgDescrp' = U.update (B.boundOfUpdate args) (S.sections args) (DP.dependencies args) pkgDescrp buildInfo + liftIO $ writeFile (A.outputFile args) (showGenericPackageDescription pkgDescrp')) + + +packageDescription :: FilePath -> EitherT Error IO GenericPackageDescription +packageDescription file = do + contents <- liftIO $ SIO.readFile file + case parsePackageDescription contents of + ParseFailed error -> left $ show error + ParseOk _ pkgDescrp -> right pkgDescrp + + +localBuildInfo :: FilePath -> EitherT Error IO LocalBuildInfo +localBuildInfo file = do + binfo <- liftIO $ tryGetConfigStateFile file + bimapEitherT show id (hoistEither binfo) + + +leftToJust :: Either a b -> Maybe a +leftToJust = either Just (const Nothing) + + +deriving instance Show ConfigStateFileErrorType diff --git a/lib/CabalBounds/Sections.hs b/lib/CabalBounds/Sections.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Sections.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE PatternGuards, Rank2Types #-} + +module CabalBounds.Sections + ( Sections(..) + , Section(..) + , sections + , dependenciesOf + ) where + +import Control.Lens +import Distribution.PackageDescription (GenericPackageDescription(..)) +import Distribution.Package (Dependency(..)) +import CabalBounds.Args (Args) +import qualified CabalBounds.Args as A +import qualified CabalBounds.Lenses as L + +data Sections = Sections [Section] + | AllSections + deriving (Show, Eq) + +-- | A section of the cabal file. +data Section = Library + | Executable String + | TestSuite String + | Benchmark String + deriving (Show, Eq) + +sections :: Args -> Sections +sections args + | ts@(_:_) <- concat [ if (A.library args) then [Library] else [] + , map Executable (A.executable args) + , map TestSuite (A.testSuite args) + , map Benchmark (A.benchmark args) + ] + = Sections ts + + | otherwise + = AllSections + + +dependenciesOf :: Section -> Traversal' GenericPackageDescription [Dependency] +dependenciesOf Library = L.dependenciesOfLib +dependenciesOf (Executable exe) = L.dependenciesOfExe exe +dependenciesOf (TestSuite test) = L.dependenciesOfTest test +dependenciesOf (Benchmark benchm) = L.dependenciesOfBenchm benchm diff --git a/lib/CabalBounds/Update.hs b/lib/CabalBounds/Update.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/Update.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE PatternGuards #-} + +module CabalBounds.Update + ( update + ) where + +import qualified Distribution.PackageDescription as D +import qualified Distribution.Package as P +import qualified Distribution.Version as V +import qualified Distribution.Simple.LocalBuildInfo as BI +import qualified Distribution.Simple.PackageIndex as PX +import qualified Distribution.InstalledPackageInfo as PI +import Control.Lens +import Control.Applicative ((<$>)) +import CabalBounds.Bound (UpdateBound(..)) +import CabalBounds.Sections (Sections(..), dependenciesOf) +import CabalBounds.Dependencies (Dependencies, filterDependencies) +import CabalBounds.VersionComp (VersionComp(..), defaultLowerComp) +import qualified CabalBounds.Lenses as L +import Data.List (sort, foldl') +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe, listToMaybe) + +type PkgName = String +type InstalledPackages = HM.HashMap PkgName V.Version + + +update :: UpdateBound -> Sections -> Dependencies -> D.GenericPackageDescription -> BI.LocalBuildInfo -> D.GenericPackageDescription +update bound AllSections deps pkgDescrp buildInfo = + pkgDescrp & L.allDependencies . filterDeps %~ updateDep + where + filterDeps = filterDependencies deps + updateDep = updateDependency bound (installedPackages buildInfo) + +update bound (Sections sections) deps pkgDescrp buildInfo = + foldl' updateSection pkgDescrp sections + where + updateSection pkgDescrp section = + pkgDescrp & (dependenciesOf section) . filterDeps %~ updateDep + + filterDeps = filterDependencies deps + updateDep = updateDependency bound (installedPackages buildInfo) + + +updateDependency :: UpdateBound -> InstalledPackages -> P.Dependency -> P.Dependency +updateDependency (UpdateLower comp) instPkgs dep = + fromMaybe dep $ do + let pkgName_ = pkgName dep + version <- HM.lookup pkgName_ instPkgs + vrange <- mkVersionRange (comp `compOf` version) Nothing + return $ mkDependency pkgName_ vrange + +updateDependency (UpdateUpper comp) instPkgs dep + | V.isAnyVersion versionRange_ + = updateDependency (UpdateBoth defaultLowerComp comp) instPkgs dep + + | otherwise + = fromMaybe dep $ do + upperVersion <- HM.lookup pkgName_ instPkgs + V.LowerBound lowerVersion _ <- fst <$> (listToMaybe $ V.asVersionIntervals versionRange_) + vrange <- mkVersionRange lowerVersion (Just $ nextVersion $ comp `compOf` upperVersion) + return $ mkDependency pkgName_ vrange + where + versionRange_ = versionRange dep + pkgName_ = pkgName dep + +updateDependency (UpdateBoth lowerComp upperComp) instPkgs dep = + fromMaybe dep $ do + let pkgName_ = pkgName dep + version <- HM.lookup pkgName_ instPkgs + vrange <- mkVersionRange (lowerComp `compOf` version) (Just $ nextVersion $ upperComp `compOf` version) + return $ mkDependency pkgName_ vrange + + +mkVersionRange :: V.Version -> Maybe V.Version -> Maybe V.VersionRange +mkVersionRange lowerVersion Nothing = + V.fromVersionIntervals <$> V.mkVersionIntervals [(V.LowerBound lowerVersion V.InclusiveBound, V.NoUpperBound)] + +mkVersionRange lowerVersion (Just upperVersion) = + V.fromVersionIntervals <$> V.mkVersionIntervals [(V.LowerBound lowerVersion V.InclusiveBound, + V.UpperBound upperVersion V.ExclusiveBound)] + + +compOf :: VersionComp -> V.Version -> V.Version +Major1 `compOf` version = + version & L.vbranch %~ take 1 + & L.vtags .~ [] + +Major2 `compOf` version = + version & L.vbranch %~ take 2 + & L.vtags .~ [] + +Minor `compOf` version = + version & L.vtags .~ [] + + +nextVersion :: V.Version -> V.Version +nextVersion version = + version & L.vbranch %~ increaseLastComp + where + increaseLastComp = reverse . (& ix 0 %~ (+ 1)) . reverse + + +installedPackages :: BI.LocalBuildInfo -> InstalledPackages +installedPackages = HM.fromList + . map (\(P.PackageName n, v) -> (n, newestVersion v)) + . filter ((not . null) . snd) + . PX.allPackagesByName . BI.installedPkgs + where + newestVersion :: [PI.InstalledPackageInfo] -> V.Version + newestVersion = last . sort . map (P.pkgVersion . PI.sourcePackageId) + + +pkgName :: P.Dependency -> PkgName +pkgName (P.Dependency (P.PackageName name) _) = name + + +versionRange :: P.Dependency -> V.VersionRange +versionRange (P.Dependency _ vrange) = vrange + + +mkDependency :: PkgName -> V.VersionRange -> P.Dependency +mkDependency name vrange = P.Dependency (P.PackageName name) vrange diff --git a/lib/CabalBounds/VersionComp.hs b/lib/CabalBounds/VersionComp.hs new file mode 100644 --- /dev/null +++ b/lib/CabalBounds/VersionComp.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module CabalBounds.VersionComp + ( VersionComp(..) + , defaultLowerComp + , defaultUpperComp + ) where + +import Data.Data (Data(..), Typeable(..)) + +-- | The component of a version number A.B.C -> Major1.Major2.Minor +data VersionComp = Major1 + | Major2 + | Minor + deriving (Data, Typeable, Eq, Show) + + +defaultLowerComp :: VersionComp +defaultLowerComp = Minor + + +defaultUpperComp :: VersionComp +defaultUpperComp = Major2 diff --git a/src/CabalBounds/Args.hs b/src/CabalBounds/Args.hs deleted file mode 100644 --- a/src/CabalBounds/Args.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} -{-# OPTIONS_GHC -w #-} - -module CabalBounds.Args - ( Args(..) - , get - , outputFile - , defaultDrop - , defaultUpdate - ) where - -import System.Console.CmdArgs hiding (ignore) -import CabalBounds.VersionComp (VersionComp(..)) - -#ifdef CABAL -import Data.Version (showVersion) -import Paths_cabal_bounds (version) -#endif - -data Args = Drop { upper :: Bool - , library :: Bool - , executable :: [String] - , testSuite :: [String] - , benchmark :: [String] - , only :: [String] - , ignore :: [String] - , outputCabalFile :: String - , cabalFile :: String - } - | Update { lower :: Bool - , upper :: Bool - , lowerComp :: Maybe VersionComp - , upperComp :: Maybe VersionComp - , library :: Bool - , executable :: [String] - , testSuite :: [String] - , benchmark :: [String] - , only :: [String] - , ignore :: [String] - , outputCabalFile :: String - , cabalFile :: String - , setupConfigFile :: String - } - deriving (Data, Typeable, Show, Eq) - - -get :: IO Args -get = cmdArgsRun . cmdArgsMode $ modes [dropArgs, updateArgs] - &= program "cabal-bounds" - &= summary summaryInfo - &= help "A command line program for managing the bounds/versions of the dependencies in a cabal file." - &= helpArg [explicit, name "help", name "h"] - &= versionArg [explicit, name "version", name "v", summary versionInfo] - where - summaryInfo = "" - - -outputFile :: Args -> FilePath -outputFile args - | null $ outputCabalFile args = cabalFile args - | otherwise = outputCabalFile args - - -defaultDrop :: Args -defaultDrop = Drop - { upper = False - , library = False - , executable = [] - , testSuite = [] - , benchmark = [] - , only = [] - , ignore = [] - , outputCabalFile = "" - , cabalFile = "" - } - - -defaultUpdate :: Args -defaultUpdate = Update - { lower = False - , upper = False - , lowerComp = Nothing - , upperComp = Nothing - , library = False - , executable = [] - , testSuite = [] - , benchmark = [] - , only = [] - , ignore = [] - , outputCabalFile = "" - , cabalFile = "" - , setupConfigFile = "" - } - - -dropArgs :: Args -dropArgs = Drop - { upper = def &= explicit &= name "upper" &= name "U" &= help "Only the upper bound is dropped, otherwise both - the lower and upper - bounds are dropped." - , library = def &= explicit &= name "library" &= name "l" &= help "Only the bounds of the library are modified." - , executable = def &= typ "EXECUTABLE" &= help "Only the bounds of the executable are modified." - , testSuite = def &= typ "TESTSUITE" &= help "Only the bounds of the test suite are modified." - , benchmark = def &= typ "BENCHMARK" &= help "Only the bounds of the benchmark are modified." - , only = def &= explicit &= typ "DEPENDENCY" &= name "only" &= name "O" &= help "Only the bounds of the dependency are modified." - , ignore = def &= explicit &= typ "DEPENDENCY" &= name "ignore" &= name "I" &= help "This dependency is ignored, not modified in any way." - , outputCabalFile = def &= explicit &= typ "FILE" &= name "outputCabalFile" &= name "o" &= help "Save modified cabal file to file, if empty, the cabal file is modified inplace." - , cabalFile = def &= argPos 0 &= typ "CABAL-FILE" - } - - -updateArgs :: Args -updateArgs = Update - { lower = def &= explicit &= name "lower" &= name "L" &= help "Only the lower bound is updated. The same as using '--lowercomp=minor'." - , upper = def &= explicit &= name "upper" &= name "U" &= help "Only the upper bound is updated. The same as using '--uppercomp=major2'." - , lowerComp = def &= explicit &= name "lowercomp" &= help "Only the lower bound is updated with the specified version component. (major1, major2 or minor)" - , upperComp = def &= explicit &= name "uppercomp" &= help "Only the upper bound is updated with the specified version component. (major1, major2 or minor)" - , setupConfigFile = def &= argPos 1 &= typ "SETUP-CONFIG-FILE" - } - - -versionInfo :: String -versionInfo = -#ifdef CABAL - "cabal-bounds version " ++ showVersion version -#else - "cabal-bounds version unknown (not built with cabal)" -#endif - - diff --git a/src/CabalBounds/Bound.hs b/src/CabalBounds/Bound.hs deleted file mode 100644 --- a/src/CabalBounds/Bound.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# Language PatternGuards #-} - -module CabalBounds.Bound - ( DropBound(..) - , UpdateBound(..) - , boundOfDrop - , boundOfUpdate - ) where - -import CabalBounds.Args (Args(Drop, Update)) -import qualified CabalBounds.Args as A -import CabalBounds.VersionComp (VersionComp(..), defaultLowerComp, defaultUpperComp) -import Data.Maybe (isJust) - -data DropBound = DropUpper - | DropBoth - deriving (Show, Eq) - -data UpdateBound = UpdateLower VersionComp - | UpdateUpper VersionComp - | UpdateBoth { lowerComp :: VersionComp, upperComp :: VersionComp } - deriving (Show, Eq) - - -boundOfDrop :: Args -> DropBound -boundOfDrop Drop {A.upper = upper} = if upper then DropUpper else DropBoth -boundOfDrop _ = error "Expected Drop Args!" - - -boundOfUpdate :: Args -> UpdateBound -boundOfUpdate upd@Update {} - | hasLower && hasUpper - = UpdateBoth lowerComp upperComp - - | hasLower - = UpdateLower lowerComp - - | hasUpper - = UpdateUpper upperComp - - | otherwise - = UpdateBoth lowerComp upperComp - where - lowerComp - | Just comp <- A.lowerComp upd - = comp - - | otherwise - = defaultLowerComp - - upperComp - | Just comp <- A.upperComp upd - = comp - - | otherwise - = defaultUpperComp - - hasLower = A.lower upd || (isJust . A.lowerComp $ upd) - hasUpper = A.upper upd || (isJust . A.upperComp $ upd) - -boundOfUpdate _ = error "Expected Update Args!" diff --git a/src/CabalBounds/Dependencies.hs b/src/CabalBounds/Dependencies.hs deleted file mode 100644 --- a/src/CabalBounds/Dependencies.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE PatternGuards, Rank2Types #-} - -module CabalBounds.Dependencies - ( Dependencies(..) - , dependencies - , filterDependencies - ) where - -import Control.Lens -import qualified CabalBounds.Args as A -import Distribution.Package (Dependency(..), PackageName(..)) - -data Dependencies = AllDependencies - | OnlyDependencies [String] - | IgnoreDependencies [String] - deriving (Show, Eq) - - -dependencies :: A.Args -> Dependencies -dependencies args - | ds@(_:_) <- A.only args - = OnlyDependencies ds - - | ds@(_:_) <- A.ignore args - = IgnoreDependencies ds - - | otherwise - = AllDependencies - - -filterDependencies :: Dependencies -> Traversal' [Dependency] Dependency -filterDependencies AllDependencies = - traversed - -filterDependencies (OnlyDependencies deps) = - traversed . filtered (\(Dependency (PackageName pkgName) _) -> any (== pkgName) deps) - -filterDependencies (IgnoreDependencies deps) = - traversed . filtered (\(Dependency (PackageName pkgName) _) -> all (/= pkgName) deps) diff --git a/src/CabalBounds/Drop.hs b/src/CabalBounds/Drop.hs deleted file mode 100644 --- a/src/CabalBounds/Drop.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -module CabalBounds.Drop - ( drop - ) where - -import Prelude hiding (drop) -import Control.Lens -import CabalBounds.Bound (DropBound(..)) -import CabalBounds.Targets (Targets(..), dependenciesOf) -import CabalBounds.Dependencies (Dependencies, filterDependencies) -import qualified CabalBounds.Lenses as L -import Data.List (foldl') -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.Package (Dependency(..)) -import Distribution.Version (mkVersionIntervals, fromVersionIntervals, asVersionIntervals, UpperBound(..), anyVersion) - - -drop :: DropBound -> Targets -> Dependencies -> GenericPackageDescription -> GenericPackageDescription -drop bound AllTargets deps pkgDescrp = - pkgDescrp & L.allDependencies . filterDeps %~ dropFromDep - where - filterDeps = filterDependencies deps - dropFromDep = dropFromDependency bound - - -drop bound (Targets targets) deps pkgDescrp = - foldl' dropFromTarget pkgDescrp targets - where - dropFromTarget pkgDescrp target = - pkgDescrp & (dependenciesOf target) . filterDeps %~ dropFromDep - - filterDeps = filterDependencies deps - dropFromDep = dropFromDependency bound - - -dropFromDependency :: DropBound -> Dependency -> Dependency -dropFromDependency DropUpper (Dependency pkgName versionRange) = Dependency pkgName versionRange' - where - versionRange' - | Just vi <- mkVersionIntervals intervals' - = fromVersionIntervals vi - - | otherwise - = versionRange - - intervals' = map (& _2 .~ NoUpperBound) (asVersionIntervals versionRange) - -dropFromDependency DropBoth (Dependency pkgName _) = Dependency pkgName anyVersion diff --git a/src/CabalBounds/Lenses.hs b/src/CabalBounds/Lenses.hs deleted file mode 100644 --- a/src/CabalBounds/Lenses.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE TemplateHaskell, Rank2Types #-} - -module CabalBounds.Lenses - ( vbranch - , vtags - , allDependencies - , dependenciesOfLib - , dependenciesOfAllExes - , dependenciesOfExe - , dependenciesOfAllTests - , dependenciesOfTest - , dependenciesOfAllBenchms - , dependenciesOfBenchm - ) where - -import Distribution.PackageDescription -import Distribution.Package -import Distribution.Version -import Control.Lens -import Data.Data.Lens - -makeLensesFor [ ("condLibrary" , "condLibraryL") - , ("condExecutables", "condExecutablesL") - , ("condTestSuites" , "condTestSuitesL") - , ("condBenchmarks" , "condBenchmarksL") - ] ''GenericPackageDescription - -makeLensesFor [ ("versionBranch", "vbranch") - , ("versionTags" , "vtags") - ] ''Version - - -allDependencies :: Traversal' GenericPackageDescription [Dependency] -allDependencies = biplate - -dependenciesOfLib :: Traversal' GenericPackageDescription [Dependency] -dependenciesOfLib = condLibraryL . _Just . biplate - -dependenciesOfAllExes :: Traversal' GenericPackageDescription [Dependency] -dependenciesOfAllExes = condExecutablesL . traversed . _2 . biplate - -dependenciesOfExe :: String -> Traversal' GenericPackageDescription [Dependency] -dependenciesOfExe exe = condExecutablesL . traversed . filtered ((== exe) . fst) . _2 . biplate - -dependenciesOfAllTests :: Traversal' GenericPackageDescription [Dependency] -dependenciesOfAllTests = condTestSuitesL . traversed . _2 . biplate - -dependenciesOfTest :: String -> Traversal' GenericPackageDescription [Dependency] -dependenciesOfTest test = condTestSuitesL . traversed . filtered ((== test) . fst) . _2 . biplate - -dependenciesOfAllBenchms :: Traversal' GenericPackageDescription [Dependency] -dependenciesOfAllBenchms = condBenchmarksL . traversed . _2 . biplate - -dependenciesOfBenchm :: String -> Traversal' GenericPackageDescription [Dependency] -dependenciesOfBenchm benchm = condBenchmarksL . traversed . filtered ((== benchm) . fst) . _2 . biplate diff --git a/src/CabalBounds/Main.hs b/src/CabalBounds/Main.hs deleted file mode 100644 --- a/src/CabalBounds/Main.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# Language StandaloneDeriving #-} - -module CabalBounds.Main - ( cabalBounds - ) where - -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult(..)) -import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Simple.Configure (ConfigStateFileErrorType(..), tryGetConfigStateFile) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) -import qualified CabalBounds.Args as A -import qualified CabalBounds.Bound as B -import qualified CabalBounds.Targets as T -import qualified CabalBounds.Dependencies as DP -import qualified CabalBounds.Drop as D -import qualified CabalBounds.Update as U -import qualified System.IO.Strict as SIO -import Control.Applicative ((<$>)) - -type Error = String - -cabalBounds :: A.Args -> IO (Maybe Error) -cabalBounds args@A.Drop {} = do - pkgDescrp <- packageDescription $ A.cabalFile args - case pkgDescrp of - Left error -> return . Just $ error - Right pkgDescrp_ -> do - let pkgDescrp' = D.drop (B.boundOfDrop args) (T.targets args) (DP.dependencies args) pkgDescrp_ - writeFile (A.outputFile args) (showGenericPackageDescription pkgDescrp') - return Nothing - -cabalBounds args@A.Update {} = do - pkgDescrp <- packageDescription $ A.cabalFile args - buildInfo <- localBuildInfo $ A.setupConfigFile args - case (pkgDescrp, buildInfo) of - (Left error, _) -> return . Just $ error - (_, Left error) -> return . Just $ error - (Right pkgDescrp_, Right buildInfo_) -> do - let pkgDescrp' = U.update (B.boundOfUpdate args) (T.targets args) (DP.dependencies args) pkgDescrp_ buildInfo_ - writeFile (A.outputFile args) (showGenericPackageDescription pkgDescrp') - return Nothing - - -packageDescription :: FilePath -> IO (Either Error GenericPackageDescription) -packageDescription file = do - contents <- SIO.readFile file - case parsePackageDescription contents of - ParseFailed error -> return . Left $ show error - ParseOk _ pkgDescrp -> return . Right $ pkgDescrp - - -localBuildInfo :: FilePath -> IO (Either Error LocalBuildInfo) -localBuildInfo file = - either (Left . show) Right <$> tryGetConfigStateFile file - -deriving instance Show ConfigStateFileErrorType diff --git a/src/CabalBounds/Targets.hs b/src/CabalBounds/Targets.hs deleted file mode 100644 --- a/src/CabalBounds/Targets.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE PatternGuards, Rank2Types #-} - -module CabalBounds.Targets - ( Targets(..) - , Target(..) - , targets - , dependenciesOf - ) where - -import Control.Lens -import Distribution.PackageDescription (GenericPackageDescription(..)) -import Distribution.Package (Dependency(..)) -import CabalBounds.Args (Args) -import qualified CabalBounds.Args as A -import qualified CabalBounds.Lenses as L - -data Targets = Targets [Target] - | AllTargets - deriving (Show, Eq) - -data Target = Library - | Executable String - | TestSuite String - | Benchmark String - deriving (Show, Eq) - -targets :: Args -> Targets -targets args - | ts@(_:_) <- concat [ if (A.library args) then [Library] else [] - , map Executable (A.executable args) - , map TestSuite (A.testSuite args) - , map Benchmark (A.benchmark args) - ] - = Targets ts - - | otherwise - = AllTargets - - -dependenciesOf :: Target -> Traversal' GenericPackageDescription [Dependency] -dependenciesOf Library = L.dependenciesOfLib -dependenciesOf (Executable exe) = L.dependenciesOfExe exe -dependenciesOf (TestSuite test) = L.dependenciesOfTest test -dependenciesOf (Benchmark benchm) = L.dependenciesOfBenchm benchm diff --git a/src/CabalBounds/Update.hs b/src/CabalBounds/Update.hs deleted file mode 100644 --- a/src/CabalBounds/Update.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -module CabalBounds.Update - ( update - ) where - -import qualified Distribution.PackageDescription as D -import qualified Distribution.Package as P -import qualified Distribution.Version as V -import qualified Distribution.Simple.LocalBuildInfo as BI -import qualified Distribution.Simple.PackageIndex as PX -import qualified Distribution.InstalledPackageInfo as PI -import Control.Lens -import Control.Applicative ((<$>)) -import CabalBounds.Bound (UpdateBound(..)) -import CabalBounds.Targets (Targets(..), dependenciesOf) -import CabalBounds.Dependencies (Dependencies, filterDependencies) -import CabalBounds.VersionComp (VersionComp(..), defaultLowerComp) -import qualified CabalBounds.Lenses as L -import Data.List (sort, foldl') -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe, listToMaybe) - -type PkgName = String -type InstalledPackages = HM.HashMap PkgName V.Version - - -update :: UpdateBound -> Targets -> Dependencies -> D.GenericPackageDescription -> BI.LocalBuildInfo -> D.GenericPackageDescription -update bound AllTargets deps pkgDescrp buildInfo = - pkgDescrp & L.allDependencies . filterDeps %~ updateDep - where - filterDeps = filterDependencies deps - updateDep = updateDependency bound (installedPackages buildInfo) - -update bound (Targets targets) deps pkgDescrp buildInfo = - foldl' updateTarget pkgDescrp targets - where - updateTarget pkgDescrp target = - pkgDescrp & (dependenciesOf target) . filterDeps %~ updateDep - - filterDeps = filterDependencies deps - updateDep = updateDependency bound (installedPackages buildInfo) - - -updateDependency :: UpdateBound -> InstalledPackages -> P.Dependency -> P.Dependency -updateDependency (UpdateLower comp) instPkgs dep = - fromMaybe dep $ do - let pkgName_ = pkgName dep - version <- HM.lookup pkgName_ instPkgs - vrange <- mkVersionRange (comp `compOf` version) Nothing - return $ mkDependency pkgName_ vrange - -updateDependency (UpdateUpper comp) instPkgs dep - | V.isAnyVersion versionRange_ - = updateDependency (UpdateBoth defaultLowerComp comp) instPkgs dep - - | otherwise - = fromMaybe dep $ do - upperVersion <- HM.lookup pkgName_ instPkgs - V.LowerBound lowerVersion _ <- fst <$> (listToMaybe $ V.asVersionIntervals versionRange_) - vrange <- mkVersionRange lowerVersion (Just $ nextVersion $ comp `compOf` upperVersion) - return $ mkDependency pkgName_ vrange - where - versionRange_ = versionRange dep - pkgName_ = pkgName dep - -updateDependency (UpdateBoth lowerComp upperComp) instPkgs dep = - fromMaybe dep $ do - let pkgName_ = pkgName dep - version <- HM.lookup pkgName_ instPkgs - vrange <- mkVersionRange (lowerComp `compOf` version) (Just $ nextVersion $ upperComp `compOf` version) - return $ mkDependency pkgName_ vrange - - -mkVersionRange :: V.Version -> Maybe V.Version -> Maybe V.VersionRange -mkVersionRange lowerVersion Nothing = - V.fromVersionIntervals <$> V.mkVersionIntervals [(V.LowerBound lowerVersion V.InclusiveBound, V.NoUpperBound)] - -mkVersionRange lowerVersion (Just upperVersion) = - V.fromVersionIntervals <$> V.mkVersionIntervals [(V.LowerBound lowerVersion V.InclusiveBound, - V.UpperBound upperVersion V.ExclusiveBound)] - - -compOf :: VersionComp -> V.Version -> V.Version -Major1 `compOf` version = - version & L.vbranch %~ take 1 - & L.vtags .~ [] - -Major2 `compOf` version = - version & L.vbranch %~ take 2 - & L.vtags .~ [] - -Minor `compOf` version = - version & L.vtags .~ [] - - -nextVersion :: V.Version -> V.Version -nextVersion version = - version & L.vbranch %~ increaseLastComp - where - increaseLastComp = reverse . (& ix 0 %~ (+ 1)) . reverse - - -installedPackages :: BI.LocalBuildInfo -> InstalledPackages -installedPackages = HM.fromList - . map (\(P.PackageName n, v) -> (n, newestVersion v)) - . filter ((not . null) . snd) - . PX.allPackagesByName . BI.installedPkgs - where - newestVersion :: [PI.InstalledPackageInfo] -> V.Version - newestVersion = last . sort . map (P.pkgVersion . PI.sourcePackageId) - - -pkgName :: P.Dependency -> PkgName -pkgName (P.Dependency (P.PackageName name) _) = name - - -versionRange :: P.Dependency -> V.VersionRange -versionRange (P.Dependency _ vrange) = vrange - - -mkDependency :: PkgName -> V.VersionRange -> P.Dependency -mkDependency name vrange = P.Dependency (P.PackageName name) vrange diff --git a/src/CabalBounds/VersionComp.hs b/src/CabalBounds/VersionComp.hs deleted file mode 100644 --- a/src/CabalBounds/VersionComp.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module CabalBounds.VersionComp - ( VersionComp(..) - , defaultLowerComp - , defaultUpperComp - ) where - -import Data.Data (Data(..), Typeable(..)) - --- | The component of a version number A.B.C -> Major1.Major2.Minor -data VersionComp = Major1 - | Major2 - | Minor - deriving (Data, Typeable, Eq, Show) - - -defaultLowerComp :: VersionComp -defaultLowerComp = Minor - - -defaultUpperComp :: VersionComp -defaultUpperComp = Major2 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,15 +0,0 @@ - -module Main where - -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStrLn, stderr) -import qualified CabalBounds.Args as Args -import CabalBounds.Main (cabalBounds) - -main :: IO () -main = do - args <- Args.get - error <- cabalBounds args - case error of - Just err -> hPutStrLn stderr ("cabal-bounds: " ++ err) >> exitFailure - _ -> exitSuccess diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -83,11 +83,11 @@ argsWithFiles = case args of - Drop {} -> args { cabalFile = inputFile - , outputCabalFile = outputFile + Drop {} -> args { cabalFile = inputFile + , output = outputFile } Update {} -> args { cabalFile = inputFile - , outputCabalFile = outputFile + , output = outputFile , setupConfigFile = setupConfigFile }