{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.Dot
Description : Functions related to Stack's @dot@ command.
License     : BSD-3-Clause

Functions related to Stack's @dot@ command.
-}

module Stack.Dot
  ( dotCmd
  , printGraph
  ) where

import qualified Data.Foldable as F
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import           Stack.Constants ( wiredInPackages )
import           Stack.DependencyGraph ( createPrunedDependencyGraph )
import           Stack.Prelude
import           Stack.Types.Compiler ( ActualCompiler )
import           Stack.Types.DependencyTree ( DependencyGraph )
import           Stack.Types.DotOpts ( DotOpts (..) )
import           Stack.Types.Runner ( Runner )

-- | Visualize the project's dependencies as a graphviz graph

dotCmd :: DotOpts -> RIO Runner ()
dotCmd :: DotOpts -> RIO Runner ()
dotCmd DotOpts
dotOpts = do
  (compiler, localNames, prunedGraph) <- DotOpts
-> RIO Runner (ActualCompiler, Set PackageName, DependencyGraph)
createPrunedDependencyGraph DotOpts
dotOpts
  printGraph dotOpts compiler localNames prunedGraph

-- | Print a graphviz graph of the edges in the Map and highlight the given

-- project packages

printGraph ::
     (Applicative m, MonadIO m)
  => DotOpts
  -> ActualCompiler
  -> Set PackageName -- ^ All project packages.

  -> DependencyGraph
  -> m ()
printGraph :: forall (m :: * -> *).
(Applicative m, MonadIO m) =>
DotOpts
-> ActualCompiler -> Set PackageName -> DependencyGraph -> m ()
printGraph DotOpts
dotOpts ActualCompiler
compiler Set PackageName
locals DependencyGraph
graph = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
"strict digraph deps {"
  DotOpts -> Set PackageName -> m ()
forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadIO m) =>
DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts Set PackageName
filteredLocals
  ActualCompiler -> DependencyGraph -> m ()
forall (m :: * -> *).
MonadIO m =>
ActualCompiler -> DependencyGraph -> m ()
printLeaves ActualCompiler
compiler DependencyGraph
graph
  let allNodes :: Set PackageName
allNodes = DependencyGraph -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet DependencyGraph
graph
  m (Map PackageName ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((PackageName -> Set PackageName -> m ())
-> Map PackageName (Set PackageName) -> m (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (Set PackageName -> PackageName -> Set PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
Set PackageName -> PackageName -> Set PackageName -> m ()
printEdges Set PackageName
allNodes) ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> DependencyGraph -> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DependencyGraph
graph))
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
"}"
 where
  filteredLocals :: Set PackageName
filteredLocals =
    (PackageName -> Bool) -> Set PackageName -> Set PackageName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\PackageName
local' -> PackageName
local' PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` DotOpts
dotOpts.prune) Set PackageName
locals

-- | Print the project packages nodes with a different style, depending on

-- options

printLocalNodes ::
     (F.Foldable t, MonadIO m)
  => DotOpts
  -> t PackageName
  -> m ()
printLocalNodes :: forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadIO m) =>
DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts t PackageName
locals =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn (Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
lpNodes)
 where
  applyStyle :: Text -> Text
  applyStyle :: Text -> Text
applyStyle Text
n = if DotOpts
dotOpts.includeExternal
                   then Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [style=dashed];"
                   else Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [style=solid];"
  lpNodes :: [Text]
  lpNodes :: [Text]
lpNodes = (PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
applyStyle (Text -> Text) -> (PackageName -> Text) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Text
nodeName) (t PackageName -> [PackageName]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t PackageName
locals)

-- | Print relevant nodes, based on their relevant attributes.

printLeaves :: MonadIO m => ActualCompiler -> DependencyGraph -> m ()
printLeaves :: forall (m :: * -> *).
MonadIO m =>
ActualCompiler -> DependencyGraph -> m ()
printLeaves ActualCompiler
compiler DependencyGraph
graph =
  ((PackageName, Bool, Bool) -> m ())
