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

-- | 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.DependencyTree ( DotPayload (..) )
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
  (Set PackageName
localNames, Map PackageName (Set PackageName, DotPayload)
prunedGraph) <- DotOpts
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts
  DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> RIO Runner ()
forall (m :: * -> *).
(Applicative m, MonadIO m) =>
DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
printGraph DotOpts
dotOpts Set PackageName
localNames Map PackageName (Set PackageName, DotPayload)
prunedGraph

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

-- local packages

printGraph ::
     (Applicative m, MonadIO m)
  => DotOpts
  -> Set PackageName -- ^ all locals

  -> Map PackageName (Set PackageName, DotPayload)
  -> m ()
printGraph :: forall (m :: * -> *).
(Applicative m, MonadIO m) =>
DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
printGraph DotOpts
dotOpts Set PackageName
locals Map PackageName (Set PackageName, DotPayload)
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
  Map PackageName (Set PackageName, DotPayload) -> m ()
forall (m :: * -> *).
MonadIO m =>
Map PackageName (Set PackageName, DotPayload) -> m ()
printLeaves Map PackageName (Set PackageName, DotPayload)
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 PackageName -> Set PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> Set PackageName -> m ()
printEdges ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
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 local 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 nodes without dependencies

printLeaves ::
     MonadIO m
  => Map PackageName (Set PackageName, DotPayload)
  -> m ()
printLeaves :: forall (m :: * -> *).
MonadIO m =>
Map PackageName (Set PackageName, DotPayload) -> m ()
printLeaves = (PackageName -> m ()) -> Set PackageName -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ PackageName -> m ()
forall (m :: * -> *). MonadIO m => PackageName -> m ()
printLeaf (Set PackageName -> m ())
-> (Map PackageName (Set PackageName, DotPayload)
    -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PackageName (Set PackageName) -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName (Set PackageName) -> Set PackageName)
-> (Map PackageName (Set PackageName, DotPayload)
    -> Map PackageName (Set PackageName))
-> Map PackageName (Set PackageName, DotPayload)
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set PackageName -> Bool)
-> Map PackageName (Set PackageName)
-> Map PackageName (Set PackageName)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Set PackageName -> Bool
forall a. Set a -> Bool
Set.null (Map PackageName (Set PackageName)
 -> Map PackageName (Set PackageName))
-> (Map PackageName (Set PackageName, DotPayload)
    -> Map PackageName (Set PackageName))
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set PackageName, DotPayload) -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall a b. (a -> b) -> Map PackageName a -> Map PackageName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst

-- | @printDedges p ps@ prints an edge from p to every ps

printEdges :: MonadIO m => PackageName -> Set PackageName -> m ()
printEdges :: forall (m :: * -> *).
MonadIO m =>
PackageName -> Set PackageName -> m ()
printEdges 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 -> PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> PackageName -> m ()
printEdge PackageName
package)

-- | 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 with no dependencies

printLeaf :: MonadIO m => PackageName -> m ()
printLeaf :: forall (m :: * -> *). MonadIO m => PackageName -> m ()
printLeaf PackageName
package = 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
$
  if PackageName -> Bool
isWiredIn PackageName
package
    then [Text
"{rank=max; ", PackageName -> Text
nodeName PackageName
package, Text
" [shape=box]; };"]
    else [Text
"{rank=max; ", PackageName -> Text
nodeName PackageName
package, Text
"; };"]

-- | Check if the package is wired in (shipped with) ghc

isWiredIn :: PackageName -> Bool
isWiredIn :: PackageName -> Bool
isWiredIn = (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages)