Add the stack dot command

Pinging @mboes

Author: snoyberg

ChangeLog.md

@@ -12,6 +12,7 @@
 * Don't require build plan to upload [#400](https://github.com/commercialhaskell/stack/issues/400)
 * Specifying test components only builds/runs those tests [#398](https://github.com/commercialhaskell/stack/issues/398)
 * `STACK_EXE` environment variable
+* Add the `stack dot` command
 
 Bug fixes:
 

src/Stack/Build/Source.hs

@@ -10,6 +10,7 @@ module Stack.Build.Source
     , SourceMap
     , PackageSource (..)
     , localFlags
+    , loadLocals
     ) where
 
 import Network.HTTP.Client.Conduit (HasHttpManager)

src/Stack/Dot.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Stack.Dot where
+
+
+import           Control.Monad (when)
+import           Control.Monad.Catch (MonadCatch)
+import           Control.Monad.IO.Class (MonadIO)
+import           Control.Monad.Logger (MonadLogger, logInfo)
+import           Control.Monad.Reader (MonadReader)
+import qualified Data.Foldable as F
+import           Data.Monoid ((<>))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import           Stack.Build.Source
+import           Stack.Build.Types
+import           Stack.Package
+import           Stack.Types
+
+-- | Convert a package name to a graph node name.
+nodeName :: PackageName -> T.Text
+nodeName name = "\"" <> T.pack (packageNameString name) <> "\""
+
+dot :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadCatch m,HasEnvConfig env)
+    => m ()
+dot = do
+    (locals, _names, _idents) <- loadLocals
+        BuildOpts
+            { boptsTargets = []
+            , boptsLibProfile = False
+            , boptsExeProfile = False
+            , boptsEnableOptimizations = Nothing
+            , boptsHaddock = False
+            , boptsHaddockDeps = Nothing
+            , boptsFinalAction = DoNothing
+            , boptsDryrun = False
+            , boptsGhcOptions = []
+            , boptsFlags = Map.empty
+            , boptsInstallExes = False
+            , boptsPreFetch = False
+            , boptsTestArgs = []
+            , boptsOnlySnapshot = False
+            , boptsCoverage = False
+            }
+        Map.empty
+    let localNames = Set.fromList $ map (packageName . lpPackage) locals
+
+    $logInfo "digraph deps {"
+    $logInfo "splines=polyline;"
+
+    F.forM_ locals $ \lp -> do
+        let deps = Set.intersection localNames $ packageAllDeps $ lpPackage lp
+        F.forM_ deps $ \dep ->
+            $logInfo $ T.concat
+                [ nodeName $ packageName $ lpPackage lp
+                , " -> "
+                , nodeName dep
+                , ";"
+                ]
+        when (Set.null deps) $
+            $logInfo $ T.concat
+                [ "{rank=max; "
+                , nodeName $ packageName $ lpPackage lp
+                , "}"
+                ]
+
+    $logInfo "}"

src/main/Main.hs

@@ -40,6 +40,7 @@ import           Stack.Build.Types
 import           Stack.Config
 import           Stack.Constants
 import qualified Stack.Docker as Docker
+import           Stack.Dot
 import           Stack.Exec
 import           Stack.Fetch
 import           Stack.Init
@@ -140,6 +141,10 @@ main =
                         "Upload a package to Hackage"
                         uploadCmd
                         (many $ strArgument $ metavar "TARBALL/DIR")
+             addCommand "dot"
+                        "Visualize your project's dependency graph using Graphviz dot"
+                        dotCmd
+                        (pure ())
              addCommand "exec"
                         "Execute a command"
                         execCmd
@@ -789,3 +794,7 @@ solverOptsParser = boolFlags False
     "modify-stack-yaml"
     "Automatically modify stack.yaml with the solver's recommendations"
     idm
+
+-- | Visualize dependencies
+dotCmd :: () -> GlobalOpts -> IO ()
+dotCmd () go = withBuildConfig go ThrowException dot

stack.cabal

@@ -47,6 +47,7 @@ library
                      Stack.Constants
                      Stack.Docker
                      Stack.Docker.GlobalDB
+                     Stack.Dot
                      Stack.Fetch
                      Stack.Exec
                      Stack.GhcPkg