diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/cabal-graphdeps.cabal b/cabal-graphdeps.cabal new file mode 100644 --- /dev/null +++ b/cabal-graphdeps.cabal @@ -0,0 +1,39 @@ +name: cabal-graphdeps +version: 0.1 +license: MIT +license-file: license.txt +author: John Millikin +maintainer: John Millikin +build-type: Simple +cabal-version: >= 1.6 +category: Development +stability: experimental +homepage: https://john-millikin.com/software/cabal-graphdeps/ +bug-reports: mailto:jmillikin@gmail.com + +synopsis: Generate graphs of install-time Cabal dependencies +description: + +source-repository head + type: git + location: https://john-millikin.com/code/cabal-graphdeps/ + +source-repository this + type: git + location: https://john-millikin.com/code/cabal-graphdeps/ + tag: cabal-graphdeps_0.1 + +executable cabal-graphdeps + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall -O2 + + build-depends: + base >= 4.0 && < 5.0 + , containers >= 0.1 + , directory + , options >= 1.0 && < 2.0 + , parsec >= 3.0 && < 3.2 + , process >= 1.2 + , split + , temporary diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,22 @@ +Copyright (c) 2012 John Millikin + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,178 @@ +-- | +-- Module: Main +-- License: MIT +-- +-- Run like: +-- >$ cabal-graphdeps mypackage | tred | dot -Tpng > ~/mypackage.png +module Main where + +import Control.Applicative +import Control.Exception +import Control.Monad (foldM, forM_) +import Data.Char (isSpace) +import Data.List (nub, sort, isInfixOf, stripPrefix) +import Data.List.Split (splitWhen) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Options +import qualified System.Directory as Filesystem +import qualified System.Process as Process +import qualified System.IO as IO +import System.IO.Temp (withSystemTempDirectory) +import qualified Text.Parsec as Parsec +import qualified Text.Parsec.String as Parsec + +data MainOptions = MainOptions + { optGlobalPackageDb :: String + , optFundamental :: [String] + , optExclude :: Set.Set String + } + +instance Options MainOptions where + defineOptions = pure MainOptions + <*> simpleOption "global-package-db" "" + "" + <*> defineOption (optionType_list ',' optionType_string) (\o -> o + { optionLongFlags = ["fundamental-packages"] + , optionDefault = ["base"] + , optionDescription = "These packages and their dependencies should be considered fundamental to the package DB." + }) + <*> defineOption (optionType_set ',' optionType_string) (\o -> o + { optionLongFlags = ["exclude-packages"] + , optionDefault = Set.empty + , optionDescription = "These packages and their dependencies will be excluded when rendering the graph." + }) + +resolveDeps :: MainOptions -> Map.Map String (Set.Set String) -> String -> IO (Map.Map String (Set.Set String)) +resolveDeps _ allDeps pkg | Map.member pkg allDeps = return allDeps +resolveDeps opts allDeps pkg | Set.member (extractPkgName pkg) (optExclude opts) = return allDeps +resolveDeps opts allDeps pkg = do + let header1 = "Resolving dependencies...\nIn order, the following would be installed (use -v for more details):\n" + let header2 = "Resolving dependencies...\nIn order, the following would be installed:\n" + + IO.hPutStrLn IO.stderr ("[" ++ pkg ++ "]") + output <- Process.readProcess "cabal" ["--package-db=clear", "install", "--dry-run", "--ghc-pkg-options=--global-package-db=./empty-db", pkg] "" + if "All the requested packages are already installed:" `isInfixOf` output + then return allDeps + else do + trimmedOutput <- case stripPrefix header1 output of + Just stripped -> return stripped + Nothing -> case stripPrefix header2 output of + Just stripped -> return stripped + Nothing -> do + IO.hPutStrLn IO.stderr (show output) + error "unknown output format" + let newDeps = linesToDeps pkg (splitWhen (== '\n') trimmedOutput) + let insertedDeps = Map.insertWith Set.union pkg newDeps allDeps + foldM (resolveDeps opts) insertedDeps (Set.toList newDeps) + +linesToDeps :: String -> [String] -> Set.Set String +linesToDeps pkg lines = Set.fromList $ do + line <- filter (not . null) lines + parsedLine <- case stringMatch lineOnlyVersion line of + Just _ -> return line + Nothing -> case stringMatch lineVersionWithNote line of + Just version -> return version + Nothing -> error ("can't parse line " ++ show line) + if parsedLine == pkg + then [] + else [parsedLine] + +stringMatch :: Parsec.Parser a -> String -> Maybe a +stringMatch parser input = case Parsec.parse parser "" input of + Left _ -> Nothing + Right x -> Just x + +lineOnlyVersion :: Parsec.Parser () +lineOnlyVersion = do + Parsec.skipMany1 alphaNumDot + Parsec.eof + +lineVersionWithNote :: Parsec.Parser String +lineVersionWithNote = do + version <- Parsec.many1 alphaNumDot + _ <- Parsec.char ' ' + _ <- Parsec.char '(' + Parsec.skipMany1 Parsec.anyChar + Parsec.eof + return version + +alphaNumDot :: Parsec.Parser Char +alphaNumDot = Parsec.lower <|> Parsec.digit <|> Parsec.oneOf "-." + +renderDeps :: MainOptions -> Map.Map String (Set.Set String) -> String -> [String] +renderDeps opts deps pkg = do + dep <- Set.toList (Map.findWithDefault Set.empty pkg deps) + let line = (show pkg ++ " -> " ++ show dep) + -- map "foo-bar-baz-1.0" to "foo-bar-baz" for excluded packages + if Set.member (extractPkgName dep) (optExclude opts) + then [] + else line : renderDeps opts deps dep + +extractPkgName :: String -> String +extractPkgName pkg = case stripPrefix "-" (dropWhile (/= '-') (reverse pkg)) of + Nothing -> pkg + Just rev -> reverse rev + +printDeps :: MainOptions -> Map.Map String (Set.Set String) -> String -> IO () +printDeps opts deps pkg = forM_ (nub (sort (renderDeps opts deps pkg))) putStrLn + +readGhcPkgField :: String -> String -> IO String +readGhcPkgField pkgName fieldName = do + rawField <- Process.readProcess "ghc-pkg" ["field", pkgName, fieldName] "" + case stripPrefix (fieldName ++ ":") rawField of + Nothing -> error ("Unexpected output from ghc-pkg field: " ++ show rawField) + Just s -> return (dropWhile isSpace (dropWhileEnd isSpace s)) + +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] + +initSandbox :: MainOptions -> IO () +initSandbox opts = do + _ <- Process.readProcess "cabal" ["sandbox", "init"] "" + Filesystem.createDirectory "empty-db" + + globalDb <- case optGlobalPackageDb opts of + -- Look for the global package DB + "" -> do + rawGlobalDb <- Process.readProcess "ghc-pkg" ["list", "--no-user-package-db"] "" + case lines rawGlobalDb of + firstLine:_ -> + -- ghc-pkg adds a ':' to the first line when not + -- run from a terminal + return (reverse (drop 1 (reverse firstLine))) + _ -> error "Unexpected output from ghc-pkg list" + path -> return path + + -- these packages and their dependencies will be excluded from the + -- graph for being fundamental. + forM_ (optFundamental opts) $ \pkg -> do + -- find package id (used in .conf filename) + pkgId <- readGhcPkgField pkg "id" + let pkgConf = pkgId ++ ".conf" + + -- try to figure out what the package depends on; in the GHC + -- installed on my system, ::depends includes all dependencies + -- of the package. + deps <- readGhcPkgField pkg "depends" + let splitDeps = words deps + let emptyPackageDbConfs = pkgConf : [s ++ ".conf" | s <- splitDeps] + forM_ emptyPackageDbConfs $ \conf -> Filesystem.copyFile (globalDb ++ "/" ++ conf) ("empty-db/" ++ conf) + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory dir io = bracket + (do + cwd <- Filesystem.getCurrentDirectory + Filesystem.setCurrentDirectory dir + return cwd) + Filesystem.setCurrentDirectory + (\_ -> io) + +main :: IO () +main = runCommand $ \opts args -> do + deps <- withSystemTempDirectory "cabal-graphdeps.d-" $ \dir -> withCurrentDirectory dir $ do + initSandbox opts + resolveDeps opts Map.empty (args !! 0) + putStrLn "digraph {" + printDeps opts deps (args !! 0) + putStrLn "}"