color unreachable nodes
This commit is contained in:
parent
67c1facad1
commit
0fd0e414ec
2 changed files with 40 additions and 20 deletions
|
@ -51,11 +51,12 @@ start = do
|
|||
- displayed as a node, and each of its remotes is represented as an edge
|
||||
- pointing at the node for the remote. -}
|
||||
drawMap :: [Git.Repo] -> (M.Map UUID String) -> String
|
||||
drawMap rs umap = Dot.graph $ repos ++ others
|
||||
drawMap rs umap = Dot.graph $ others ++ repos
|
||||
where
|
||||
repos = map (node umap rs) rs
|
||||
others = map uuidnode (M.keys umap)
|
||||
uuidnode u = Dot.graphNode u $ M.findWithDefault "" u umap
|
||||
uuidnode u = unreachable $
|
||||
Dot.graphNode u $ M.findWithDefault "" u umap
|
||||
|
||||
hostname :: Git.Repo -> String
|
||||
hostname r
|
||||
|
@ -78,7 +79,7 @@ repoName umap r
|
|||
Just n -> n
|
||||
Nothing -> "unknown"
|
||||
|
||||
{- A unique id for the node. Uses the annex.uuid if available. -}
|
||||
{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
|
||||
nodeId :: Git.Repo -> String
|
||||
nodeId r =
|
||||
case (getUncachedUUID r) of
|
||||
|
@ -90,8 +91,11 @@ node :: (M.Map UUID String) -> [Git.Repo] -> Git.Repo -> String
|
|||
node umap fullinfo r = unlines $ n:edges
|
||||
where
|
||||
n = Dot.subGraph (hostname r) (basehostname r) $
|
||||
Dot.graphNode (nodeId r) (repoName umap r)
|
||||
decorate $ Dot.graphNode (nodeId r) (repoName umap r)
|
||||
edges = map (edge umap fullinfo r) (Git.remotes r)
|
||||
decorate
|
||||
| Git.configMap r == M.empty = unreachable
|
||||
| otherwise = reachable
|
||||
|
||||
{- An edge between two repos. The second repo is a remote of the first. -}
|
||||
edge :: (M.Map UUID String) -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
|
||||
|
@ -115,6 +119,11 @@ edge umap fullinfo from to =
|
|||
then Nothing
|
||||
else Just n
|
||||
|
||||
unreachable :: String -> String
|
||||
unreachable s = Dot.fillColor "red" s
|
||||
reachable :: String -> String
|
||||
reachable s = Dot.fillColor "white" s
|
||||
|
||||
{- Recursively searches out remotes starting with the specified repo. -}
|
||||
spider :: Git.Repo -> Annex [Git.Repo]
|
||||
spider r = spider' [r] []
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue