From e689487589144a26fb3f108acf4c58d08c8e50c8 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 4 Feb 2019 22:00:00 +0000 Subject: [PATCH 1/4] Respect dotTargets in `ls dependencies --tree` [Fixes #4552] --- src/Stack/Dot.hs | 10 ++- .../tests/4101-dependency-tree/Main.hs | 71 ++++++++++++++----- .../4101-dependency-tree/files/files.cabal | 2 +- .../4101-dependency-tree/files/stack.yaml | 1 + .../files/subproject/src/Main.hs | 5 ++ .../files/subproject/stack.yaml | 3 + .../files/subproject/subproject.cabal | 10 +++ 7 files changed, 80 insertions(+), 22 deletions(-) create mode 100644 test/integration/tests/4101-dependency-tree/files/subproject/src/Main.hs create mode 100644 test/integration/tests/4101-dependency-tree/files/subproject/stack.yaml create mode 100644 test/integration/tests/4101-dependency-tree/files/subproject/subproject.cabal diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 08a7c687d8..ff437aad2f 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -140,18 +140,24 @@ listDependencies opts = do if listDepsTree opts then do liftIO $ Text.putStrLn "Packages" - liftIO $ printTree opts 0 [] pkgs resultGraph + liftIO $ printTree opts 0 [] (treeRoots opts pkgs) resultGraph else void (Map.traverseWithKey go (snd <$> resultGraph)) where go name payload = liftIO $ Text.putStrLn $ listDepsLine opts name payload +treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName +treeRoots opts defaults = let targets = dotTargets $ listDepsDotOpts opts + in if null targets + then defaults + else Set.fromList $ map (mkPackageName . Text.unpack) targets + printTree :: ListDepsOpts -> Int -> [Int] -> Set PackageName -> Map PackageName (Set PackageName, DotPayload) -> IO () -printTree opts depth remainingDepsCounts packages dependencyMap = +printTree opts depth remainingDepsCounts packages dependencyMap = do F.sequence_ $ Seq.mapWithIndex go (toSeq packages) where toSeq = Seq.fromList . Set.toList diff --git a/test/integration/tests/4101-dependency-tree/Main.hs b/test/integration/tests/4101-dependency-tree/Main.hs index bfc179e39e..672332fcb4 100644 --- a/test/integration/tests/4101-dependency-tree/Main.hs +++ b/test/integration/tests/4101-dependency-tree/Main.hs @@ -5,32 +5,65 @@ main :: IO () main = do stackCheckStdout ["ls", "dependencies", "--tree"] $ \stdOut -> do let expected = unlines [ "Packages" - , "└─┬ files 0.1.0.0" - , " ├─┬ base 4.10.1.0" - , " │ ├─┬ ghc-prim 0.5.1.1" - , " │ │ └── rts 1.0" - , " │ ├─┬ integer-gmp 1.0.1.0" - , " │ │ └─┬ ghc-prim 0.5.1.1" - , " │ │ └── rts 1.0" - , " │ └── rts 1.0" - , " └─┬ mtl 2.2.2" - , " ├─┬ base 4.10.1.0" - , " │ ├─┬ ghc-prim 0.5.1.1" - , " │ │ └── rts 1.0" - , " │ ├─┬ integer-gmp 1.0.1.0" - , " │ │ └─┬ ghc-prim 0.5.1.1" - , " │ │ └── rts 1.0" + , "├─┬ files 0.1.0.0" + , "│ ├─┬ base 4.10.1.0" + , "│ │ ├─┬ ghc-prim 0.5.1.1" + , "│ │ │ └── rts 1.0" + , "│ │ ├─┬ integer-gmp 1.0.1.0" + , "│ │ │ └─┬ ghc-prim 0.5.1.1" + , "│ │ │ └── rts 1.0" + , "│ │ └── rts 1.0" + , "│ ├─┬ mtl 2.2.2" + , "│ │ ├─┬ base 4.10.1.0" + , "│ │ │ ├─┬ ghc-prim 0.5.1.1" + , "│ │ │ │ └── rts 1.0" + , "│ │ │ ├─┬ integer-gmp 1.0.1.0" + , "│ │ │ │ └─┬ ghc-prim 0.5.1.1" + , "│ │ │ │ └── rts 1.0" + , "│ │ │ └── rts 1.0" + , "│ │ └── transformers 0.5.2.0" + , "│ └─┬ subproject 0.1.0.0" + , "│ └─┬ base 4.10.1.0" + , "│ ├─┬ ghc-prim 0.5.1.1" + , "│ │ └── rts 1.0" + , "│ ├─┬ integer-gmp 1.0.1.0" + , "│ │ └─┬ ghc-prim 0.5.1.1" + , "│ │ └── rts 1.0" + , "│ └── rts 1.0" + , "└─┬ subproject 0.1.0.0" + , " └─┬ base 4.10.1.0" + , " ├─┬ ghc-prim 0.5.1.1" , " │ └── rts 1.0" - , " └── transformers 0.5.2.0" + , " ├─┬ integer-gmp 1.0.1.0" + , " │ └─┬ ghc-prim 0.5.1.1" + , " │ └── rts 1.0" + , " └── rts 1.0" ] when (stdOut /= expected) $ error $ unlines [ "Expected:", expected, "Actual:", stdOut ] stackCheckStdout ["ls", "dependencies", "--tree", "--depth=1"] $ \stdOut -> do let expected = unlines [ "Packages" - , "└─┬ files 0.1.0.0" - , " ├── base 4.10.1.0" - , " └── mtl 2.2.2" + , "├─┬ files 0.1.0.0" + , "│ ├── base 4.10.1.0" + , "│ ├── mtl 2.2.2" + , "│ └── subproject 0.1.0.0" + , "└─┬ subproject 0.1.0.0" + , " └── base 4.10.1.0" + ] + when (stdOut /= expected) $ + error $ unlines [ "Expected:", expected, "Actual:", stdOut ] + + stackCheckStdout ["ls", "dependencies", "--tree", "subproject"] $ \stdOut -> do + let expected = unlines [ "Packages" + , "└─┬ subproject 0.1.0.0" + , " └─┬ base 4.10.1.0" + , " ├─┬ ghc-prim 0.5.1.1" + , " │ └── rts 1.0" + , " ├─┬ integer-gmp 1.0.1.0" + , " │ └─┬ ghc-prim 0.5.1.1" + , " │ └── rts 1.0" + , " └── rts 1.0" ] 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 index 66525ce056..1ee9717152 100644 --- a/test/integration/tests/4101-dependency-tree/files/files.cabal +++ b/test/integration/tests/4101-dependency-tree/files/files.cabal @@ -6,5 +6,5 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Lib - build-depends: base >= 4.7 && < 5, mtl + build-depends: base >= 4.7 && < 5, mtl, subproject default-language: Haskell2010 diff --git a/test/integration/tests/4101-dependency-tree/files/stack.yaml b/test/integration/tests/4101-dependency-tree/files/stack.yaml index c45908a037..3235f73005 100644 --- a/test/integration/tests/4101-dependency-tree/files/stack.yaml +++ b/test/integration/tests/4101-dependency-tree/files/stack.yaml @@ -1,3 +1,4 @@ resolver: lts-11.22 packages: - . +- subproject diff --git a/test/integration/tests/4101-dependency-tree/files/subproject/src/Main.hs b/test/integration/tests/4101-dependency-tree/files/subproject/src/Main.hs new file mode 100644 index 0000000000..9cd992d9e5 --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/files/subproject/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/subproject/stack.yaml b/test/integration/tests/4101-dependency-tree/files/subproject/stack.yaml new file mode 100644 index 0000000000..c45908a037 --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/files/subproject/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-11.22 +packages: +- . diff --git a/test/integration/tests/4101-dependency-tree/files/subproject/subproject.cabal b/test/integration/tests/4101-dependency-tree/files/subproject/subproject.cabal new file mode 100644 index 0000000000..6c3a2f939d --- /dev/null +++ b/test/integration/tests/4101-dependency-tree/files/subproject/subproject.cabal @@ -0,0 +1,10 @@ +name: subproject +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 + default-language: Haskell2010 From c292e8fe7742c7833ccb72f4e763fac512aabbf0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 4 Feb 2019 22:41:28 +0000 Subject: [PATCH 2/4] Replace Map.! with Map.lookup [Fixes #4552] --- src/Stack/Dot.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index ff437aad2f..5c239964f4 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -162,12 +162,14 @@ printTree opts depth remainingDepsCounts packages dependencyMap = do where toSeq = Seq.fromList . Set.toList go index name = let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1] - (deps, payload) = (Map.!) dependencyMap name - in do + in + case Map.lookup name dependencyMap of + Just (deps, payload) -> do printTreeNode opts depth newDepsCounts deps payload name if Just depth == dotDependencyDepth (listDepsDotOpts opts) then return () else printTree opts (depth + 1) newDepsCounts deps dependencyMap + Nothing -> return () printTreeNode :: ListDepsOpts -> Int From 029022e686a711563d5dde9f1c9ff15beb7d3f3d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 4 Feb 2019 22:43:28 +0000 Subject: [PATCH 3/4] Add TODO for when a dependency is not found --- src/Stack/Dot.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 5c239964f4..54375f0b00 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -169,6 +169,7 @@ printTree opts depth remainingDepsCounts packages dependencyMap = do if Just depth == dotDependencyDepth (listDepsDotOpts opts) then return () else printTree opts (depth + 1) newDepsCounts deps dependencyMap + -- TODO: Define this behaviour, maybe return an error? Nothing -> return () printTreeNode :: ListDepsOpts From 7e204b8485ad2d19cc595975912834168aa2bd00 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 6 Feb 2019 10:07:59 +0000 Subject: [PATCH 4/4] Fix variable name and remove unnecessary do --- src/Stack/Dot.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 54375f0b00..d6177624f4 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -146,10 +146,10 @@ listDependencies opts = do where go name payload = liftIO $ Text.putStrLn $ listDepsLine opts name payload treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName -treeRoots opts defaults = let targets = dotTargets $ listDepsDotOpts opts - in if null targets - then defaults - else Set.fromList $ map (mkPackageName . Text.unpack) targets +treeRoots opts projectPackages = let targets = dotTargets $ listDepsDotOpts opts + in if null targets + then projectPackages + else Set.fromList $ map (mkPackageName . Text.unpack) targets printTree :: ListDepsOpts -> Int @@ -157,7 +157,7 @@ printTree :: ListDepsOpts -> Set PackageName -> Map PackageName (Set PackageName, DotPayload) -> IO () -printTree opts depth remainingDepsCounts packages dependencyMap = do +printTree opts depth remainingDepsCounts packages dependencyMap = F.sequence_ $ Seq.mapWithIndex go (toSeq packages) where toSeq = Seq.fromList . Set.toList