Draw the arrows in role diagram

src/Diagrams/IntransitiveDAG.hs

@@ -31,12 +31,14 @@ import Data.IntMap.Lazy (IntMap)
 import Data.Tuple.Select (sel2)
 import Diagrams.Combinators (atop)
 import Diagrams.Core.Types (href)
+import Diagrams.Names (named)
+import Diagrams.TwoD.Arrow (connectOutside)
 import Diagrams.TwoD.Attributes (fc, lc)
 import Diagrams.TwoD.Combinators (hcat, vcat)
 import Diagrams.TwoD.Path (stroke)
 import Diagrams.TwoD.Shapes (roundedRect)
 import Diagrams.TwoD.Size (width)
-import Diagrams.Util ((#), with)
+import Diagrams.Util ((#), with, applyAll)
 import Graphics.SVGFonts.Fonts (lin2)
 import Graphics.SVGFonts.Text (textSVG', TextOpts (..))
 --import Yesod.Core.Handler (toTextUrl)
@@ -79,18 +81,18 @@ box w h =
             # fc black
             # lc plain
 
-roleBox s u =
+textBox n s u =
     let h = 1
         t = href u $ stroke $ textSVG' with {textFont = lin2, textHeight = h} s
         t' = t # lc plain
         w = width t'
         b = box w h
-    in  t' `atop` b
+    in  named n $ t' `atop` b
 
 -- intransDag :: Graph g => g a b -> QDiagram
-intransDag disp link = --TODO connect the layers
-    vcat .
-    I.elems .
-    fmap (hcat . map (uncurry roleBox . (disp &&& link) . sel2)) .
-    attachNumbers .
-    layers
+intransDag disp link graph =
+    let ls = layers graph
+        conn (n, _, cs) = map (\ c -> connectOutside c n) cs
+        conns = concatMap (concatMap conn) ls
+        tbox (n, l, _) = textBox n (disp l) (link l)
+    in  applyAll conns $ vcat $ map (hcat . map tbox) ls