diff --git a/cabal-sort.cabal b/cabal-sort.cabal --- a/cabal-sort.cabal +++ b/cabal-sort.cabal @@ -1,5 +1,5 @@ Name: cabal-sort -Version: 0.0.1 +Version: 0.0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -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 diff --git a/src/CabalSort.hs b/src/CabalSort.hs new file mode 100644 --- /dev/null +++ b/src/CabalSort.hs @@ -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) diff --git a/src/GhcPkgDep.hs b/src/GhcPkgDep.hs new file mode 100644 --- /dev/null +++ b/src/GhcPkgDep.hs @@ -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 "" diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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)