forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Insert links to DAG diagram

Browse source
This commit is contained in:
fr33domlover 2016-06-28 22:19:48 +00:00
parent 5b4607e64d
commit 063caab86d
2 changed files with 8 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/Diagrams/IntransitiveDAG.hs
View file

@ -23,12 +23,14 @@ where
import Prelude import Prelude
import Control.Arrow ((&&&))
import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Query.Layer (rlayerWith) import Data.Graph.Inductive.Query.Layer (rlayerWith)
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import Data.IntMap.Lazy (IntMap) import Data.IntMap.Lazy (IntMap)
import Data.Tuple.Select (sel2) import Data.Tuple.Select (sel2)
import Diagrams.Combinators (atop) import Diagrams.Combinators (atop)
import Diagrams.Core.Types (href)
import Diagrams.TwoD.Attributes (fc, lc) import Diagrams.TwoD.Attributes (fc, lc)
import Diagrams.TwoD.Combinators (hcat, vcat) import Diagrams.TwoD.Combinators (hcat, vcat)
import Diagrams.TwoD.Path (stroke) import Diagrams.TwoD.Path (stroke)
@ -75,18 +77,18 @@ box w h =
# fc black # fc black
# lc plain # lc plain
roleBox s = roleBox s u =
let h = 1 let h = 1
t = stroke $ textSVG' with {textFont = lin2, textHeight = h} s t = href u $ stroke $ textSVG' with {textFont = lin2, textHeight = h} s
t' = t # lc plain t' = t # lc plain
w = width t' w = width t'
b = box w h b = box w h
in t' `atop` b in t' `atop` b
-- intransDag :: Graph g => g a b -> QDiagram -- intransDag :: Graph g => g a b -> QDiagram
intransDag disp = --TODO connect the layers intransDag disp link = --TODO connect the layers
vcat . vcat .
I.elems . I.elems .
fmap (hcat . map (roleBox . disp . sel2)) . fmap (hcat . map (uncurry roleBox . (disp &&& link) . sel2)) .
attachNumbers . attachNumbers .
layers layers

2
vervis.cabal
View file

@ -201,6 +201,8 @@ library
-- for Data.Paginate.Local -- for Data.Paginate.Local
, data-default-class , data-default-class
-- for drawing DAGs: RBAC role inheritance, etc. -- for drawing DAGs: RBAC role inheritance, etc.
, diagrams-core
-- for drawing DAGs: RBAC role inheritance, etc.
, diagrams-lib , diagrams-lib
, directory , directory
-- for Data.Git.Local -- for Data.Git.Local