{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.ShowDependencies ( showDeps ) where

import Darcs.Prelude

import qualified Data.Map.Strict as M
import Data.Maybe( fromJust, fromMaybe )
import qualified Data.Set as S

import Darcs.Repository ( RepoJob(..), readRepo, withRepositoryLocation )

import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )
import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts )
import Darcs.UI.Commands.Util ( matchRange )
import Darcs.UI.Completion ( noArgs )

import Darcs.Util.Hash ( sha1short, showAsHex )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer
    ( Doc
    , (<+>)
    , ($+$)
    , formatText
    , formatWords
    , hsep
    , prefixLines
    , putDocLn
    , quoted
    , renderString
    , text
    , vcat
    )
import Darcs.Util.Progress ( beginTedious, endTedious, progress, tediousSize )

import Darcs.Patch.Commute ( Commute, commuteFL )
import Darcs.Patch.Ident ( PatchId, Ident(..) )
import Darcs.Patch.Info ( PatchInfo, piName, makePatchname )
import Darcs.Patch.Witnesses.Ordered
    ( (:>)(..)
    , FL(..)
    , RL(..)
    , reverseFL
    , lengthFL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )

showDepsDescription :: String
showDepsDescription :: String
showDepsDescription = String
"Generate the graph of dependencies."

showDepsHelp :: Doc
showDepsHelp :: Doc
showDepsHelp =
  [String] -> Doc
formatWords
    [ String
"This command creates a graph of the dependencies between patches."
    , String
"The output format is the Dot Language, see"
    , String
"https://www.graphviz.org/doc/info/lang.html. The resulting graph"
    , String
"is transitively reduced, in other words,"
    , String
"it contains only the direct dependencies, not the indirect ones."
    ]
  Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
    [ String
"By default all patches in your repository are considered. You can"
    , String
"limit this to a range of patches using patch matching options, see"
    , String
"`darcs help patterns` and the options avaiable for this command."
    , String
"For instance, to visualize the dependencies between all patches"
    , String
"since the last tag, do:"
    ]
  Doc -> Doc -> Doc
$+$ Doc
"    darcs show dependencies --from-tag=. | dot -Tpdf -o FILE.pdf"
  Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
    [ String
"This command can take a very(!) long time to compute its result,"
    , String
"depending on the number of patches in the selected range. For N"
    , String
"patches it needs to do on the order of N^3 commutations in the"
    , String
"worst case."
    ]

showDeps :: DarcsCommand
showDeps :: DarcsCommand
showDeps = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"dependencies"
    , commandHelp :: Doc
commandHelp = Doc
showDepsHelp
    , commandDescription :: String
