color unreachable nodes

Command/Map.hs

@@ -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] []

Dot.hs

@@ -9,39 +9,50 @@ module Dot where -- import qualified
 
 {- generates a graph description from a list of lines -}
 graph :: [String] -> String
-graph s = unlines $ [header] ++ s ++ [footer]
+graph s = unlines $ [header] ++ map formatLine s ++ [footer]
 	where
 		header = "digraph map {"
 		footer= "}"
 
 {- a node in the graph -}
 graphNode :: String -> String -> String
-graphNode nodeid desc = lineLabeled desc $ quote nodeid
+graphNode nodeid desc = label desc $ quote nodeid
 
 {- an edge between two nodes -}
 graphEdge :: String -> String -> Maybe String -> String
-graphEdge fromid toid d =
+graphEdge fromid toid desc =
-	case d of
+	case desc of
-		Nothing -> line edge
+		Nothing -> edge
-		Just desc -> lineLabeled desc edge
+		Just d -> label d edge
 	where
 		edge = quote fromid ++ " -> " ++ quote toid
 
-quote :: String -> String
+{- adds a label to a node or edge -}
-quote s = "\"" ++ s ++ "\""
+label :: String -> String -> String
+label l s = attr "label" l s
 
-line :: String -> String
+{- adds an attribute to a node or edge
-line s = "\t" ++ s ++ ";"
+ - (can be called multiple times for multiple attributes) -}
+attr :: String -> String -> String -> String
+attr a v s = s ++ " [ " ++ a ++ "=" ++ quote v ++ " ]"
 
-{- a line with a label -}
+{- fills a node with a color -}
-lineLabeled :: String -> String -> String
+fillColor :: String -> String -> String
-lineLabeled label s = line $ s ++ " [ label=" ++ quote label ++ " ]"
+fillColor color s = attr "fillcolor" color $ attr "style" "filled" $ s
 
 {- apply to graphNode to put the node in a labeled box -}
 subGraph :: String -> String -> String -> String
-subGraph subid label s = line $
+subGraph subid l s =
-	"subgraph " ++ name ++ "{\n" ++ setlabel ++ "\n" ++ s ++ "\n}"
+	"subgraph " ++ name ++ "{\n\t" ++ setlabel ++ "\n\t\t" ++ s ++ "\n\t}"
 	where
 		-- the "cluster_" makes dot draw a box
 		name = quote ("cluster_" ++ subid)
-		setlabel = line $ "label=" ++ quote label
+		setlabel = formatLine $ "label=" ++ quote l
+
+formatLine :: String -> String	
+formatLine s = "\t" ++ s ++ ";"
+
+quote :: String -> String
+quote s = "\"" ++ s' ++ "\""
+	where
+		s' = filter (/= '"') s