From 6c972a43a66e09b28b77eb6d8b8135577149f025 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 6 Dec 2018 23:25:56 +0000 Subject: [PATCH] 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\","