From 7e5d74a2643402f9ce5405a1f99bb8c90804efa6 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Fri, 5 Oct 2018 00:09:39 +0100 Subject: [PATCH 1/3] Add option to print dependencies as tree [Fixes #4101] --- src/Stack/Dot.hs | 70 +++++++++++++++++++++++++++++----- src/Stack/Options/DotParser.hs | 4 ++ 2 files changed, 65 insertions(+), 9 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 2e39d76534..036e8d8e6a 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -15,6 +15,7 @@ module Stack.Dot (dot ) where import qualified Data.Foldable as F +import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as Text @@ -65,6 +66,8 @@ data ListDepsOpts = ListDepsOpts -- ^ Separator between the package name and details. , listDepsLicense :: !Bool -- ^ Print dependency licenses instead of versions. + , listDepsTree :: !Bool + -- ^ Print dependency tree. } -- | Visualize the project's dependencies as a graphviz graph @@ -132,15 +135,64 @@ listDependencies :: HasEnvConfig env -> RIO env () listDependencies opts = do let dotOpts = listDepsDotOpts opts - (_, resultGraph) <- createPrunedDependencyGraph dotOpts - void (Map.traverseWithKey go (snd <$> resultGraph)) - where go name payload = - let payloadText = - if listDepsLicense opts - then maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) - else maybe "" (Text.pack . show) (payloadVersion payload) - line = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText - in liftIO $ Text.putStrLn line + (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts + if listDepsTree opts then + do + liftIO $ Text.putStrLn "Packages" + liftIO $ printTree opts 0 [] pkgs resultGraph + else + void (Map.traverseWithKey go (snd <$> resultGraph)) + where go name payload = liftIO $ Text.putStrLn $ listDepsLine opts name payload + +printTree :: ListDepsOpts + -> Int + -> [Int] + -> Set PackageName + -> Map PackageName (Set PackageName, DotPayload) + -> IO () +printTree opts depth remainingDepsCounts packages dependencyMap = + F.sequence_ $ Seq.mapWithIndex go (toSeq packages) + where + toSeq = Seq.fromList . Set.toList + go index name = let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1] + (deps, payload) = (Map.!) dependencyMap name + in do + printTreeNode opts depth newDepsCounts deps payload name + if Just depth == dotDependencyDepth (listDepsDotOpts opts) + then return () + else printTree opts (depth + 1) newDepsCounts deps dependencyMap + +printTreeNode :: ListDepsOpts + -> Int + -> [Int] + -> Set PackageName + -> DotPayload + -> PackageName + -> IO () +printTreeNode opts depth remainingDepsCounts deps payload name = + let remainingDepth = fromMaybe 999 (dotDependencyDepth (listDepsDotOpts opts)) - depth + hasDeps = not $ null deps + in Text.putStrLn $ treeNodePrefix "" remainingDepsCounts hasDeps remainingDepth <> " " <> listDepsLine opts name payload + +treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text +treeNodePrefix t [] _ _ = t +treeNodePrefix t [0] True 0 = t <> "└──" +treeNodePrefix t [_] True 0 = t <> "├──" +treeNodePrefix t [0] True _ = t <> "└─┬" +treeNodePrefix t [_] True _ = t <> "├─┬" +treeNodePrefix t [0] False _ = t <> "└──" +treeNodePrefix t [_] False _ = t <> "├──" +treeNodePrefix t (0:ns) d remainingDepth = treeNodePrefix (t <> " ") ns d remainingDepth +treeNodePrefix t (_:ns) d remainingDepth = treeNodePrefix (t <> "│ ") ns d remainingDepth + +listDepsLine :: ListDepsOpts -> PackageName -> DotPayload -> Text +listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText opts payload + +payloadText :: ListDepsOpts -> DotPayload -> Text +payloadText opts payload = + if listDepsLicense opts + then maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) + else maybe "" (Text.pack . show) (payloadVersion payload) -- | @pruneGraph dontPrune toPrune graph@ prunes all packages in -- @graph@ with a name in @toPrune@ and removes resulting orphans diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index 351ec1ec63..ac22d81626 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -67,4 +67,8 @@ listDepsOptsParser = ListDepsOpts "license" "printing of dependency licenses instead of versions" idm + <*> boolFlags False + "tree" + "printing of dependencies as a tree" + idm where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep) From a67ba896481a5584aaeeef832591ea19fe86a636 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Fri, 5 Oct 2018 00:18:39 +0100 Subject: [PATCH 2/3] Update ChangeLog for ls dependencies --tree [#4101] --- ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index a6db22f3b9..f351bbd38a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -75,6 +75,8 @@ Other enhancements: * Use en_US.UTF-8 locale by default in pure Nix mode so programs won't crash because of Unicode in their output [#4095](https://github.com/commercialhaskell/stack/issues/4095) +* Add `--tree` to `ls dependencies` to list dependencies as tree. + [#4101](https://github.com/commercialhaskell/stack/issues/4101) Bug fixes: From 51c09e869a3413bb742c8e8356028edfa05d66b1 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Sun, 21 Oct 2018 23:05:25 +0100 Subject: [PATCH 3/3] Add integration test for printing dependency tree [#4101] --- .../tests/4101-dependency-tree/Main.hs | 36 +++++++++++++++++++ .../4101-dependency-tree/files/files.cabal | 10 ++++++ .../4101-dependency-tree/files/src/Main.hs | 5 +++ .../4101-dependency-tree/files/stack.yaml | 3 ++ 4 files changed, 54 insertions(+) create mode 100644 test/integration/tests/4101-dependency-tree/Main.hs create mode 100644 test/integration/tests/4101-dependency-tree/files/files.cabal create mode 100644 test/integration/tests/4101-dependency-tree/files/src/Main.hs create mode 100644 test/integration/tests/4101-dependency-tree/files/stack.yaml diff --git a/test/integration/tests/4101-dependency-tree/Main.hs b/test/integration/tests/4101-dependency-tree/Main.hs new file mode 100644 index 0000000000..5752cad7f0 --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/Main.hs @@ -0,0 +1,36 @@ +import Control.Monad (when) +import StackTest + +main :: IO () +main = do + stackCheckStdout ["ls", "dependencies", "--tree"] $ \stdOut -> do + let expected = unlines [ "Packages" + , "└─┬ files mkVersion [0,1,0,0]" + , " ├─┬ base mkVersion [4,11,1,0]" + , " │ ├─┬ ghc-prim mkVersion [0,5,2,0]" + , " │ │ └── rts mkVersion [1,0]" + , " │ ├─┬ integer-gmp mkVersion [1,0,2,0]" + , " │ │ └─┬ ghc-prim mkVersion [0,5,2,0]" + , " │ │ └── rts mkVersion [1,0]" + , " │ └── rts mkVersion [1,0]" + , " └─┬ mtl mkVersion [2,2,2]" + , " ├─┬ base mkVersion [4,11,1,0]" + , " │ ├─┬ ghc-prim mkVersion [0,5,2,0]" + , " │ │ └── rts mkVersion [1,0]" + , " │ ├─┬ integer-gmp mkVersion [1,0,2,0]" + , " │ │ └─┬ ghc-prim mkVersion [0,5,2,0]" + , " │ │ └── rts mkVersion [1,0]" + , " │ └── rts mkVersion [1,0]" + , " └── transformers mkVersion [0,5,5,0]" + ] + when (stdOut /= expected) $ + error $ unlines [ "Expected:", expected, "Actual:", stdOut ] + + stackCheckStdout ["ls", "dependencies", "--tree", "--depth=1"] $ \stdOut -> do + let expected = unlines [ "Packages" + , "└─┬ files mkVersion [0,1,0,0]" + , " ├── base mkVersion [4,11,1,0]" + , " └── mtl mkVersion [2,2,2]" + ] + when (stdOut /= expected) $ + error $ unlines [ "Expected:", expected, "Actual:", stdOut ] diff --git a/test/integration/tests/4101-dependency-tree/files/files.cabal b/test/integration/tests/4101-dependency-tree/files/files.cabal new file mode 100644 index 0000000000..66525ce056 --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/files/files.cabal @@ -0,0 +1,10 @@ +name: files +version: 0.1.0.0 +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib + build-depends: base >= 4.7 && < 5, mtl + default-language: Haskell2010 diff --git a/test/integration/tests/4101-dependency-tree/files/src/Main.hs b/test/integration/tests/4101-dependency-tree/files/src/Main.hs new file mode 100644 index 0000000000..9cd992d9e5 --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/files/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = do + putStrLn "hello world" diff --git a/test/integration/tests/4101-dependency-tree/files/stack.yaml b/test/integration/tests/4101-dependency-tree/files/stack.yaml new file mode 100644 index 0000000000..3e184f846f --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/files/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-12.14 +packages: +- .