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

[commercialhaskell#4101]

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,36 +186,38 @@ 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
     go index name = let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1]
                      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

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

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\","