cabal-sort 0.0.1 → 0.0.2
raw patch · 4 files changed
+368/−173 lines, 4 filesdep +bytestringdep +processnew-component:exe:ghc-pkg-dep
Dependencies added: bytestring, process
Files
- cabal-sort.cabal +32/−4
- src/CabalSort.hs +169/−0
- src/GhcPkgDep.hs +167/−0
- src/Main.hs +0/−169
cabal-sort.cabal view
@@ -1,5 +1,5 @@ Name: cabal-sort-Version: 0.0.1+Version: 0.0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -26,7 +26,7 @@ . > for dir in `find . -name "*.cabal" | fgrep -v _darcs | xargs cabal-sort --info=dir`; do (cd $dir && rm dist/*.tar.gz && cabal sdist && cabal upload dist/*.tar.gz); done .- Problem: Given packages A, B, C,+ Problem 1: Given packages A, B, C, where C depends on B and B depends on A, and you call .@@ -38,6 +38,20 @@ B.cabal is missing in the output and thus the list of cabal files cannot immediately be used for a sequence of cabal-install runs.+ .+ Problem 2: We ignore flags and merge all dependencies.+ This may lead to dependency cycles that cannot occur for any flag assignment.+ .+ There is a second program called @ghc-pkg-dep@+ that finds recursively all packages that a set of packages depends on.+ Duplicates are eliminated and the packages are given topologically sorted,+ such that you can use this for recompilation of the packages.+ .+ > ghc-pkg-dep pkgA-0.1 pkgB-2.3 pkgC-0.1.2+ .+ Unfortunately ghc-pkg runs quite slowly.+ In order to not get bored you may run the program with @--verbose=2@ option.+ Maybe there is a way to query the complete GHC package database at once. Tested-With: GHC==6.10.4 Cabal-Version: >=1.6 Build-Type: Simple@@ -48,7 +62,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/cabal-sort/- tag: 0.0.1+ tag: 0.0.1.1 Executable cabal-sort@@ -64,4 +78,18 @@ GHC-Options: -Wall Hs-source-dirs: src- Main-Is: Main.hs+ Main-Is: CabalSort.hs++Executable ghc-pkg-dep+ Build-Depends:+ Cabal >=1.6 && <1.10,+ process >=1.0 && <1.1,+ containers >=0.2 && <0.4,+ explicit-exception >=0.1.4 && <0.2,+ transformers >=0.2 && <0.3,+ bytestring >=0.9.1 && <0.10,+ base >=2 && <5++ GHC-Options: -Wall+ Hs-source-dirs: src+ Main-Is: GhcPkgDep.hs
+ src/CabalSort.hs view
@@ -0,0 +1,169 @@+module Main where++import qualified Distribution.PackageDescription as P+import Distribution.PackageDescription+ (GenericPackageDescription, PackageDescription,+ package, packageDescription, buildDepends, )+import Distribution.PackageDescription.Parse (readPackageDescription, )+import Distribution.Package+ (Dependency(Dependency), PackageName(PackageName), pkgName, )++import qualified Distribution.Verbosity as Verbosity+import qualified Distribution.ReadE as ReadE++import System.Console.GetOpt+ (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )+import System.Exit (exitWith, ExitCode(..), )+import qualified System.Environment as Env+import qualified System.FilePath as FilePath++import Data.Graph.Inductive.Query.DFS (topsort', scc, )+import Data.Graph.Inductive.Tree (Gr, )+import qualified Data.Graph.Inductive.Graph as Graph++import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Trans.Class as Trans++import qualified Data.Set as Set+import Control.Monad (when, )+import Data.Maybe (mapMaybe, )+++main :: IO ()+main =+ Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do+ argv <- Trans.lift Env.getArgs+ let (opts, cabalPaths, errors) =+ getOpt RequireOrder options argv+ when (not (null errors)) $ Exc.throwT $ concat $ errors+ flags <-+ Exc.ExceptionalT $ return $+ foldr (flip (>>=))+ (return $+ Flags {optHelp = False,+ optVerbosity = Verbosity.silent,+ optInfo = location})+ opts+ when (optHelp flags)+ (Trans.lift $+ Env.getProgName >>= \programName ->+ putStrLn+ (usageInfo ("Usage: " ++ programName +++ " [OPTIONS] CABAL-FILES ...") options) >>+ exitWith ExitSuccess)++ Trans.lift $ sortCabalFiles flags cabalPaths+++data Flags =+ Flags {+ optHelp :: Bool,+ optVerbosity :: Verbosity.Verbosity,+ optInfo :: SourcePackage -> String+ }++options :: [OptDescr (Flags -> Exc.Exceptional String Flags)]+options =+ Option ['h'] ["help"]+ (NoArg (\flags -> return $ flags{optHelp = True}))+ "show options" :+ Option ['v'] ["verbose"]+ (ReqArg+ (\str flags ->+ fmap (\n -> flags{optVerbosity = n}) $+ Exc.fromEither $+ ReadE.runReadE Verbosity.flagToVerbosity str)+ "N")+ "verbosity level: 0..3" :+ Option [] ["info"]+ (ReqArg+ (\str flags ->+ fmap (\select -> flags{optInfo = select}) $+ case str of+ "name" -> Exc.Success+ (getPkgName . pkgName . package .+ packageDescription . description)+ "path" -> Exc.Success location+ "dir" -> Exc.Success (FilePath.takeDirectory . location)+ _ ->+ Exc.Exception $+ "unknown info type " ++ str)+ "KIND")+ "kind of output: name, path, dir" :+ []++++data SourcePackage =+ SourcePackage {+ location :: FilePath,+ description :: GenericPackageDescription+ }++sortCabalFiles :: Flags -> [FilePath] -> IO ()+sortCabalFiles flags cabalPaths =+ do pkgDescs <-+ mapM (readPackageDescription (optVerbosity flags)) cabalPaths+ when (optVerbosity flags >= Verbosity.verbose) $+ flip mapM_ pkgDescs $ \pkgDesc -> do+ putStrLn+ ((getPkgName . pkgName . package . packageDescription $ pkgDesc) ++ ":")+ let deps =+ Set.toAscList $ Set.fromList $+ map (getPkgName . depName) $+ allDependencies pkgDesc+ flip mapM_ deps $ \dep ->+ putStrLn $ " " ++ dep+ mapM_ (putStrLn . optInfo flags) $+ getBuildOrder $+ zipWith SourcePackage cabalPaths pkgDescs+++getBuildOrder ::+ [SourcePackage] ->+ [SourcePackage]+getBuildOrder srcPkgs =+ let nodes = zip [0..] srcPkgs+ nodeDict =+ zip+ (map (pkgName . package . packageDescription . description)+ srcPkgs)+ [0..]+ edges = do+ (srcNode,desc) <- nodes+ dstNode <-+ mapMaybe+ (flip lookup nodeDict . depName)+ (allDependencies $ description desc)+ return (dstNode, srcNode, ())+ graph :: Gr SourcePackage ()+ graph = Graph.mkGraph nodes edges++ in if hasCycle graph+ then error "cycle in dependencies"+ else topsort' graph++allDependencies :: GenericPackageDescription -> [Dependency]+allDependencies pkg =+ P.buildDepends (packageDescription pkg) +++ maybe [] (concatMap snd . flattenCondTree) (P.condLibrary pkg) +++ concatMap (concatMap snd . flattenCondTree . snd) (P.condExecutables pkg)++flattenCondTree :: P.CondTree v c a -> [(a,c)]+flattenCondTree tree =+ (P.condTreeData tree, P.condTreeConstraints tree) :+ concatMap+ (\(_, thenBranch, elseBranch) ->+ flattenCondTree thenBranch +++ maybe [] flattenCondTree elseBranch)+ (P.condTreeComponents tree)++depName :: Dependency -> PackageName+depName (Dependency name _) = name++getPkgName :: PackageName -> String+getPkgName (PackageName name) = name++hasCycle :: Gr a b -> Bool+hasCycle graph =+ length (scc graph) < length (Graph.nodes graph)
+ src/GhcPkgDep.hs view
@@ -0,0 +1,167 @@+module Main where++import qualified Distribution.Verbosity as Verbosity+import qualified Distribution.ReadE as ReadE++import qualified System.Process as Proc+import qualified System.Exit as Exit+import qualified System.IO as IO++import System.Console.GetOpt+ (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )+import System.Exit (exitWith, ExitCode(..), )+import qualified System.Environment as Env++import qualified Distribution.Verbosity as Verbosity+import qualified Distribution.ReadE as ReadE+import qualified Distribution.Package as Pkg+import qualified Distribution.Text as DistText++import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Class as Trans+-- import Control.Monad.IO.Class (liftIO, )++import qualified Data.Set as Set++import qualified Data.ByteString.Char8 as B++import Control.Monad (when, guard, )+import Data.Maybe (fromMaybe, )+++main :: IO ()+main =+ Exc.resolveT (\e -> IO.hPutStr IO.stderr $ "Aborted: " ++ e ++ "\n") $ do+ argv <- Trans.lift Env.getArgs+ let (opts, pgkNames, errors) =+ getOpt RequireOrder options argv+ when (not (null errors)) $ Exc.throwT $ concat $ errors+ flags <-+ Exc.ExceptionalT $ return $+ foldr (flip (>>=)) (return defltFlags) opts+ when (optHelp flags)+ (Trans.lift $+ Env.getProgName >>= \programName ->+ putStrLn+ (usageInfo ("Usage: " ++ programName +++ " [OPTIONS] PKG-NAMES ...") options) >>+ exitWith ExitSuccess)++ mapM_ (Trans.lift . putStrLn) =<<+ (Exc.mapExceptionalT (flip State.evalStateT Set.empty) $+ fmap concat $ mapM (getAllDependencies flags True) pgkNames)+++data Flags =+ Flags {+ optHelp :: Bool,+ optVerbosity :: Verbosity.Verbosity,+ optUser, optGlobal :: Bool,+ optShowVersions :: Bool+ }++defltFlags :: Flags+defltFlags =+ Flags {+ optHelp = False,+ optVerbosity = Verbosity.silent,+ optUser = False,+ optGlobal = False,+ optShowVersions = False+ }++options :: [OptDescr (Flags -> Exc.Exceptional String Flags)]+options =+ Option ['h'] ["help"]+ (NoArg (\flags -> return $ flags{optHelp = True}))+ "show options" :+ Option ['v'] ["verbose"]+ (ReqArg+ (\str flags ->+ fmap (\n -> flags{optVerbosity = n}) $+ Exc.fromEither $+ ReadE.runReadE Verbosity.flagToVerbosity str)+ "N")+ "verbosity level: 0..3" :+ Option [] ["user"]+ (NoArg (\flags -> return $ flags{optUser = True}))+ "query GHC's local user package database" :+ Option [] ["global"]+ (NoArg (\flags -> return $ flags{optGlobal = True}))+ "query GHC's global package database" :+ Option [] ["show-versions"]+ (NoArg (\flags -> return $ flags{optShowVersions = True}))+ "show package version numbers in the output" :+ []+++type PkgName = String+++getAllDependencies ::+ Flags -> Bool -> PkgName ->+ Exc.ExceptionalT String (State.StateT (Set.Set PkgName) IO) [PkgName]+getAllDependencies flags userSuppliedName name = do+ when (optVerbosity flags >= Verbosity.deafening)+ (Trans.lift $+ Trans.lift . print =<< State.get)+ b <- Trans.lift $ State.gets (Set.member name)+ if b+ then return []+ else+ Exc.catchT+ (do {- register this name _before_ calling ghc-pkg,+ because ghc-pkg may not find the package,+ and then we do not need to query again -}+ Trans.lift $ State.modify (Set.insert name)+ deps <-+ Exc.mapExceptionalT Trans.lift $+ getDirectDependencies flags name+ allDeps <- mapM (getAllDependencies flags False) deps+ let strippedName = fromMaybe name $ do+ guard $ not $ optShowVersions flags+ Pkg.PackageName pname <-+ fmap Pkg.pkgName $ DistText.simpleParse name+ return pname+ return $ concat allDeps ++ [strippedName])+ (\errTxt ->+ if not userSuppliedName &&+ B.isInfixOf (B.pack "cannot find") (B.pack errTxt)+ then return []+ else Exc.throwT errTxt)+++getDirectDependencies ::+ Flags -> PkgName ->+ Exc.ExceptionalT String IO [PkgName]+getDirectDependencies flags name = do+ let cmd = "ghc-pkg"+ args =+ (if optUser flags then ("--user" :) else id) $+ (if optGlobal flags then ("--global" :) else id) $+ ["field", name, "depends"]+ when (optVerbosity flags >= Verbosity.verbose)+ (Trans.lift $ putStrLn $ unwords $ cmd : args)+ (inp,out,err,pid) <-+ Trans.lift (Proc.runInteractiveProcess cmd args Nothing Nothing)+ txt <- Trans.lift $ B.hGetContents out+ errTxt <- Trans.lift $ B.hGetContents err+ when (optVerbosity flags >= Verbosity.normal) $+ Trans.lift $ putStr $ B.unpack errTxt+ exit <- Trans.lift $ Proc.waitForProcess pid+ case exit of+ Exit.ExitSuccess -> return ()+ Exit.ExitFailure n ->+ Exc.throwT $+ "ghc-pkg exited with code " ++ show n ++ "\n" ++ B.unpack errTxt+ Trans.lift (mapM_ IO.hClose [inp,out,err])+ case words (B.unpack txt) of+ "depends:":names ->+ return (filter ("depends:"/=) names)+ _ -> Exc.throwT $+ "unexpected output of ghc-pkg - " +++ "it should start with 'depends:'" +++ if optVerbosity flags >= Verbosity.verbose+ then "\n" ++ B.unpack txt+ else ""
− src/Main.hs
@@ -1,169 +0,0 @@-module Main where--import qualified Distribution.PackageDescription as P-import Distribution.PackageDescription- (GenericPackageDescription, PackageDescription,- package, packageDescription, buildDepends, )-import Distribution.PackageDescription.Parse (readPackageDescription, )-import Distribution.Package- (Dependency(Dependency), PackageName(PackageName), pkgName, )--import qualified Distribution.Verbosity as Verbosity-import qualified Distribution.ReadE as ReadE--import System.Console.GetOpt- (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )-import System.Exit (exitWith, ExitCode(..), )-import qualified System.Environment as Env-import qualified System.FilePath as FilePath--import Data.Graph.Inductive.Query.DFS (topsort', scc, )-import Data.Graph.Inductive.Tree (Gr, )-import qualified Data.Graph.Inductive.Graph as Graph--import qualified Control.Monad.Exception.Synchronous as Exc-import qualified Control.Monad.Trans.Class as Trans--import qualified Data.Set as Set-import Control.Monad (when, )-import Data.Maybe (mapMaybe, )---main :: IO ()-main =- Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do- argv <- Trans.lift Env.getArgs- let (opts, cabalPaths, errors) =- getOpt RequireOrder options argv- when (not (null errors)) $ Exc.throwT $ concat $ errors- flags <-- Exc.ExceptionalT $ return $- foldr (flip (>>=))- (return $- Flags {optHelp = False,- optVerbosity = Verbosity.silent,- optInfo = location})- opts- when (optHelp flags)- (Trans.lift $- Env.getProgName >>= \programName ->- putStrLn- (usageInfo ("Usage: " ++ programName ++- " [OPTIONS] CABAL-FILES ...") options) >>- exitWith ExitSuccess)-- Trans.lift $ sortCabalFiles flags cabalPaths---data Flags =- Flags {- optHelp :: Bool,- optVerbosity :: Verbosity.Verbosity,- optInfo :: SourcePackage -> String- }--options :: [OptDescr (Flags -> Exc.Exceptional String Flags)]-options =- Option ['h'] ["help"]- (NoArg (\flags -> return $ flags{optHelp = True}))- "show options" :- Option ['v'] ["verbose"]- (ReqArg- (\str flags ->- fmap (\n -> flags{optVerbosity = n}) $- Exc.fromEither $- ReadE.runReadE Verbosity.flagToVerbosity str)- "N")- "verbosity level: 0..3" :- Option [] ["info"]- (ReqArg- (\str flags ->- fmap (\select -> flags{optInfo = select}) $- case str of- "name" -> Exc.Success- (getPkgName . pkgName . package .- packageDescription . description)- "path" -> Exc.Success location- "dir" -> Exc.Success (FilePath.takeDirectory . location)- _ ->- Exc.Exception $- "unknown info type " ++ str)- "KIND")- "kind of output: name, path, dir" :- []----data SourcePackage =- SourcePackage {- location :: FilePath,- description :: GenericPackageDescription- }--sortCabalFiles :: Flags -> [FilePath] -> IO ()-sortCabalFiles flags cabalPaths =- do pkgDescs <-- mapM (readPackageDescription (optVerbosity flags)) cabalPaths- when (optVerbosity flags >= Verbosity.verbose) $- flip mapM_ pkgDescs $ \pkgDesc -> do- putStrLn- ((getPkgName . pkgName . package . packageDescription $ pkgDesc) ++ ":")- let deps =- Set.toAscList $ Set.fromList $- map (getPkgName . depName) $- allDependencies pkgDesc- flip mapM_ deps $ \dep ->- putStrLn $ " " ++ dep- mapM_ (putStrLn . optInfo flags) $- getBuildOrder $- zipWith SourcePackage cabalPaths pkgDescs---getBuildOrder ::- [SourcePackage] ->- [SourcePackage]-getBuildOrder srcPkgs =- let nodes = zip [0..] srcPkgs- nodeDict =- zip- (map (pkgName . package . packageDescription . description)- srcPkgs)- [0..]- edges = do- (srcNode,desc) <- nodes- dstNode <-- mapMaybe- (flip lookup nodeDict . depName)- (allDependencies $ description desc)- return (dstNode, srcNode, ())- graph :: Gr SourcePackage ()- graph = Graph.mkGraph nodes edges-- in if hasCycle graph- then error "cycle in dependencies"- else topsort' graph--allDependencies :: GenericPackageDescription -> [Dependency]-allDependencies pkg =- P.buildDepends (packageDescription pkg) ++- maybe [] (concatMap snd . flattenCondTree) (P.condLibrary pkg) ++- concatMap (concatMap snd . flattenCondTree . snd) (P.condExecutables pkg)--flattenCondTree :: P.CondTree v c a -> [(a,c)]-flattenCondTree tree =- (P.condTreeData tree, P.condTreeConstraints tree) :- concatMap- (\(_, thenBranch, elseBranch) ->- flattenCondTree thenBranch ++- maybe [] flattenCondTree elseBranch)- (P.condTreeComponents tree)--depName :: Dependency -> PackageName-depName (Dependency name _) = name--getPkgName :: PackageName -> String-getPkgName (PackageName name) = name--hasCycle :: Gr a b -> Bool-hasCycle graph =- length (scc graph) < length (Graph.nodes graph)