Merge pull request #4339 from akshaymankar/dependency-tree

 Add option to print dependencies as tree

First part of #4101

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:
 

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 "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)
-                      else maybe "<unknown>" (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 "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)
+    else maybe "<unknown>" (Text.pack . show) (payloadVersion payload)
 
 -- | @pruneGraph dontPrune toPrune graph@ prunes all packages in
 -- @graph@ with a name in @toPrune@ and removes resulting orphans

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)

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 ]

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

test/integration/tests/4101-dependency-tree/files/src/Main.hs

@@ -0,0 +1,5 @@
+module Main where
+
+main :: IO ()
+main = do
+  putStrLn "hello world"

test/integration/tests/4101-dependency-tree/files/stack.yaml

@@ -0,0 +1,3 @@
+resolver: lts-12.14
+packages:
+- .