Add option to print dependendies as JSON

[commercialhaskell#4101]
akshaymankar · Jun 15, 2019 · b595d12 · b595d12
1 parent b7644ee
commit b595d12
Show file tree

Hide file tree

Showing 4 changed files with 85 additions and 7 deletions.
diff --git a/package.yaml b/package.yaml
@@ -40,6 +40,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
@@ -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 "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)
-    else maybe "<unknown>" (Text.pack . display) (payloadVersion payload)
+    then licenseText payload
+    else versionText payload
+
+licenseText :: DotPayload -> Text
+licenseText payload = maybe "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)
+
+versionText :: DotPayload -> Text
+versionText payload = maybe "<unknown>" (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
@@ -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
@@ -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 ]