commandDescription = String
showDepsDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
findRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showDepsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showDepsOpts
    }
  where
    showDepsBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchRange
    showDepsOpts :: DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showDepsOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  [MatchFlag]
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  [MatchFlag]
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     ([MatchFlag]
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

progressKey :: String
progressKey :: String
progressKey = String
"Determining dependencies"

depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = do
    let repodir :: String
repodir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." ([DarcsFlag] -> Maybe String
getRepourl [DarcsFlag]
opts)
    UseCache -> String -> RepoJob () -> IO ()
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
repodir (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> do
        Sealed2 FL (PatchInfoAnd rt p) wX wY
range <- [MatchFlag]
-> PatchSet rt p Origin wR -> Sealed2 (FL (PatchInfoAnd rt p))
forall (p :: * -> * -> *) (rt :: RepoType) wY.
MatchableRP p =>
[MatchFlag]
-> PatchSet rt p Origin wY -> Sealed2 (FL (PatchInfoAnd rt p))
matchRange (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchRange (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag])
-> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PatchSet rt p Origin wR -> Sealed2 (FL (PatchInfoAnd rt p)))
-> IO (PatchSet rt p Origin wR)
-> IO (Sealed2 (FL (PatchInfoAnd rt p)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repo
        String -> IO ()
beginTedious String
progressKey
        String -> Int -> IO ()
tediousSize String
progressKey (FL (PatchInfoAnd rt p) wX wY -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd rt p) wX wY
range)
        Doc -> IO ()
putDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Map PatchInfo (Set PatchInfo, Set PatchInfo) -> Doc
renderDepsGraphAsDot (Map PatchInfo (Set PatchInfo, Set PatchInfo) -> Doc)
-> Map PatchInfo (Set PatchInfo, Set PatchInfo) -> Doc
forall a b. (a -> b) -> a -> b
$ RL (PatchInfoAnd rt p) wX wY -> DepsGraph (PatchInfoAnd rt p)
forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
RL p wX wY -> DepsGraph p
depsGraph (RL (PatchInfoAnd rt p) wX wY -> DepsGraph (PatchInfoAnd rt p))
-> RL (PatchInfoAnd rt p) wX wY -> DepsGraph (PatchInfoAnd rt p)
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wX wY
range
        String -> IO ()
endTedious String
progressKey

-- | A 'M.Map' from 'PatchId's to 'Deps'.
type DepsGraph p = M.Map (PatchId p) (Deps p)

-- | A pair of (direct, indirect) dependencies. For the result we need only the
-- direct dependencies. We store the indirect ones as an optimization to avoid
-- doing commutes for which we already know that they cannot succeed. Note that
-- the two sets are always disjoint.
type Deps p = (S.Set (PatchId p), S.Set (PatchId p))

-- | Determine the 'DepsGraph' of an 'RL' of patches.
depsGraph :: forall p wX wY. (Commute p, Ident p) => RL p wX wY -> DepsGraph p
depsGraph :: RL p wX wY -> DepsGraph p
depsGraph RL p wX wY
NilRL = DepsGraph p
forall k a. Map k a
M.empty
depsGraph (RL p wX wY
ps :<: p wY wY
p) =
  PatchId p
-> (Set (PatchId p), Set (PatchId p)) -> DepsGraph p -> DepsGraph p
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (p wY wY -> PatchId p
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident p wY wY
p) (RL p wX wY
-> FL p wY wY
-> FL p wY wY
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
forall wA wB wC wD.
RL p wA wB
-> FL p wB wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
foldDeps RL p wX wY
ps (p wY wY
p p wY wY -> FL p wY wY -> FL p wY wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (Set (PatchId p)
forall a. Set a
S.empty, Set (PatchId p)
forall a. Set a
S.empty)) DepsGraph p
m
  where
    -- First recurse on the context. The result now has all the 'Deps' for
    -- all patches preceding p.
    m :: DepsGraph p
m = RL p wX wY -> DepsGraph p
forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
RL p wX wY -> DepsGraph p
depsGraph RL p wX wY
ps
    -- Lookup all (direct and indirect) dependencies of a patch in a given
    -- 'DepthGraph'
    allDeps :: k -> Map k (Set a, Set a) -> Set a
allDeps k
j = (Set a -> Set a -> Set a) -> (Set a, Set a) -> Set a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union ((Set a, Set a) -> Set a)
-> (Map k (Set a, Set a) -> (Set a, Set a))
-> Map k (Set a, Set a)
-> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Set a, Set a) -> (Set a, Set a)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Set a, Set a) -> (Set a, Set a))
-> (Map k (Set a, Set a) -> Maybe (Set a, Set a))
-> Map k (Set a, Set a)
-> (Set a, Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Map k (Set a, Set a) -> Maybe (Set a, Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
j
    -- Add all (direct and indirect) dependencies of a patch to a given set
    -- assuming 'm' already
    addDeps :: PatchId p -> Set (PatchId p) -> Set (PatchId p)
addDeps PatchId p
j = PatchId p -> Set (PatchId p) -> Set (PatchId p)
forall a. Ord a => a -> Set a -> Set a
S.insert PatchId p
j (Set (PatchId p) -> Set (PatchId p))
-> (Set (PatchId p) -> Set (PatchId p))
-> Set (PatchId p)
-> Set (PatchId p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (PatchId p) -> Set (PatchId p) -> Set (PatchId p)
forall a. Ord a => Set a -> Set a -> Set a
S.union (PatchId p -> DepsGraph p -> Set (PatchId p)
forall a k. (Ord a, Ord k) => k -> Map k (Set a, Set a) -> Set a
allDeps PatchId p
j DepsGraph p
m)
    -- Add direct and indirect dependencies of a patch, assuming that the
    -- graph has already been constructed for all patches in the context.
    foldDeps :: RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
    foldDeps :: RL p wA wB
-> FL p wB wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
foldDeps RL p wA wB
NilRL FL p wB wC
_ FL p wC wD
_ (Set (PatchId p), Set (PatchId p))
acc = String
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
forall a. String -> a -> a
progress String
progressKey (Set (PatchId p), Set (PatchId p))
acc
    foldDeps (RL p wA wY
qs :<: p wY wB
q) FL p wB wC
p_and_deps FL p wC wD
non_deps acc :: (Set (PatchId p), Set (PatchId p))
acc@(Set (PatchId p)
direct, Set (PatchId p)
indirect)
      -- If we already know we indirectly depend on q, then there is
      -- nothing left to do. Note that (j `S.member` direct) is impossible.
      | PatchId p
j PatchId p -> Set (PatchId p) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set (PatchId p)
indirect = RL p wA wY
-> FL p wY wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
forall wA wB wC wD.
RL p wA wB
-> FL p wB wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
foldDeps RL p wA wY
qs (p wY wB
q p wY wB -> FL p wB wC -> FL p wY wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wB wC
p_and_deps) FL p wC wD
non_deps (Set (PatchId p), Set (PatchId p))
acc
      -- If q commutes past p_and_deps then we don't depend on it
      | Just (FL p wY wZ
p_and_deps' :> p wZ wC
q') <- (:>) p (FL p) wY wC -> Maybe ((:>) (FL p) p wY wC)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (p wY wB
q p wY wB -> FL p wB wC -> (:>) p (FL p) wY wC
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wB wC
p_and_deps) =
        RL p wA wY
-> FL p wY wZ
-> FL p wZ wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
forall wA wB wC wD.
RL p wA wB
-> FL p wB wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
foldDeps RL p wA wY
qs FL p wY wZ
p_and_deps' (p wZ wC
q' p wZ wC -> FL p wC wD -> FL p wZ wD
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wC wD
non_deps) (Set (PatchId p), Set (PatchId p))
acc
      -- We have a new dependency which must be a direct one, so add it to
      -- 'direct' and all its dependencies to 'indirect'. The invariant that
      -- direct and indirect are disjoint is maintained because neither the
      -- direct and indirect deps of a patch contain its own 'PatchId'.
      | Bool
otherwise =
        RL p wA wY
-> FL p wY wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
forall wA wB wC wD.
RL p wA wB
-> FL p wB wC
-> FL p wC wD
-> (Set (PatchId p), Set (PatchId p))
-> (Set (PatchId p), Set (PatchId p))
foldDeps RL p wA wY
qs (p wY wB
q p wY wB -> FL p wB wC -> FL p wY wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wB wC
p_and_deps) FL p wC wD
non_deps (PatchId p -> Set (PatchId p) -> Set (PatchId p)
forall a. Ord a => a -> Set a -> Set a
S.insert PatchId p
j Set (PatchId p)
direct, PatchId p -> Set (PatchId p) -> Set (PatchId p)
addDeps PatchId p
j Set (PatchId p)
indirect)
      where
        j :: PatchId p
j = p wY wB -> PatchId p
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident p wY wB
q

-- | Render a 'DepthGraph' in the Dot Language format. This function
-- considers only the direct dependencies.
renderDepsGraphAsDot :: M.Map PatchInfo (S.Set PatchInfo, S.Set PatchInfo) -> Doc
renderDepsGraphAsDot :: Map PatchInfo (Set PatchInfo, Set PatchInfo) -> Doc
renderDepsGraphAsDot Map PatchInfo (Set PatchInfo, Set PatchInfo)
g = [Doc] -> Doc
vcat [Doc
"digraph {", Doc -> Doc
indent Doc
body, Doc
"}"]
  where
    indent :: Doc -> Doc
indent = Doc -> Doc -> Doc
prefixLines (Doc
"  ")
    body :: Doc
body = [Doc] -> Doc
vcat
      [ Doc
"graph [rankdir=LR];"
      , Doc
"node [imagescale=true];"
      , [Doc] -> Doc
vcat ((PatchInfo -> Doc) -> [PatchInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> Doc
showNode (((PatchInfo, Set PatchInfo) -> PatchInfo)
-> [(PatchInfo, Set PatchInfo)] -> [PatchInfo]
forall a b. (a -> b) -> [a] -> [b]
map (PatchInfo, Set PatchInfo) -> PatchInfo
forall a b. (a, b) -> a
fst [(PatchInfo, Set PatchInfo)]
pairs))
      , [Doc] -> Doc
vcat (((PatchInfo, Set PatchInfo) -> Doc)
-> [(PatchInfo, Set PatchInfo)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PatchInfo, Set PatchInfo) -> Doc
showEdges [(PatchInfo, Set PatchInfo)]
pairs)
      ]
    pairs :: [(PatchInfo, Set PatchInfo)]
pairs = Map PatchInfo (Set PatchInfo) -> [(PatchInfo, Set PatchInfo)]
forall k a. Map k a -> [(k, a)]
M.toList (Map PatchInfo (Set PatchInfo) -> [(PatchInfo, Set PatchInfo)])
-> Map PatchInfo (Set PatchInfo) -> [(PatchInfo, Set PatchInfo)]
forall a b. (a -> b) -> a -> b
$ ((Set PatchInfo, Set PatchInfo) -> Set PatchInfo)
-> Map PatchInfo (Set PatchInfo, Set PatchInfo)
-> Map PatchInfo (Set PatchInfo)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Set PatchInfo, Set PatchInfo) -> Set PatchInfo
forall a b. (a, b) -> a
fst Map PatchInfo (Set PatchInfo, Set PatchInfo)
g
    showEdges :: (PatchInfo, Set PatchInfo) -> Doc
showEdges (PatchInfo
i, Set PatchInfo
ds)
      | Set PatchInfo -> Bool
forall a. Set a -> Bool
S.null Set PatchInfo
ds = Doc
forall a. Monoid a => a
mempty
      | Bool
otherwise =
          [Doc] -> Doc
hsep [PatchInfo -> Doc
showID PatchInfo
i, Doc
"->", Doc
"{" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hsep ((PatchInfo -> Doc) -> [PatchInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> Doc
showID (Set PatchInfo -> [PatchInfo]
forall a. Set a -> [a]
S.toList Set PatchInfo
ds)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"}"]
    showNode :: PatchInfo -> Doc
showNode PatchInfo
i = PatchInfo -> Doc
showID PatchInfo
i Doc -> Doc -> Doc
<+> Doc
"[label=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PatchInfo -> Doc
showLabel PatchInfo
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"]"
    showID :: PatchInfo -> Doc
showID = String -> Doc
quoted (String -> Doc) -> (PatchInfo -> String) -> PatchInfo -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> String
showAsHex (Word32 -> String) -> (PatchInfo -> Word32) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA1 -> Word32
sha1short (SHA1 -> Word32) -> (PatchInfo -> SHA1) -> PatchInfo -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> SHA1
makePatchname
    showLabel :: PatchInfo -> Doc
showLabel PatchInfo
i = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> Doc
formatText Int
20 [PatchInfo -> String
piName PatchInfo
i]