diff --git a/cabal-sort.cabal b/cabal-sort.cabal --- a/cabal-sort.cabal +++ b/cabal-sort.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: cabal-sort -Version: 0.1.1.1 +Version: 0.1.1.2 License: BSD-3-Clause License-File: LICENSE Author: Henning Thielemann @@ -90,7 +90,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/cabal-sort/ - tag: 0.1.1.1 + tag: 0.1.1.2 Executable cabal-sort diff --git a/src/CabalSort.hs b/src/CabalSort.hs --- a/src/CabalSort.hs +++ b/src/CabalSort.hs @@ -16,9 +16,9 @@ import qualified System.FilePath as FilePath import System.FilePath (()) +import qualified Data.Graph.Inductive.Query.DFS as GraphQuery import qualified Data.Graph.Inductive.Graph as Graph -import Data.Graph.Inductive.Query.DFS (topsort', scc, components, ) -import Data.Graph.Inductive.Tree (Gr, ) +import Data.Graph.Inductive.Tree (Gr) import qualified Control.Monad.Exception.Synchronous as Exc import qualified Control.Monad.Trans.Class as Trans @@ -26,11 +26,12 @@ import Control.Monad (guard, when) import Control.Applicative (pure, (<*>), (<|>)) +import qualified Data.Foldable as Fold import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import Data.Map (Map) -import Data.Maybe (fromMaybe, mapMaybe, ) +import Data.Maybe (fromMaybe, maybeToList) main :: IO () @@ -61,8 +62,7 @@ infoMap :: Map String (SourcePackage -> String) infoMap = Map.fromList $ - ("name", - unPackageName . pkgName . package . packageDescription . description) : + ("name", unPackageName . pkgNameFromDescription . description) : ("path", location) : ("dir", FilePath.takeDirectory . location) : [] @@ -122,6 +122,8 @@ } deriving (Show, Eq) +type DependencyGraph = Gr SourcePackage () + sortCabalFiles :: Flags -> [FilePath] -> Exc.ExceptionalT String IO () sortCabalFiles flags cabalPaths = do pkgDescs <- @@ -129,28 +131,24 @@ mapM (readGenericPackageDescription (optVerbosity flags)) cabalPaths when (optVerbosity flags >= Verbosity.verbose) $ Trans.lift $ - flip mapM_ pkgDescs $ \pkgDesc -> do - putStrLn - ((unPackageName . pkgName . package . packageDescription $ - pkgDesc) - ++ ":") + Fold.for_ pkgDescs $ \pkgDesc -> do + putStrLn $ unPackageName (pkgNameFromDescription pkgDesc) ++ ":" let deps = Set.toAscList $ Set.fromList $ map (unPackageName . depName) $ allDependencies pkgDesc - flip mapM_ deps $ \dep -> - putStrLn $ " " ++ dep - let pkgs = zipWith SourcePackage cabalPaths pkgDescs - graph = getBuildGraph pkgs + Fold.for_ deps $ \dep -> putStrLn $ " " ++ dep + let graph = dependencyGraph $ zipWith SourcePackage cabalPaths pkgDescs checkForCycles graph Trans.lift $ case optOutputFormat flags of Makefile -> printMakefile flags $ getDeps graph - Serial -> mapM_ (putStrLn . optInfo flags) $ topsort' graph + Serial -> + mapM_ (putStrLn . optInfo flags) $ GraphQuery.topsort' graph Parallel -> - mapM_ (putStrLn . unwords . map (optInfo flags)) $ - map (topsort' . subgraph graph) $ - components graph + mapM_ (putStrLn . unwords . map (optInfo flags)) $ + map (GraphQuery.topsort' . flip Graph.subgraph graph) $ + GraphQuery.components graph printMakefile :: Flags -> [(SourcePackage, [SourcePackage])] -> IO () @@ -172,7 +170,7 @@ putStrLn "" mapM_ (printDep . (stamp *** map stamp)) deps -getDeps :: Gr SourcePackage () -> [(SourcePackage, [SourcePackage])] +getDeps :: DependencyGraph -> [(SourcePackage, [SourcePackage])] getDeps gr = let c2dep :: Graph.Context SourcePackage () -> (SourcePackage, [SourcePackage]) @@ -182,29 +180,22 @@ (Graph.pre gr . Graph.node' $ ctx)) in Graph.ufold (\ctx ds -> c2dep ctx : ds) [] gr -getBuildGraph :: [SourcePackage] -> Gr SourcePackage () -getBuildGraph srcPkgs = +dependencyGraph :: [SourcePackage] -> DependencyGraph +dependencyGraph srcPkgs = let nodes = zip [0..] srcPkgs nodeDict = - zip - (map (pkgName . package . packageDescription . description) - srcPkgs) - [0..] + Map.fromList $ + zip (map (pkgNameFromDescription . description) srcPkgs) [0..] edges = do (srcNode,desc) <- nodes - dstNode <- - mapMaybe - (flip lookup nodeDict . depName) - (allDependencies $ description desc) + dependency <- allDependencies $ description desc + dstNode <- maybeToList $ Map.lookup (depName dependency) nodeDict guard (dstNode /= srcNode) return (dstNode, srcNode, ()) in Graph.mkGraph nodes edges -checkForCycles :: - Monad m => - Gr SourcePackage () -> - Exc.ExceptionalT String m () +checkForCycles :: (Monad m) => DependencyGraph -> Exc.ExceptionalT String m () checkForCycles graph = case getCycles graph of [] -> return () @@ -217,20 +208,10 @@ 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 + GraphQuery.scc allDependencies :: GenericPackageDescription -> [Dependency] @@ -250,3 +231,6 @@ depName :: Dependency -> PackageName depName (Dependency name _ _) = name + +pkgNameFromDescription :: GenericPackageDescription -> PackageName +pkgNameFromDescription = pkgName . package . packageDescription