{-# 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(..), readPatches, withRepositoryLocation )
import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )
import Darcs.UI.Options ( oid, (?) )
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
{ 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
, commandOptions :: CommandOptions
commandOptions = CommandOptions
showDepsOpts
}
where
showDepsBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchRange
showDepsOpts :: CommandOptions
showDepsOpts = PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Verbosity
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
[MatchFlag]
MatchOption
showDepsBasicOpts PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Verbosity
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
[MatchFlag]
-> DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
b
-> CommandOptions
`withStdOpts` DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
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 'RO () -> IO ()
forall a. UseCache -> String -> RepoJob 'RO a -> IO a
withRepositoryLocation (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
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 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO () -> RepoJob 'RO ())
-> TreePatchJob 'RO () -> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repo -> do
Sealed2 FL (PatchInfoAnd p) wX wY
range <- [MatchFlag]
-> PatchSet p Origin wR -> Sealed2 (FL (PatchInfoAnd p))
forall (p :: * -> * -> *) wY.
MatchableRP p =>
[MatchFlag]
-> PatchSet p Origin wY -> Sealed2 (FL (PatchInfoAnd p))
matchRange (PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchRange MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PatchSet p Origin wR -> Sealed2 (FL (PatchInfoAnd p)))
-> IO (PatchSet p Origin wR) -> IO (Sealed2 (FL (PatchInfoAnd p)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository 'RO p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RO p wU wR
repo
String -> IO ()
beginTedious String
progressKey
String -> Int -> IO ()
tediousSize String
progressKey (FL (PatchInfoAnd p) wX wY -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd 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 p) wX wY -> DepsGraph (PatchInfoAnd p)
forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
RL p wX wY -> DepsGraph p
depsGraph (RL (PatchInfoAnd p) wX wY -> DepsGraph (PatchInfoAnd p))
-> RL (PatchInfoAnd p) wX wY -> DepsGraph (PatchInfoAnd p)
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wX wY
range
String -> IO ()
endTedious String
progressKey
type DepsGraph p = M.Map (PatchId p) (Deps p)
type Deps p = (S.Set (PatchId p), S.Set (PatchId p))
depsGraph :: forall p wX wY. (Commute p, Ident p) => RL p wX wY -> DepsGraph p
depsGraph :: forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
RL p wX wY -> DepsGraph p
depsGraph RL p wX wY
NilRL = Map (PatchId p) (Set (PatchId p), Set (PatchId 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))
-> Map (PatchId p) (Set (PatchId p), Set (PatchId p))
-> Map (PatchId p) (Set (PatchId p), Set (PatchId p))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (p wY wY -> PatchId p
forall wX wY. p wX 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)) Map (PatchId p) (Set (PatchId p), Set (PatchId p))
m
where
m :: Map (PatchId p) (Set (PatchId p), Set (PatchId p))
m = RL p wX wY -> Map (PatchId p) (Set (PatchId p), Set (PatchId p))
forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
RL p wX wY -> DepsGraph p
depsGraph RL p wX wY
ps
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
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
-> Map (PatchId p) (Set (PatchId p), Set (PatchId p))
-> Set (PatchId p)
forall {a} {k}.
(Ord a, Ord k) =>
k -> Map k (Set a, Set a) -> Set a
allDeps PatchId p
j Map (PatchId p) (Set (PatchId p), Set (PatchId p))
m)
foldDeps :: RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
foldDeps :: 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 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)
| 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
| 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
| 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 wX wY. p wX wY -> PatchId p
forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident p wY wB
q
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]