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.3.1 +Version: 0.0.4 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -42,17 +42,23 @@ Problem 2: We ignore flags and merge all dependencies. This may lead to dependency cycles that cannot occur for any flag assignment. . + You also have options @--parallel@ and @--makefile@ + that support parallel compilation. + The first option is for manual parallelization + and the second one allows you to compile parallelly using + @make@'s @-j@/@--jobs@ option. + . 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. + The packages must already be registered with @ghc-pkg@. . > ghc-pkg-dep pkgA-0.1 pkgB-2.3 pkgC-0.1.2 . - Unfortunately ghc-pkg runs quite slowly. + On GHC versions before 7.0 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 +Tested-With: GHC==6.10.4, GHC==6.12.3 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository head @@ -62,7 +68,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/cabal-sort/ - tag: 0.0.3.1 + tag: 0.0.4 Executable cabal-sort diff --git a/src/CabalSort.hs b/src/CabalSort.hs --- a/src/CabalSort.hs +++ b/src/CabalSort.hs @@ -13,25 +13,27 @@ import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, ) -import System.Exit (exitWith, ExitCode(..), ) +import System.Exit (exitSuccess, exitFailure, ) import qualified System.Environment as Env +import System.FilePath (()) import qualified System.FilePath as FilePath -import Data.Graph.Inductive.Query.DFS (topsort', scc, ) +import Data.Graph.Inductive.Query.DFS (topsort', scc, components, ) import Data.Graph.Inductive.Tree (Gr, ) import qualified Data.Graph.Inductive.Graph as Graph +import Control.Arrow ((***)) 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, ) +import Control.Monad (guard, when, ) +import Data.Maybe (fromMaybe, mapMaybe, ) main :: IO () main = - Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do + Exc.resolveT handleException $ do argv <- Trans.lift Env.getArgs let (opts, cabalPaths, errors) = getOpt RequireOrder options argv @@ -42,7 +44,11 @@ (return $ Flags {optHelp = False, optVerbosity = Verbosity.silent, - optInfo = location}) + optInfo = location, + optParallel = False, + optMakefile = False, + optBuilddir = ".", + optInstall = "cabal install"}) opts when (optHelp flags) (Trans.lift $ @@ -50,16 +56,25 @@ putStrLn (usageInfo ("Usage: " ++ programName ++ " [OPTIONS] CABAL-FILES ...") options) >> - exitWith ExitSuccess) + exitSuccess) - Trans.lift $ sortCabalFiles flags cabalPaths + sortCabalFiles flags cabalPaths +handleException :: String -> IO () +handleException msg = do + putStrLn $ "Aborted: " ++ msg + exitFailure + data Flags = Flags { optHelp :: Bool, optVerbosity :: Verbosity.Verbosity, - optInfo :: SourcePackage -> String + optInfo :: SourcePackage -> String, + optParallel :: Bool, + optMakefile :: Bool, + optBuilddir :: FilePath, + optInstall :: String } options :: [OptDescr (Flags -> Exc.Exceptional String Flags)] @@ -90,6 +105,24 @@ "unknown info type " ++ str) "KIND") "kind of output: name, path, dir" : + Option ['p'] ["parallel"] + (NoArg (\flags -> return $ flags{optParallel = True})) + "Display independently buildable groups of packages" : + Option ['m'] ["makefile"] + (NoArg (\flags -> return $ flags{optMakefile = True})) + "Generate a makefile of package dependencies" : + Option [] ["builddir"] + (ReqArg + (\str flags -> + fmap (\dir -> flags{optBuilddir = dir}) (Exc.Success str)) + "PATH") + "Specify the build dir to use for generated makefile" : + Option [] ["install-cmd"] + (ReqArg + (\str flags -> + fmap (\cmd -> flags{optInstall = cmd}) (Exc.Success str)) + "CMD") + "Specify the install command to use in generated makefile" : [] @@ -99,12 +132,15 @@ location :: FilePath, description :: GenericPackageDescription } + deriving (Show, Eq) -sortCabalFiles :: Flags -> [FilePath] -> IO () +sortCabalFiles :: Flags -> [FilePath] -> Exc.ExceptionalT String IO () sortCabalFiles flags cabalPaths = do pkgDescs <- + Trans.lift $ mapM (readPackageDescription (optVerbosity flags)) cabalPaths when (optVerbosity flags >= Verbosity.verbose) $ + Trans.lift $ flip mapM_ pkgDescs $ \pkgDesc -> do putStrLn ((getPkgName . pkgName . package . packageDescription $ pkgDesc) ++ ":") @@ -114,15 +150,52 @@ allDependencies pkgDesc flip mapM_ deps $ \dep -> putStrLn $ " " ++ dep - mapM_ (putStrLn . optInfo flags) $ - getBuildOrder $ - zipWith SourcePackage cabalPaths pkgDescs + let pkgs = zipWith SourcePackage cabalPaths pkgDescs + graph = getBuildGraph pkgs + checkForCycles graph + Trans.lift $ + if optMakefile flags + then printMakefile flags $ getDeps graph + else if optParallel flags + then + mapM_ (putStrLn . unwords . map (optInfo flags)) $ + map (topsort' . subgraph graph) $ + components graph + else + mapM_ (putStrLn . optInfo flags) $ topsort' graph -getBuildOrder :: +printMakefile :: Flags -> [(SourcePackage, [SourcePackage])] -> IO () +printMakefile flags deps = do + let printDep (l, ls) = putStrLn (l ++ ": " ++ unwords ls) + stamp = + (optBuilddir flags ) . + flip FilePath.replaceExtension "cstamp" . location + allDeps = unwords (map (stamp . fst) deps) + putStrLn (optBuilddir flags "%.cstamp:") + putStrLn ("\t" ++ optInstall flags ++ " `dirname $*`") + putStrLn "\tmkdir -p `dirname $@`" + putStrLn "\ttouch $@" + putStrLn "" + putStrLn ("all: " ++ allDeps) + putStrLn "" + putStrLn "clean:" + putStrLn ("\t$(RM) " ++ allDeps) + putStrLn "" + mapM_ (printDep . (stamp *** map stamp)) deps + +getDeps :: Gr SourcePackage () -> [(SourcePackage, [SourcePackage])] +getDeps gr = + let c2dep :: Graph.Context SourcePackage () -> (SourcePackage, [SourcePackage]) + c2dep ctx = + (Graph.lab' ctx, + map (Graph.lab' . Graph.context gr) (Graph.pre gr . Graph.node' $ ctx)) + in Graph.ufold (\ctx ds -> c2dep ctx : ds) [] gr + +getBuildGraph :: [SourcePackage] -> - [SourcePackage] -getBuildOrder srcPkgs = + Gr SourcePackage () +getBuildGraph srcPkgs = let nodes = zip [0..] srcPkgs nodeDict = zip @@ -135,14 +208,44 @@ mapMaybe (flip lookup nodeDict . depName) (allDependencies $ description desc) + guard (dstNode /= srcNode) return (dstNode, srcNode, ()) - graph :: Gr SourcePackage () - graph = Graph.mkGraph nodes edges + in Graph.mkGraph nodes edges - in if hasCycle graph - then error "cycle in dependencies" - else topsort' graph +checkForCycles :: + Monad m => + Gr SourcePackage () -> + Exc.ExceptionalT String m () +checkForCycles graph = + case getCycles graph of + [] -> return () + cycles -> + Exc.throwT $ unlines $ + "Cycles in dependencies:" : + map (unwords . map location . nodeLabels graph) cycles + +nodeLabels :: Gr a b -> [Graph.Node] -> [a] +nodeLabels graph = + map (fromMaybe (error "node not found in graph") . + Graph.lab graph) + +subgraph :: Gr a b -> [Graph.Node] -> Gr a b +subgraph graph nodes = + let nodeSet = Set.fromList nodes + edges = do + from <- nodes + (to, lab) <- Graph.lsuc graph from + guard $ Set.member from nodeSet && Set.member to nodeSet + return (from,to,lab) + in Graph.mkGraph (zip nodes $ nodeLabels graph nodes) edges + +getCycles :: Gr a b -> [[Graph.Node]] +getCycles = + filter (\component -> case component of _:_:_ -> True; _ -> False) . + scc + + allDependencies :: GenericPackageDescription -> [Dependency] allDependencies pkg = P.buildDepends (packageDescription pkg) ++ @@ -163,7 +266,3 @@ getPkgName :: PackageName -> String getPkgName (PackageName name) = name - -hasCycle :: Gr a b -> Bool -hasCycle graph = - length (scc graph) < length (Graph.nodes graph)