{-# 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
{ 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 = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
([MatchFlag]
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
showDepsOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
([MatchFlag]
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
showDepsOpts
}
where
showDepsBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchRange
showDepsOpts :: DarcsOption
a
([MatchFlag]
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
showDepsOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` 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 = forall a. a -> Maybe a -> a
fromMaybe String
"." ([DarcsFlag] -> Maybe String
getRepourl [DarcsFlag]
opts)
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
repodir forall a b. (a -> b) -> a -> b
$ 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 a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> do
Sealed2 FL (PatchInfoAnd rt p) wX wY
range <- 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 (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd rt p) wX wY
range)
Doc -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ Map PatchInfo (Set PatchInfo, Set PatchInfo) -> Doc
renderDepsGraphAsDot forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
(Commute p, Ident p) =>
RL p wX wY -> DepsGraph p
depsGraph forall a b. (a -> b) -> a -> b
$ 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
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 = forall k a. Map k a
M.empty
depsGraph (RL p wX wY
ps :<: p wY wY
p) =
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall (p :: * -> * -> *) wX wY. Ident p => p wX wY -> PatchId p
ident p wY wY
p) (forall wA wB wC wD.
RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
foldDeps RL p wX wY
ps (p wY wY
p forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (forall a. Set a
S.empty, forall a. Set a
S.empty)) Map (PatchId p) (Deps p)
m
where
m :: Map (PatchId p) (Deps p)
m = 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 = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Ord a => Set a -> Set a -> Set a
S.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Ord a => a -> Set a -> Set a
S.insert PatchId p
j forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
S.union (forall {a} {k}.
(Ord a, Ord k) =>
k -> Map k (Set a, Set a) -> Set a
allDeps PatchId p
j Map (PatchId p) (Deps 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 -> Deps p -> Deps p
foldDeps RL p wA wB
NilRL FL p wB wC
_ FL p wC wD
_ Deps p
acc = forall a. String -> a -> a
progress String
progressKey Deps 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 :: Deps p
acc@(Set (PatchId p)
direct, Set (PatchId p)
indirect)
| PatchId p
j forall a. Ord a => a -> Set a -> Bool
`S.member` Set (PatchId p)
indirect = forall wA wB wC wD.
RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
foldDeps RL p wA wY
qs (p wY wB
q 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 Deps p
acc
| Just (FL p wY wZ
p_and_deps' :> p wZ wC
q') <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (p wY wB
q forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wB wC
p_and_deps) =
forall wA wB wC wD.
RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
foldDeps RL p wA wY
qs FL p wY wZ
p_and_deps' (p wZ wC
q' forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wC wD
non_deps) Deps p
acc
| Bool
otherwise =
forall wA wB wC wD.
RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
foldDeps RL p wA wY
qs (p wY wB
q 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 (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 = 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 (forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> Doc
showNode (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PatchInfo, Set PatchInfo)]
pairs))
, [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (PatchInfo, Set PatchInfo) -> Doc
showEdges [(PatchInfo, Set PatchInfo)]
pairs)
]
pairs :: [(PatchInfo, Set PatchInfo)]
pairs = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map 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)
| forall a. Set a -> Bool
S.null Set PatchInfo
ds = forall a. Monoid a => a
mempty
| Bool
otherwise =
[Doc] -> Doc
hsep [PatchInfo -> Doc
showID PatchInfo
i, Doc
"->", Doc
"{" forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> Doc
showID (forall a. Set a -> [a]
S.toList Set PatchInfo
ds)) forall a. Semigroup a => a -> a -> a
<> Doc
"}"]
showNode :: PatchInfo -> Doc
showNode PatchInfo
i = PatchInfo -> Doc
showID PatchInfo
i Doc -> Doc -> Doc
<+> Doc
"[label=" forall a. Semigroup a => a -> a -> a
<> PatchInfo -> Doc
showLabel PatchInfo
i forall a. Semigroup a => a -> a -> a
<> Doc
"]"
showID :: PatchInfo -> Doc
showID = String -> Doc
quoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> String
showAsHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA1 -> Word32
sha1short forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> SHA1
makePatchname
showLabel :: PatchInfo -> Doc
showLabel PatchInfo
i = String -> Doc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString forall a b. (a -> b) -> a -> b
$ Int -> [String] -> Doc
formatText Int
20 [PatchInfo -> String
piName PatchInfo
i]