-> Map PackageName (PackageName, Bool, Bool) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ (PackageName, Bool, Bool) -> m ()
forall (m :: * -> *).
MonadIO m =>
(PackageName, Bool, Bool) -> m ()
printLeaf ((PackageName
 -> (Set PackageName, DotPayload) -> (PackageName, Bool, Bool))
-> DependencyGraph -> Map PackageName (PackageName, Bool, Bool)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PackageName
-> (Set PackageName, DotPayload) -> (PackageName, Bool, Bool)
nodeAttributes DependencyGraph
graph)
 where
  allNodes :: Set PackageName
allNodes = DependencyGraph -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet DependencyGraph
graph
  hasNoNodes :: Set PackageName -> Bool
hasNoNodes = (PackageName -> Bool) -> Set PackageName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set PackageName
allNodes)
  nodeAttributes :: PackageName
-> (Set PackageName, DotPayload) -> (PackageName, Bool, Bool)
nodeAttributes PackageName
package (Set PackageName
deps, DotPayload
_) =
    let isWiredInPackage :: Bool
isWiredInPackage = ActualCompiler -> PackageName -> Bool
isWiredIn ActualCompiler
compiler PackageName
package
        isBottomRow :: Bool
isBottomRow = Set PackageName -> Bool
hasNoNodes Set PackageName
deps
    in  (PackageName
package, Bool
isWiredInPackage, Bool
isBottomRow)

-- | @printDedges ps p ps'@ prints an edge from @p@ to every @ps'@, if it is a

-- member of @ps@.

printEdges ::
     MonadIO m
  => Set PackageName
     -- ^ The nodes in the graph.

  -> PackageName
     -- ^ The node in question.

  -> Set PackageName
     -- ^ The dependencies of the node in question.

  -> m ()
printEdges :: forall (m :: * -> *).
MonadIO m =>
Set PackageName -> PackageName -> Set PackageName -> m ()
printEdges Set PackageName
nodes PackageName
package Set PackageName
deps = Set PackageName -> (PackageName -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Set PackageName
deps ((PackageName -> m ()) -> m ()) -> (PackageName -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PackageName
dep ->
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
dep PackageName -> Set PackageName -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PackageName
nodes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PackageName -> PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> PackageName -> m ()
printEdge PackageName
package PackageName
dep

-- | Print an edge between the two package names

printEdge :: MonadIO m => PackageName -> PackageName -> m ()
printEdge :: forall (m :: * -> *).
MonadIO m =>
PackageName -> PackageName -> m ()
printEdge PackageName
from PackageName
to' =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn ([Text] -> Text
Text.concat [ PackageName -> Text
nodeName PackageName
from
                                      , Text
" -> "
                                      , PackageName -> Text
nodeName PackageName
to'
                                      , Text
";" ])

-- | Convert a package name to a graph node name.

nodeName :: PackageName -> Text
nodeName :: PackageName -> Text
nodeName PackageName
name = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (PackageName -> String
packageNameString PackageName
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

-- | Print a node if it (a) is a GHC wired-in package or (b) has no dependencies

-- that are also nodes.

printLeaf ::
     MonadIO m
  =>  ( PackageName
      , Bool
        -- Is package a GHC wired-in package?

      , Bool
        -- Does package have no dependencies that are are also nodes in the

        -- graph?

      )
  -> m ()
printLeaf :: forall (m :: * -> *).
MonadIO m =>
(PackageName, Bool, Bool) -> m ()
printLeaf (PackageName
package, Bool
isWiredInPackage, Bool
isBottomRow) =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isWiredInPackage Bool -> Bool -> Bool
|| Bool
isBottomRow) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([Text] -> IO ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.putStrLn (Text -> IO ()) -> ([Text] -> Text) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
         [ Text
"{"]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"rank=max; " | Bool
isBottomRow ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ PackageName -> Text
nodeName PackageName
package ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
" [shape=box]" | Bool
isWiredInPackage ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"; };" ]

-- | Check if the package is a GHC wired-in package

isWiredIn :: ActualCompiler -> PackageName -> Bool
isWiredIn :: ActualCompiler -> PackageName -> Bool
isWiredIn ActualCompiler
compiler PackageName
package =
  PackageName
package PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ActualCompiler -> Set PackageName
wiredInPackages ActualCompiler
compiler