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