From d45695ddaaceb0688800226685f6dd9c4c5aa322 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Fri, 30 Nov 2018 00:18:21 +0000 Subject: [PATCH 1/8] Add option to print dependendies as JSON [#4101] --- package.yaml | 1 + src/Stack/Dot.hs | 45 ++++++++++++++++--- src/Stack/Options/DotParser.hs | 4 ++ .../tests/4101-dependency-tree/Main.hs | 42 +++++++++++++++++ 4 files changed, 85 insertions(+), 7 deletions(-) diff --git a/package.yaml b/package.yaml index 1e1ffc553c..2c928c5a87 100644 --- a/package.yaml +++ b/package.yaml @@ -47,6 +47,7 @@ ghc-options: dependencies: - Cabal - aeson +- aeson-pretty - annotated-wl-pprint - ansi-terminal - array diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index d54d97ca17..fe4b47cfe8 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -14,6 +14,9 @@ module Stack.Dot (dot ,pruneGraph ) where +import Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy.Char8 as LBC8 import qualified Data.Foldable as F import qualified Data.Sequence as Seq import qualified Data.Set as Set @@ -76,6 +79,8 @@ data ListDepsOpts = ListDepsOpts -- ^ Print dependency licenses instead of versions. , listDepsTree :: !Bool -- ^ Print dependency tree. + , listDepsJson :: !Bool + -- ^ Print dependencies as json } -- | Visualize the project's dependencies as a graphviz graph @@ -142,13 +147,33 @@ listDependencies listDependencies opts = do let dotOpts = listDepsDotOpts opts (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts - if listDepsTree opts then - do - liftIO $ Text.putStrLn "Packages" - liftIO $ printTree opts 0 [] (treeRoots opts pkgs) resultGraph + liftIO $ + if listDepsTree opts then + Text.putStrLn "Packages" >> + printTree opts 0 [] (treeRoots opts pkgs) resultGraph + else if listDepsJson opts then printJSON pkgs resultGraph else void (Map.traverseWithKey go (snd <$> resultGraph)) - where go name payload = liftIO $ Text.putStrLn $ listDepsLine opts name payload + where go name payload = Text.putStrLn $ listDepsLine opts name payload + +data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload)) + +instance ToJSON DependencyTree where + toJSON (DependencyTree _ dependencyMap) = + toJSON $ foldToList dependencyToJSON dependencyMap + +foldToList :: (k -> a -> b) -> Map k a -> [b] +foldToList f = Map.foldrWithKey (\k a bs -> bs ++ [f k a]) [] + +dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value +dependencyToJSON pkg (_, payload) = object [ "name" .= packageNameString pkg + , "version" .= versionText payload + , "license" .= licenseText payload] + +printJSON :: Set PackageName + -> Map PackageName (Set PackageName, DotPayload) + -> IO () +printJSON pkgs dependencyMap = LBC8.putStrLn $ encodePretty $ DependencyTree pkgs dependencyMap treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName treeRoots opts projectPackages' = @@ -207,8 +232,14 @@ listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsS payloadText :: ListDepsOpts -> DotPayload -> Text payloadText opts payload = if listDepsLicense opts - then maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) - else maybe "" (Text.pack . display) (payloadVersion payload) + then licenseText payload + else versionText payload + +licenseText :: DotPayload -> Text +licenseText payload = maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) + +versionText :: DotPayload -> Text +versionText payload = maybe "" (Text.pack . display) (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 46a72d3449..ae6d85397c 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -76,4 +76,8 @@ listDepsOptsParser = ListDepsOpts "tree" "printing of dependencies as a tree" idm + <*> boolFlags False + "json" + "printing of dependencies as json" + idm where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep) diff --git a/test/integration/tests/4101-dependency-tree/Main.hs b/test/integration/tests/4101-dependency-tree/Main.hs index d88bd2d607..e38492be7f 100644 --- a/test/integration/tests/4101-dependency-tree/Main.hs +++ b/test/integration/tests/4101-dependency-tree/Main.hs @@ -74,3 +74,45 @@ main = do ] when (stdOut /= expected) $ error $ unlines [ "Expected:", expected, "Actual:", stdOut ] + + stackCheckStdout ["ls", "dependencies", "--json"] $ \stdOut -> do + let expected = unlines [ "[" + , " {" + , " \"name\": \"transformers\"," + , " \"version\": \"0.5.2.0\"," + , " \"license\": \"BSD3\"" + , " }," + , " {" + , " \"name\": \"rts\"," + , " \"version\": \"1.0\"," + , " \"license\": \"BSD3\"" + , " }," + , " {" + , " \"name\": \"mtl\"," + , " \"version\": \"2.2.2\"," + , " \"license\": \"BSD3\"" + , " }," + , " {" + , " \"name\": \"integer-gmp\"," + , " \"version\": \"1.0.1.0\"," + , " \"license\": \"BSD3\"" + , " }," + , " {" + , " \"name\": \"ghc-prim\"," + , " \"version\": \"0.5.1.1\"," + , " \"license\": \"BSD3\"" + , " }," + , " {" + , " \"name\": \"files\"," + , " \"version\": \"0.1.0.0\"," + , " \"license\": \"AllRightsReserved\"" + , " }," + , " {" + , " \"name\": \"base\"," + , " \"version\": \"4.10.1.0\"," + , " \"license\": \"BSD3\"" + , " }" + , "]" + ] + when (stdOut /= expected) $ + error $ unlines [ "Expected:", expected, "Actual:", stdOut ] From 6c972a43a66e09b28b77eb6d8b8135577149f025 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 6 Dec 2018 23:25:56 +0000 Subject: [PATCH 2/8] Read format as subcommand for `ls dependencies` This ensures interface of ls dependencies remains clean and users can only pass options when they make sense [#4101] --- src/Stack/Dot.hs | 60 ++++++++++-------- src/Stack/Options/DotParser.hs | 63 ++++++++++++------- .../tests/4101-dependency-tree/Main.hs | 6 +- 3 files changed, 77 insertions(+), 52 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index fe4b47cfe8..23e6d25757 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -9,6 +9,7 @@ module Stack.Dot (dot ,DotOpts(..) ,DotPayload(..) ,ListDepsOpts(..) + ,ListDepsFormat(..) ,resolveDependencies ,printGraph ,pruneGraph @@ -70,17 +71,23 @@ data DotOpts = DotOpts -- ^ Use global hints instead of relying on an actual GHC installation. } +data ListDepsFormat = ListDepsText { listDepsSep :: !Text + -- ^ Separator between the package name and details. + , listDepsLicense :: !Bool + -- ^ Print dependency licenses instead of versions. + } + | ListDepsTree { listDepsSep :: !Text + -- ^ Separator between the package name and details. + , listDepsLicense :: !Bool + -- ^ Print dependency licenses instead of versions. + } + | ListDepsJSON + data ListDepsOpts = ListDepsOpts - { listDepsDotOpts :: !DotOpts + { listDepsFormat :: !ListDepsFormat + -- ^ Format of printing dependencies + , listDepsDotOpts :: !DotOpts -- ^ The normal dot options. - , listDepsSep :: !Text - -- ^ Separator between the package name and details. - , listDepsLicense :: !Bool - -- ^ Print dependency licenses instead of versions. - , listDepsTree :: !Bool - -- ^ Print dependency tree. - , listDepsJson :: !Bool - -- ^ Print dependencies as json } -- | Visualize the project's dependencies as a graphviz graph @@ -147,14 +154,11 @@ listDependencies listDependencies opts = do let dotOpts = listDepsDotOpts opts (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts - liftIO $ - if listDepsTree opts then - Text.putStrLn "Packages" >> - printTree opts 0 [] (treeRoots opts pkgs) resultGraph - else if listDepsJson opts then printJSON pkgs resultGraph - else - void (Map.traverseWithKey go (snd <$> resultGraph)) - where go name payload = Text.putStrLn $ listDepsLine opts name payload + liftIO $ case listDepsFormat opts of + treeOpts@(ListDepsTree{}) -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph + ListDepsJSON -> printJSON pkgs resultGraph + textOpts@(ListDepsText{}) -> void (Map.traverseWithKey go (snd <$> resultGraph)) + where go name payload = Text.putStrLn $ listDepsLine textOpts name payload data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload)) @@ -182,13 +186,14 @@ treeRoots opts projectPackages' = then projectPackages' else Set.fromList $ map (mkPackageName . Text.unpack) targets -printTree :: ListDepsOpts +printTree :: ListDepsFormat + -> DotOpts -> Int -> [Int] -> Set PackageName -> Map PackageName (Set PackageName, DotPayload) -> IO () -printTree opts depth remainingDepsCounts packages dependencyMap = +printTree opts dotOpts depth remainingDepsCounts packages dependencyMap = F.sequence_ $ Seq.mapWithIndex go (toSeq packages) where toSeq = Seq.fromList . Set.toList @@ -196,22 +201,23 @@ printTree opts depth remainingDepsCounts packages dependencyMap = in case Map.lookup name dependencyMap of Just (deps, payload) -> do - printTreeNode opts depth newDepsCounts deps payload name - if Just depth == dotDependencyDepth (listDepsDotOpts opts) + printTreeNode opts dotOpts depth newDepsCounts deps payload name + if Just depth == dotDependencyDepth dotOpts then return () - else printTree opts (depth + 1) newDepsCounts deps dependencyMap + else printTree opts dotOpts (depth + 1) newDepsCounts deps dependencyMap -- TODO: Define this behaviour, maybe return an error? Nothing -> return () -printTreeNode :: ListDepsOpts +printTreeNode :: ListDepsFormat + -> DotOpts -> Int -> [Int] -> Set PackageName -> DotPayload -> PackageName -> IO () -printTreeNode opts depth remainingDepsCounts deps payload name = - let remainingDepth = fromMaybe 999 (dotDependencyDepth (listDepsDotOpts opts)) - depth +printTreeNode opts dotOpts depth remainingDepsCounts deps payload name = + let remainingDepth = fromMaybe 999 (dotDependencyDepth dotOpts) - depth hasDeps = not $ null deps in Text.putStrLn $ treeNodePrefix "" remainingDepsCounts hasDeps remainingDepth <> " " <> listDepsLine opts name payload @@ -226,10 +232,10 @@ 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 :: ListDepsFormat -> PackageName -> DotPayload -> Text listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText opts payload -payloadText :: ListDepsOpts -> DotPayload -> Text +payloadText :: ListDepsFormat -> DotPayload -> Text payloadText opts payload = if listDepsLicense opts then licenseText payload diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index ae6d85397c..d461da11ed 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -57,27 +57,46 @@ dotOptsParser externalDefault = globalHints = switch (long "global-hints" <> help "Do not require an install GHC; instead, use a hints file for global packages") +separatorParser :: Parser Text +separatorParser = + fmap escapeSep + (textOption (long "separator" <> + metavar "SEP" <> + help ("Separator between package name " <> + "and package version.") <> + value " " <> + showDefault)) + where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep) + +licenseParser :: Parser Bool +licenseParser = boolFlags False + "license" + "printing of dependency licenses instead of versions" + idm + +listDepsTreeParser :: Parser ListDepsFormat +listDepsTreeParser = ListDepsTree <$> separatorParser <*> licenseParser + +listDepsTextParser :: Parser ListDepsFormat +listDepsTextParser = ListDepsText <$> separatorParser <*> licenseParser + +listDepsJsonParser :: Parser ListDepsFormat +listDepsJsonParser = pure ListDepsJSON + +toListDepsOptsParser :: Parser ListDepsFormat -> Parser ListDepsOpts +toListDepsOptsParser formatParser = ListDepsOpts + <$> formatParser + <*> dotOptsParser True + +formatSubCommand :: String -> String -> Parser ListDepsFormat -> Mod CommandFields ListDepsOpts +formatSubCommand cmd desc formatParser = + command cmd (info (toListDepsOptsParser formatParser) + (progDesc desc)) + -- | Parser for arguments to `stack ls dependencies`. listDepsOptsParser :: Parser ListDepsOpts -listDepsOptsParser = ListDepsOpts - <$> dotOptsParser True -- Default for --external is True. - <*> fmap escapeSep - (textOption (long "separator" <> - metavar "SEP" <> - help ("Separator between package name " <> - "and package version.") <> - value " " <> - showDefault)) - <*> boolFlags False - "license" - "printing of dependency licenses instead of versions" - idm - <*> boolFlags False - "tree" - "printing of dependencies as a tree" - idm - <*> boolFlags False - "json" - "printing of dependencies as json" - idm - where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep) +listDepsOptsParser = subparser + ( formatSubCommand "text" "Print dependencies as text (default)" listDepsTextParser + <> formatSubCommand "tree" "Print dependencies as tree" listDepsTreeParser + <> formatSubCommand "json" "Print dependencies as JSON" listDepsJsonParser + ) <|> toListDepsOptsParser listDepsTextParser diff --git a/test/integration/tests/4101-dependency-tree/Main.hs b/test/integration/tests/4101-dependency-tree/Main.hs index e38492be7f..10d9453bb2 100644 --- a/test/integration/tests/4101-dependency-tree/Main.hs +++ b/test/integration/tests/4101-dependency-tree/Main.hs @@ -3,7 +3,7 @@ import StackTest main :: IO () main = do - stackCheckStdout ["ls", "dependencies", "--tree"] $ \stdOut -> do + stackCheckStdout ["ls", "dependencies", "tree"] $ \stdOut -> do let expected = unlines [ "Packages" , "├─┬ files 0.1.0.0" , "│ ├─┬ base 4.10.1.0" @@ -49,7 +49,7 @@ main = do when (stdOut /= expected) $ error $ unlines [ "Expected:", expected, "Actual:", stdOut ] - stackCheckStdout ["ls", "dependencies", "--tree", "--depth=1"] $ \stdOut -> do + stackCheckStdout ["ls", "dependencies", "tree", "--depth=1"] $ \stdOut -> do let expected = unlines [ "Packages" , "├─┬ files 0.1.0.0" , "│ ├── base 4.10.1.0" @@ -75,7 +75,7 @@ main = do when (stdOut /= expected) $ error $ unlines [ "Expected:", expected, "Actual:", stdOut ] - stackCheckStdout ["ls", "dependencies", "--json"] $ \stdOut -> do + stackCheckStdout ["ls", "dependencies", "json"] $ \stdOut -> do let expected = unlines [ "[" , " {" , " \"name\": \"transformers\"," From c261cd04ba19754d10f797001e054581c0786315 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 9 May 2019 15:05:03 +0100 Subject: [PATCH 3/8] Remove redundant brackets --- src/Stack/Dot.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 23e6d25757..9e5bc7a6b1 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -155,9 +155,9 @@ listDependencies opts = do let dotOpts = listDepsDotOpts opts (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts liftIO $ case listDepsFormat opts of - treeOpts@(ListDepsTree{}) -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph + treeOpts@ListDepsTree{} -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph ListDepsJSON -> printJSON pkgs resultGraph - textOpts@(ListDepsText{}) -> void (Map.traverseWithKey go (snd <$> resultGraph)) + textOpts@ListDepsText{} -> void (Map.traverseWithKey go (snd <$> resultGraph)) where go name payload = Text.putStrLn $ listDepsLine textOpts name payload data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload)) From 245a814c804fcdc08491c351b59672440a5f7da2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Sat, 15 Jun 2019 18:55:37 +0100 Subject: [PATCH 4/8] Add location information to dependency JSON [#4101] --- src/Stack/Dot.hs | 51 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 9e5bc7a6b1..7360218a83 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -30,6 +30,7 @@ import qualified Distribution.PackageDescription as PD import qualified Distribution.SPDX.License as SPDX import Distribution.License (License(BSD3), licenseFromSPDX) import Distribution.Types.PackageName (mkPackageName) +import qualified Path import RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..)) import RIO.Process (HasProcessContext (..)) import Stack.Build (loadPackage) @@ -102,6 +103,8 @@ data DotPayload = DotPayload -- ^ The package version. , payloadLicense :: Maybe (Either SPDX.License License) -- ^ The license the package was released under. + , payloadLocation :: Maybe PackageLocation + -- ^ The location of the package. } deriving (Eq, Show) -- | Create the dependency graph and also prune it as specified in the dot @@ -143,10 +146,11 @@ createDependencyGraph dotOpts = do -- Skip packages that can't be loaded - see -- https://github.com/commercialhaskell/stack/issues/2967 | name `elem` [mkPackageName "rts", mkPackageName "ghc"] = - return (Set.empty, DotPayload (Just version) (Just $ Right BSD3)) - | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions cabalConfigOpts) + return (Set.empty, DotPayload (Just version) (Just $ Right BSD3) Nothing) + | otherwise = + fmap (packageAllDeps &&& (makePayload loc)) (loadPackage loc flags ghcOptions cabalConfigOpts) resolveDependencies (dotDependencyDepth dotOpts) graph depLoader - where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) + where makePayload loc pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just $ PLImmutable loc) listDependencies :: ListDepsOpts @@ -170,9 +174,30 @@ foldToList :: (k -> a -> b) -> Map k a -> [b] foldToList f = Map.foldrWithKey (\k a bs -> bs ++ [f k a]) [] dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value -dependencyToJSON pkg (_, payload) = object [ "name" .= packageNameString pkg - , "version" .= versionText payload - , "license" .= licenseText payload] +dependencyToJSON pkg (_, payload) = let fieldsAlwaysPresent = [ "name" .= packageNameString pkg + , "license" .= licenseText payload + , "version" .= versionText payload + ] + loc = catMaybes [("location" .=) <$> pkgLocToJSON <$> payloadLocation payload] + in object $ fieldsAlwaysPresent ++ loc + +pkgLocToJSON :: PackageLocation -> Value +pkgLocToJSON (PLMutable (ResolvedPath _ dir)) = object [ "type" .= ("project package" :: Text) + , "url" .= ("file://" ++ Path.toFilePath dir)] +pkgLocToJSON (PLImmutable (PLIHackage pkgid _ _)) = object [ "type" .= ("hackage" :: Text) + , "url" .= ("https://hackage.haskell.org/package/" ++ display pkgid)] +pkgLocToJSON (PLImmutable (PLIArchive archive _)) = let url = case archiveLocation archive of + ALUrl u -> u + ALFilePath (ResolvedPath _ path) -> Text.pack $ "file://" ++ Path.toFilePath path + in object [ "type" .= ("archive" :: Text) + , "url" .= url ] +pkgLocToJSON (PLImmutable (PLIRepo repo _)) = object [ "type" .= case repoType repo of + RepoGit -> "git" :: Text + RepoHg -> "hg" :: Text + , "url" .= repoUrl repo + , "commit" .= repoCommit repo + , "subdir" .= repoSubdir repo + ] printJSON :: Set PackageName -> Map PackageName (Set PackageName, DotPayload) @@ -314,7 +339,7 @@ createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do where loadDeps pp = do pkg <- loadCommonPackage (ppCommon pp) - pure (packageAllDeps pkg, payloadFromLocal pkg) + pure (packageAllDeps pkg, payloadFromLocal pkg Nothing) dependencyDeps = loadDeps <$> Map.lookup pkgName (smDeps sourceMap) @@ -322,7 +347,7 @@ createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do loadDeps DepPackage{dpLocation=PLMutable dir} = do pp <- mkProjectPackage YesPrintWarnings dir False pkg <- loadCommonPackage (ppCommon pp) - pure (packageAllDeps pkg, payloadFromLocal pkg) + pure (packageAllDeps pkg, payloadFromLocal pkg (Just $ PLMutable dir)) loadDeps dp@DepPackage{dpLocation=PLImmutable loc} = do let common = dpCommon dp @@ -350,21 +375,23 @@ createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do noDepsErr = error ("Invariant violated: The '" ++ packageNameString pkgName ++ "' package was not found in any of the dependency sources") - payloadFromLocal pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) - payloadFromDump dp = DotPayload (Just $ pkgVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) + payloadFromLocal pkg loc = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) loc + payloadFromDump dp = DotPayload (Just $ pkgVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) Nothing -- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages) projectPackageDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))] projectPackageDependencies dotOpts locals = map (\lp -> let pkg = localPackageToPackage lp - in (packageName pkg, (deps pkg, lpPayload pkg))) + pkgDir = Path.parent $ lpCabalFile lp + loc = PLMutable $ ResolvedPath (RelFilePath "N/A") pkgDir + in (packageName pkg, (deps pkg, lpPayload pkg loc))) locals where deps pkg = if dotIncludeExternal dotOpts then Set.delete (packageName pkg) (packageAllDeps pkg) else Set.intersection localNames (packageAllDeps pkg) localNames = Set.fromList $ map (packageName . lpPackage) locals - lpPayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) + lpPayload pkg loc = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just loc) -- | Print a graphviz graph of the edges in the Map and highlight the given local packages printGraph :: (Applicative m, MonadIO m) From b3beeb22746d0ccddb1f93138e7cac44df39abf4 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Sat, 15 Jun 2019 19:26:25 +0100 Subject: [PATCH 5/8] Print dependency JSON without prettification And thus remove dependency on `aeson-pretty` [#4101] --- package.yaml | 1 - src/Stack/Dot.hs | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index 2c928c5a87..1e1ffc553c 100644 --- a/package.yaml +++ b/package.yaml @@ -47,7 +47,6 @@ ghc-options: dependencies: - Cabal - aeson -- aeson-pretty - annotated-wl-pprint - ansi-terminal - array diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 7360218a83..a49b6dab47 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -16,7 +16,6 @@ module Stack.Dot (dot ) where import Data.Aeson -import Data.Aeson.Encode.Pretty import qualified Data.ByteString.Lazy.Char8 as LBC8 import qualified Data.Foldable as F import qualified Data.Sequence as Seq @@ -202,7 +201,7 @@ pkgLocToJSON (PLImmutable (PLIRepo repo _)) = object [ "type" .= case repoType r printJSON :: Set PackageName -> Map PackageName (Set PackageName, DotPayload) -> IO () -printJSON pkgs dependencyMap = LBC8.putStrLn $ encodePretty $ DependencyTree pkgs dependencyMap +printJSON pkgs dependencyMap = LBC8.putStrLn $ encode $ DependencyTree pkgs dependencyMap treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName treeRoots opts projectPackages' = From ff842573dedf197b8a09662a51bf77a7c1dfbc8f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Sat, 15 Jun 2019 20:18:43 +0100 Subject: [PATCH 6/8] Add integration test for package location in deps [#4101] --- .../tests/4101-dependency-tree/Main.hs | 111 ++++++++++++------ .../4101-dependency-tree/files/files.cabal | 2 +- .../4101-dependency-tree/files/stack.yaml | 3 + 3 files changed, 76 insertions(+), 40 deletions(-) diff --git a/test/integration/tests/4101-dependency-tree/Main.hs b/test/integration/tests/4101-dependency-tree/Main.hs index 10d9453bb2..6cf09215ab 100644 --- a/test/integration/tests/4101-dependency-tree/Main.hs +++ b/test/integration/tests/4101-dependency-tree/Main.hs @@ -13,6 +13,75 @@ main = do , "│ │ │ └─┬ ghc-prim 0.5.1.1" , "│ │ │ └── rts 1.0" , "│ │ └── rts 1.0" + , "│ ├─┬ filelock 0.1.1.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" + , "│ │ └─┬ unix 2.7.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" + , "│ │ ├─┬ bytestring 0.10.8.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" + , "│ │ │ ├─┬ deepseq 1.4.3.0" + , "│ │ │ │ ├─┬ array 0.5.2.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" + , "│ │ │ │ └─┬ 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" + , "│ │ │ ├─┬ ghc-prim 0.5.1.1" + , "│ │ │ │ └── rts 1.0" + , "│ │ │ └─┬ integer-gmp 1.0.1.0" + , "│ │ │ └─┬ ghc-prim 0.5.1.1" + , "│ │ │ └── rts 1.0" + , "│ │ └─┬ time 1.8.0.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" + , "│ │ └─┬ deepseq 1.4.3.0" + , "│ │ ├─┬ array 0.5.2.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" + , "│ │ └─┬ 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" @@ -53,6 +122,7 @@ main = do let expected = unlines [ "Packages" , "├─┬ files 0.1.0.0" , "│ ├── base 4.10.1.0" + , "│ ├── filelock 0.1.1.2" , "│ ├── mtl 2.2.2" , "│ └── subproject 0.1.0.0" , "└─┬ subproject 0.1.0.0" @@ -61,7 +131,7 @@ main = do when (stdOut /= expected) $ error $ unlines [ "Expected:", expected, "Actual:", stdOut ] - stackCheckStdout ["ls", "dependencies", "--tree", "subproject"] $ \stdOut -> do + stackCheckStdout ["ls", "dependencies", "tree", "subproject"] $ \stdOut -> do let expected = unlines [ "Packages" , "└─┬ subproject 0.1.0.0" , " └─┬ base 4.10.1.0" @@ -76,43 +146,6 @@ main = do error $ unlines [ "Expected:", expected, "Actual:", stdOut ] stackCheckStdout ["ls", "dependencies", "json"] $ \stdOut -> do - let expected = unlines [ "[" - , " {" - , " \"name\": \"transformers\"," - , " \"version\": \"0.5.2.0\"," - , " \"license\": \"BSD3\"" - , " }," - , " {" - , " \"name\": \"rts\"," - , " \"version\": \"1.0\"," - , " \"license\": \"BSD3\"" - , " }," - , " {" - , " \"name\": \"mtl\"," - , " \"version\": \"2.2.2\"," - , " \"license\": \"BSD3\"" - , " }," - , " {" - , " \"name\": \"integer-gmp\"," - , " \"version\": \"1.0.1.0\"," - , " \"license\": \"BSD3\"" - , " }," - , " {" - , " \"name\": \"ghc-prim\"," - , " \"version\": \"0.5.1.1\"," - , " \"license\": \"BSD3\"" - , " }," - , " {" - , " \"name\": \"files\"," - , " \"version\": \"0.1.0.0\"," - , " \"license\": \"AllRightsReserved\"" - , " }," - , " {" - , " \"name\": \"base\"," - , " \"version\": \"4.10.1.0\"," - , " \"license\": \"BSD3\"" - , " }" - , "]" - ] + let expected = "[{\"name\":\"unix\",\"version\":\"2.7.2.2\",\"license\":\"BSD3\"},{\"name\":\"transformers\",\"version\":\"0.5.2.0\",\"license\":\"BSD3\"},{\"name\":\"time\",\"version\":\"1.8.0.2\",\"license\":\"BSD3\"},{\"location\":{\"url\":\"file:///Users/axeman/work/stack/test/integration/tests/4101-dependency-tree/files/subproject/\",\"type\":\"project package\"},\"name\":\"subproject\",\"version\":\"0.1.0.0\",\"license\":\"AllRightsReserved\"},{\"name\":\"rts\",\"version\":\"1.0\",\"license\":\"BSD3\"},{\"location\":{\"url\":\"https://hackage.haskell.org/package/mtl-2.2.2\",\"type\":\"hackage\"},\"name\":\"mtl\",\"version\":\"2.2.2\",\"license\":\"BSD3\"},{\"name\":\"integer-gmp\",\"version\":\"1.0.1.0\",\"license\":\"BSD3\"},{\"name\":\"ghc-prim\",\"version\":\"0.5.1.1\",\"license\":\"BSD3\"},{\"location\":{\"url\":\"file:///Users/axeman/work/stack/test/integration/tests/4101-dependency-tree/files/\",\"type\":\"project package\"},\"name\":\"files\",\"version\":\"0.1.0.0\",\"license\":\"AllRightsReserved\"},{\"location\":{\"subdir\":\"\",\"url\":\"git@github.com:snoyberg/filelock\",\"type\":\"git\",\"commit\":\"4f080496d8bf153fbe26e64d1f52cf73c7db25f6\"},\"name\":\"filelock\",\"version\":\"0.1.1.2\",\"license\":\"PublicDomain\"},{\"name\":\"deepseq\",\"version\":\"1.4.3.0\",\"license\":\"BSD3\"},{\"name\":\"bytestring\",\"version\":\"0.10.8.2\",\"license\":\"BSD3\"},{\"name\":\"base\",\"version\":\"4.10.1.0\",\"license\":\"BSD3\"},{\"name\":\"array\",\"version\":\"0.5.2.0\",\"license\":\"BSD3\"}]\n" 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 1ee9717152..bd96bcbf9c 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, subproject + build-depends: base >= 4.7 && < 5, mtl, subproject, filelock 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 3235f73005..44e69aafdd 100644 --- a/test/integration/tests/4101-dependency-tree/files/stack.yaml +++ b/test/integration/tests/4101-dependency-tree/files/stack.yaml @@ -2,3 +2,6 @@ resolver: lts-11.22 packages: - . - subproject +extra-deps: +- git: git@github.com:snoyberg/filelock + commit: 4f080496d8bf153fbe26e64d1f52cf73c7db25f6 From 5d63f6a4b1849bd74f1e94056e6b4e3db2207b4f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Sat, 15 Jun 2019 21:11:36 +0100 Subject: [PATCH 7/8] Fix linter warnings and unit tests --- src/Stack/Dot.hs | 4 ++-- src/test/Stack/DotSpec.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index a49b6dab47..3c44b5a1ed 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -147,7 +147,7 @@ createDependencyGraph dotOpts = do | name `elem` [mkPackageName "rts", mkPackageName "ghc"] = return (Set.empty, DotPayload (Just version) (Just $ Right BSD3) Nothing) | otherwise = - fmap (packageAllDeps &&& (makePayload loc)) (loadPackage loc flags ghcOptions cabalConfigOpts) + fmap (packageAllDeps &&& makePayload loc) (loadPackage loc flags ghcOptions cabalConfigOpts) resolveDependencies (dotDependencyDepth dotOpts) graph depLoader where makePayload loc pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just $ PLImmutable loc) @@ -177,7 +177,7 @@ dependencyToJSON pkg (_, payload) = let fieldsAlwaysPresent = [ "name" .= packa , "license" .= licenseText payload , "version" .= versionText payload ] - loc = catMaybes [("location" .=) <$> pkgLocToJSON <$> payloadLocation payload] + loc = catMaybes [("location" .=) . pkgLocToJSON <$> payloadLocation payload] in object $ fieldsAlwaysPresent ++ loc pkgLocToJSON :: PackageLocation -> Value diff --git a/src/test/Stack/DotSpec.hs b/src/test/Stack/DotSpec.hs index bebf76478b..4af94c2bb0 100644 --- a/src/test/Stack/DotSpec.hs +++ b/src/test/Stack/DotSpec.hs @@ -19,7 +19,7 @@ import Test.QuickCheck (forAll,choose,Gen) import Stack.Dot dummyPayload :: DotPayload -dummyPayload = DotPayload (parseVersion "0.0.0.0") (Just (Right BSD3)) +dummyPayload = DotPayload (parseVersion "0.0.0.0") (Just (Right BSD3)) Nothing spec :: Spec spec = do From e01ac7dd41c200d80a58ebc388b5f7abe1208499 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 25 Jun 2019 21:15:23 +0100 Subject: [PATCH 8/8] Extract helper type ListDepsFormatOpts --- src/Stack/Dot.hs | 31 +++++++++++++++---------------- src/Stack/Options/DotParser.hs | 7 +++++-- 2 files changed, 20 insertions(+), 18 deletions(-) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 3c44b5a1ed..7cfeb160cf 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -10,6 +10,7 @@ module Stack.Dot (dot ,DotPayload(..) ,ListDepsOpts(..) ,ListDepsFormat(..) + ,ListDepsFormatOpts(..) ,resolveDependencies ,printGraph ,pruneGraph @@ -71,16 +72,14 @@ data DotOpts = DotOpts -- ^ Use global hints instead of relying on an actual GHC installation. } -data ListDepsFormat = ListDepsText { listDepsSep :: !Text - -- ^ Separator between the package name and details. - , listDepsLicense :: !Bool - -- ^ Print dependency licenses instead of versions. - } - | ListDepsTree { listDepsSep :: !Text - -- ^ Separator between the package name and details. - , listDepsLicense :: !Bool - -- ^ Print dependency licenses instead of versions. - } +data ListDepsFormatOpts = ListDepsFormatOpts { listDepsSep :: !Text + -- ^ Separator between the package name and details. + , listDepsLicense :: !Bool + -- ^ Print dependency licenses instead of versions. + } + +data ListDepsFormat = ListDepsText ListDepsFormatOpts + | ListDepsTree ListDepsFormatOpts | ListDepsJSON data ListDepsOpts = ListDepsOpts @@ -158,9 +157,9 @@ listDependencies opts = do let dotOpts = listDepsDotOpts opts (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts liftIO $ case listDepsFormat opts of - treeOpts@ListDepsTree{} -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph + ListDepsTree treeOpts -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph ListDepsJSON -> printJSON pkgs resultGraph - textOpts@ListDepsText{} -> void (Map.traverseWithKey go (snd <$> resultGraph)) + ListDepsText textOpts -> void (Map.traverseWithKey go (snd <$> resultGraph)) where go name payload = Text.putStrLn $ listDepsLine textOpts name payload data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload)) @@ -210,7 +209,7 @@ treeRoots opts projectPackages' = then projectPackages' else Set.fromList $ map (mkPackageName . Text.unpack) targets -printTree :: ListDepsFormat +printTree :: ListDepsFormatOpts -> DotOpts -> Int -> [Int] @@ -232,7 +231,7 @@ printTree opts dotOpts depth remainingDepsCounts packages dependencyMap = -- TODO: Define this behaviour, maybe return an error? Nothing -> return () -printTreeNode :: ListDepsFormat +printTreeNode :: ListDepsFormatOpts -> DotOpts -> Int -> [Int] @@ -256,10 +255,10 @@ 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 :: ListDepsFormat -> PackageName -> DotPayload -> Text +listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText opts payload -payloadText :: ListDepsFormat -> DotPayload -> Text +payloadText :: ListDepsFormatOpts -> DotPayload -> Text payloadText opts payload = if listDepsLicense opts then licenseText payload diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index d461da11ed..7c75867f3c 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -74,11 +74,14 @@ licenseParser = boolFlags False "printing of dependency licenses instead of versions" idm +listDepsFormatOptsParser :: Parser ListDepsFormatOpts +listDepsFormatOptsParser = ListDepsFormatOpts <$> separatorParser <*> licenseParser + listDepsTreeParser :: Parser ListDepsFormat -listDepsTreeParser = ListDepsTree <$> separatorParser <*> licenseParser +listDepsTreeParser = ListDepsTree <$> listDepsFormatOptsParser listDepsTextParser :: Parser ListDepsFormat -listDepsTextParser = ListDepsText <$> separatorParser <*> licenseParser +listDepsTextParser = ListDepsText <$> listDepsFormatOptsParser listDepsJsonParser :: Parser ListDepsFormat listDepsJsonParser = pure ListDepsJSON