fill color for host boxes
This commit is contained in:
parent
c0ec5a35db
commit
c1b69d1511
2 changed files with 9 additions and 4 deletions
|
@ -100,7 +100,7 @@ nodeId r =
|
|||
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) $
|
||||
n = Dot.subGraph (hostname r) (basehostname r) "grey" $
|
||||
decorate $ Dot.graphNode (nodeId r) (repoName umap r)
|
||||
edges = map (edge umap fullinfo r) (Git.remotes r)
|
||||
decorate
|
||||
|
|
11
Dot.hs
11
Dot.hs
|
@ -41,13 +41,18 @@ fillColor :: String -> String -> String
|
|||
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 l s =
|
||||
"subgraph " ++ name ++ " {\n" ++ ii setlabel ++ ii s ++ indent "}"
|
||||
subGraph :: String -> String -> String -> String -> String
|
||||
subGraph subid l color s =
|
||||
"subgraph " ++ name ++ " {\n" ++
|
||||
ii setlabel ++
|
||||
ii setcolor ++
|
||||
ii s ++
|
||||
indent "}"
|
||||
where
|
||||
-- the "cluster_" makes dot draw a box
|
||||
name = quote ("cluster_" ++ subid)
|
||||
setlabel = "label=" ++ quote l
|
||||
setcolor = "fillcolor=" ++ quote color
|
||||
ii x = (indent $ indent x) ++ "\n"
|
||||
|
||||
indent ::String -> String
|
||||
|
|
Loading…
Reference in a new issue