1{-# LANGUAGE OverloadedStrings #-}
2module Darcs.UI.Commands.ShowDependencies ( showDeps ) where
3
4import Darcs.Prelude
5
6import qualified Data.Map.Strict as M
7import Data.Maybe( fromJust, fromMaybe )
8import qualified Data.Set as S
9
10import Darcs.Repository ( RepoJob(..), readRepo, withRepositoryLocation )
11
12import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )
13import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )
14import qualified Darcs.UI.Options.All as O
15import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts )
16import Darcs.UI.Commands.Util ( matchRange )
17import Darcs.UI.Completion ( noArgs )
18
19import Darcs.Util.Hash ( sha1short, showAsHex )
20import Darcs.Util.Path ( AbsolutePath )
21import Darcs.Util.Printer
22    ( Doc
23    , (<+>)
24    , ($+$)
25    , formatText
26    , formatWords
27    , hsep
28    , prefixLines
29    , putDocLn
30    , quoted
31    , renderString
32    , text
33    , vcat
34    )
35import Darcs.Util.Progress ( beginTedious, endTedious, progress, tediousSize )
36
37import Darcs.Patch.Commute ( Commute, commuteFL )
38import Darcs.Patch.Ident ( PatchId, Ident(..) )
39import Darcs.Patch.Info ( PatchInfo, piName, makePatchname )
40import Darcs.Patch.Witnesses.Ordered
41    ( (:>)(..)
42    , FL(..)
43    , RL(..)
44    , reverseFL
45    , lengthFL
46    )
47import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )
48
49showDepsDescription :: String
50showDepsDescription = "Generate the graph of dependencies."
51
52showDepsHelp :: Doc
53showDepsHelp =
54  formatWords
55    [ "This command creates a graph of the dependencies between patches."
56    , "The output format is the Dot Language, see"
57    , "https://www.graphviz.org/doc/info/lang.html. The resulting graph"
58    , "is transitively reduced, in other words,"
59    , "it contains only the direct dependencies, not the indirect ones."
60    ]
61  $+$ formatWords
62    [ "By default all patches in your repository are considered. You can"
63    , "limit this to a range of patches using patch matching options, see"
64    , "`darcs help patterns` and the options avaiable for this command."
65    , "For instance, to visualize the dependencies between all patches"
66    , "since the last tag, do:"
67    ]
68  $+$ "    darcs show dependencies --from-tag=. | dot -Tpdf -o FILE.pdf"
69  $+$ formatWords
70    [ "This command can take a very(!) long time to compute its result,"
71    , "depending on the number of patches in the selected range. For N"
72    , "patches it needs to do on the order of N^3 commutations in the"
73    , "worst case."
74    ]
75
76showDeps :: DarcsCommand
77showDeps = DarcsCommand
78    { commandProgramName = "darcs"
79    , commandName = "dependencies"
80    , commandHelp = showDepsHelp
81    , commandDescription = showDepsDescription
82    , commandExtraArgs = 0
83    , commandExtraArgHelp = []
84    , commandCommand = depsCmd
85    , commandPrereq = findRepository
86    , commandCompleteArgs = noArgs
87    , commandArgdefaults = nodefaults
88    , commandAdvancedOptions = []
89    , commandBasicOptions = odesc showDepsBasicOpts
90    , commandDefaults = defaultFlags showDepsOpts
91    , commandCheckOptions = ocheck showDepsOpts
92    }
93  where
94    showDepsBasicOpts = O.matchRange
95    showDepsOpts = showDepsBasicOpts `withStdOpts` oid
96
97progressKey :: String
98progressKey = "Determining dependencies"
99
100depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
101depsCmd _ opts _ = do
102    let repodir = fromMaybe "." (getRepourl opts)
103    withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do
104        Sealed2 range <- matchRange (O.matchRange ? opts) <$> readRepo repo
105        beginTedious progressKey
106        tediousSize progressKey (lengthFL range)
107        putDocLn $ renderDepsGraphAsDot $ depsGraph $ reverseFL range
108        endTedious progressKey
109
110-- | A 'M.Map' from 'PatchId's to 'Deps'.
111type DepsGraph p = M.Map (PatchId p) (Deps p)
112
113-- | A pair of (direct, indirect) dependencies. For the result we need only the
114-- direct dependencies. We store the indirect ones as an optimization to avoid
115-- doing commutes for which we already know that they cannot succeed. Note that
116-- the two sets are always disjoint.
117type Deps p = (S.Set (PatchId p), S.Set (PatchId p))
118
119-- | Determine the 'DepsGraph' of an 'RL' of patches.
120depsGraph :: forall p wX wY. (Commute p, Ident p) => RL p wX wY -> DepsGraph p
121depsGraph NilRL = M.empty
122depsGraph (ps :<: p) =
123  M.insert (ident p) (foldDeps ps (p :>: NilFL) NilFL (S.empty, S.empty)) m
124  where
125    -- First recurse on the context. The result now has all the 'Deps' for
126    -- all patches preceding p.
127    m = depsGraph ps
128    -- Lookup all (direct and indirect) dependencies of a patch in a given
129    -- 'DepthGraph'
130    allDeps j = uncurry S.union . fromJust . M.lookup j
131    -- Add all (direct and indirect) dependencies of a patch to a given set
132    -- assuming 'm' already
133    addDeps j = S.insert j . S.union (allDeps j m)
134    -- Add direct and indirect dependencies of a patch, assuming that the
135    -- graph has already been constructed for all patches in the context.
136    foldDeps :: RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
137    foldDeps NilRL _ _ acc = progress progressKey acc
138    foldDeps (qs :<: q) p_and_deps non_deps acc@(direct, indirect)
139      -- If we already know we indirectly depend on q, then there is
140      -- nothing left to do. Note that (j `S.member` direct) is impossible.
141      | j `S.member` indirect = foldDeps qs (q :>: p_and_deps) non_deps acc
142      -- If q commutes past p_and_deps then we don't depend on it
143      | Just (p_and_deps' :> q') <- commuteFL (q :> p_and_deps) =
144        foldDeps qs p_and_deps' (q' :>: non_deps) acc
145      -- We have a new dependency which must be a direct one, so add it to
146      -- 'direct' and all its dependencies to 'indirect'. The invariant that
147      -- direct and indirect are disjoint is maintained because neither the
148      -- direct and indirect deps of a patch contain its own 'PatchId'.
149      | otherwise =
150        foldDeps qs (q :>: p_and_deps) non_deps (S.insert j direct, addDeps j indirect)
151      where
152        j = ident q
153
154-- | Render a 'DepthGraph' in the Dot Language format. This function
155-- considers only the direct dependencies.
156renderDepsGraphAsDot :: M.Map PatchInfo (S.Set PatchInfo, S.Set PatchInfo) -> Doc
157renderDepsGraphAsDot g = vcat ["digraph {", indent body, "}"]
158  where
159    indent = prefixLines ("  ")
160    body = vcat
161      [ "graph [rankdir=LR];"
162      , "node [imagescale=true];"
163      , vcat (map showNode (map fst pairs))
164      , vcat (map showEdges pairs)
165      ]
166    pairs = M.toList $ M.map fst g
167    showEdges (i, ds)
168      | S.null ds = mempty
169      | otherwise =
170          hsep [showID i, "->", "{" <> hsep (map showID (S.toList ds)) <> "}"]
171    showNode i = showID i <+> "[label=" <> showLabel i <> "]"
172    showID = quoted . showAsHex . sha1short . makePatchname
173    showLabel i = text $ show $ renderString $ formatText 20 [piName i]
174