diff --git a/Demo.hs b/Demo.hs --- a/Demo.hs +++ b/Demo.hs @@ -4,32 +4,31 @@ import Control.Monad import Data.IORef -import Data.Text.IO hiding (putStrLn) import qualified Data.Text.Lazy.IO as L -import qualified Data.Text.Lazy as B import Data.GraphViz import qualified Data.GraphViz.Types.Generalised as G +import Data.GraphViz.Commands.IO import Graphics.XDot.Parser import Graphics.XDot.Viewer import Graphics.XDot.Types hiding (w, h) -import Graphics.UI.Gtk hiding (Box, Signal, Dot, Point, Rectangle) +import Graphics.UI.Gtk hiding (Box, Signal, Dot, Point, Rectangle, Object) import Graphics.Rendering.Cairo import qualified Graphics.UI.Gtk.Gdk.Events as E data State = State - { objects :: ([(Maybe String, Operation)], Rectangle) - , bounds :: [(String, Rectangle)] + { objects :: ([(Object String, Operation)], Rectangle) + , bounds :: [(Object String, Rectangle)] , mousePos :: Point - , hover :: Maybe String + , hover :: Object String } main :: IO () main = do args <- getArgs - + quitWithoutGraphviz "Cannot continue: Graphviz is not installed" if length args == 1 then run $ head args else error "Usage: Demo file.dot" run :: String -> IO () @@ -38,15 +37,14 @@ let dg = parseDotGraph dotText :: G.DotGraph String -- You can choose another graphviz command by changing Dot to Neato, TwoPi, Circo or Fdp - xDotText <- graphvizWithHandle Dot dg XDot hGetContents - let xdg = parseDotGraph $ B.fromChunks [xDotText] :: G.DotGraph String + xdg <- graphvizWithHandle Dot dg XDot hGetDot let objs = (getOperations xdg, getSize xdg) --putStrLn $ show xdg --putStrLn $ show objs - state <- newIORef $ State objs [] (0,0) Nothing + state <- newIORef $ State objs [] (0,0) None initGUI window <- windowNew @@ -75,12 +73,12 @@ mainGUI click :: IORef State -> G.DotGraph String -> IO () -click state dg = do +click state _dg = do s <- readIORef state case hover s of - Just t -> - putStrLn $ t ++ " clicked" + Node t -> putStrLn $ "Node clicked: " ++ t + Edge f t -> putStrLn $ "Edge clicked: " ++ f ++ " -> " ++ t _ -> return () tick :: WidgetClass w => w -> IORef State -> IO () @@ -93,8 +91,12 @@ check (name', (x,y,w,h)) = if x <= mx && mx <= x + w && y <= my && my <= y + h - then Just name' else Nothing - in s' {hover = msum $ map check (bounds s')} + then name' else None + + validOne (None:xs) = validOne xs + validOne (x:_) = x + validOne _ = None + in s' {hover = validOne $ map check (bounds s')} ) s <- readIORef state diff --git a/src/Graphics/XDot/Parser.hs b/src/Graphics/XDot/Parser.hs --- a/src/Graphics/XDot/Parser.hs +++ b/src/Graphics/XDot/Parser.hs @@ -27,35 +27,33 @@ > $ dotText <- L.readFile "example.dot" > $ let dotGraph = parseDotGraph dotText :: G.DotGraph String - > $ xDotText <- graphvizWithHandle Dot dotGraph XDot T.hGetContents - > $ let xDotGraph = parseDotGraph $ B.fromChunks [xDotText] :: G.DotGraph String + > $ xDotGraph <- graphvizWithHandle Dot dotGraph XDot hGetDot :: IO (G.DotGraph String) > $ getOperations xDotGraph - > [ (Nothing,Color {rgba = (1.0,1.0,1.0,1.0), filled = False}) - > , (Nothing,Color {rgba = (1.0,1.0,1.0,1.0), filled = True}) - > , (Nothing,Polygon {points = [(0.0,-1.0),(0.0,130.0),(55.0,130.0),(55.0,-1.0)], filled = True}) - > , (Just "0",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) - > , (Just "0",Ellipse {xy = (27.0,112.0), w = 27.0, h = 18.0, filled = False}) - > , (Just "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) - > , (Just "1",Ellipse {xy = (27.0,19.0), w = 27.0, h = 19.0, filled = False}) - > , (Just "1",Font {size = 14.0, name = "Times-Roman"}) - > , (Just "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) - > , (Just "1",Text {baseline = (27.0,15.0), alignment = CenterAlign, width = 4.0, text = ":"}) - > , (Nothing,Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) - > , (Nothing,BSpline {points = [(27.0,94.0),(27.0,81.0),(27.0,63.0),(27.0,48.0)], filled = False}) - > , (Nothing,Style {style = "solid"}) - > , (Nothing,Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) - > , (Nothing,Color {rgba = (0.0,0.0,0.0,1.0), filled = True}) - > , (Nothing,Polygon {points = [(31.0,48.0),(27.0,38.0),(24.0,48.0)], filled = True}) - > , (Nothing,Font {size = 14.0, name = "Times-Roman"}) - > , (Nothing,Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) - > , (Nothing,Text {baseline = (39.0,62.0), alignment = CenterAlign, width = 24.0, text = "[1..]"}) + > [ (None,Color {rgba = (1.0,1.0,1.0,1.0), filled = False}) + > , (None,Color {rgba = (1.0,1.0,1.0,1.0), filled = True}) + > , (None,Polygon {points = [(0.0,-1.0),(0.0,130.0),(55.0,130.0),(55.0,-1.0)], filled = True}) + > , (Node "0",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) + > , (Node "0",Ellipse {xy = (27.0,112.0), w = 27.0, h = 18.0, filled = False}) + > , (Node "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) + > , (Node "1",Ellipse {xy = (27.0,19.0), w = 27.0, h = 19.0, filled = False}) + > , (Node "1",Font {size = 14.0, name = "Times-Roman"}) + > , (Node "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) + > , (Node "1",Text {baseline = (27.0,15.0), alignment = CenterAlign, width = 4.0, text = ":"}) + > , (Edge "0" "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) + > , (Edge "0" "1",BSpline {points = [(27.0,94.0),(27.0,81.0),(27.0,63.0),(27.0,48.0)], filled = False}) + > , (Edge "0" "1",Style {style = "solid"}) + > , (Edge "0" "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) + > , (Edge "0" "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = True}) + > , (Edge "0" "1",Polygon {points = [(31.0,48.0),(27.0,38.0),(24.0,48.0)], filled = True}) + > , (Edge "0" "1",Font {size = 14.0, name = "Times-Roman"}) + > , (Edge "0" "1",Color {rgba = (0.0,0.0,0.0,1.0), filled = False}) + > , (Edge "0" "1",Text {baseline = (39.0,62.0), alignment = CenterAlign, width = 24.0, text = "[1..]"}) > ] The following imports are needed for this: > import Data.GraphViz - > import Data.Text.IO as T - > import qualified Data.Text.Lazy as B + > import Data.GraphViz.Commands.IO > import qualified Data.Text.Lazy.IO as L > import qualified Data.GraphViz.Types.Generalised as G -} @@ -84,12 +82,12 @@ -- | Extract all operations of an xdot graph and connect them to the node they -- belong to, if any. -getOperations :: G.DotGraph a -> [(Maybe a, Operation)] +getOperations :: G.DotGraph a -> [(Object a, Operation)] getOperations (G.DotGraph _ _ _ graphStatements) = F.foldr handle [] graphStatements - where handle (G.GA (GraphAttrs attrs)) l = zip (repeat Nothing) (handleInternal attrs) ++ l - handle (G.DN (DotNode ident attrs)) l = zip (repeat $ Just ident) (handleInternal attrs) ++ l + where handle (G.GA (GraphAttrs attrs)) l = zip (repeat None) (handleInternal attrs) ++ l + handle (G.DN (DotNode ident attrs)) l = zip (repeat $ Node ident) (handleInternal attrs) ++ l -- TODO: Add edge identifiers - handle (G.DE (DotEdge _ _ attrs)) l = zip (repeat Nothing) (handleInternal attrs) ++ l + handle (G.DE (DotEdge from to attrs)) l = zip (repeat $ Edge from to) (handleInternal attrs) ++ l handle (G.SG (G.DotSG _ _ statements)) l = F.foldr handle [] statements ++ l handle _ l = l diff --git a/src/Graphics/XDot/Types.hs b/src/Graphics/XDot/Types.hs --- a/src/Graphics/XDot/Types.hs +++ b/src/Graphics/XDot/Types.hs @@ -10,6 +10,7 @@ Point, Rectangle, Alignment(..), + Object(..), Operation(..) ) where @@ -25,6 +26,12 @@ | CenterAlign | RightAlign deriving Show + +-- | An object an operation can belong to. +data Object n = None + | Node n + | Edge n n + deriving (Show, Eq) -- | Drawing operations supported by xdot. See -- for more information diff --git a/src/Graphics/XDot/Viewer.hs b/src/Graphics/XDot/Viewer.hs --- a/src/Graphics/XDot/Viewer.hs +++ b/src/Graphics/XDot/Viewer.hs @@ -12,11 +12,9 @@ ) where -import Data.Maybe - import Graphics.XDot.Types hiding (w, h, filled, alignment, text, name, size) -import Graphics.UI.Gtk hiding (Color, Rectangle, descent) +import Graphics.UI.Gtk hiding (Color, Rectangle, descent, Object) import Graphics.Rendering.Cairo import Control.Monad.State hiding (State) @@ -36,10 +34,10 @@ -- | Draw an xdot graph, possibly highlighting a node. drawAll :: Eq t => - Maybe t -- ^ id of the node to highlight + Object t -- ^ id of the node to highlight -> Rectangle -- ^ dimensions of the graph, as returned by 'Graphics.XDot.Parser.getSize' - -> [(Maybe t, Operation)] -- ^ operations, as returned by 'Graphics.XDot.Parser.getOperations' - -> Render [(t, Rectangle)] -- ^ dimensions of the rendered nodes on the screen + -> [(Object t, Operation)] -- ^ operations, as returned by 'Graphics.XDot.Parser.getOperations' + -> Render [(Object t, Rectangle)] -- ^ dimensions of the rendered nodes on the screen drawAll hover (_,_,sw,sh) ops = do let scalex = 1 scaley = -1 @@ -56,15 +54,15 @@ $ map (\(o, (x,y,w,h)) -> (o, (x*scalex+offsetx,y*scaley+offsety,w,h))) $ concat boundingBoxes -stylizedDraw :: Eq t => Bool -> Maybe t -> Maybe t -> Render a -> DrawState () +stylizedDraw :: Eq t => Bool -> Object t -> Object t -> Render a -> DrawState () stylizedDraw filled mn hover renderOps = do (r,g,b,a) <- getCorrectColor filled lWidth <- gets lineWidth lStyle <- gets lineStyle lift $ do - if isJust mn && mn == hover - then setSourceRGBA 1 0 0 1 + if mn /= None && mn == hover + then if filled then setSourceRGBA 1 0 0 0.3 else setSourceRGBA 1 0 0 1 else setSourceRGBA r g b a setLineWidth lWidth setDash lStyle 0 @@ -75,7 +73,7 @@ if filled then fillPreserve >> fill else stroke -draw :: Eq t => Maybe t -> (Maybe t, Operation) -> DrawState [(t, Rectangle)] +draw :: Eq t => Object t -> (Object t, Operation) -> DrawState [(Object t, Rectangle)] draw hover (mn, Ellipse (x,y) w h filled) = do stylizedDraw filled hover mn $ do translate x y @@ -84,8 +82,8 @@ arc 0 0 1 0 (2 * pi) return $ case mn of - Just node -> [(node, (x - w, y + h, 2 * w, 2 * h))] - Nothing -> [] + None -> [] + o -> [(o, (x - w, y + h, 2 * w, 2 * h))] draw hover (mn, Polygon ((x,y):xys) filled) = do stylizedDraw filled hover mn $ do @@ -97,8 +95,8 @@ let ys = y : map snd xys return $ case mn of - Just node -> [(node, (minimum xs, maximum ys, maximum xs - minimum xs, maximum ys - minimum ys))] - Nothing -> [] + None -> [] + o -> [(o, (minimum xs, maximum ys, maximum xs - minimum xs, maximum ys - minimum ys))] draw _ (_, Polygon [] _) = return [] @@ -109,72 +107,69 @@ moveTo x y drawBezier xys - return [] + return $ case mn of + None -> [] + o -> [ (o, (x - 10, y + 10, 20, 20)) + , (o, (xe - 10, ye + 10, 20, 20)) + ] where drawBezier ((x1,y1):(x2,y2):(x3,y3):xys2) = do curveTo x1 y1 x2 y2 x3 y3 drawBezier xys2 drawBezier _ = return () - + (xe,ye) = last xys draw _ (_, BSpline [] _) = return [] -draw _ (_, Text (x,y) alignment w text) = do - (r,g,b,a) <- getCorrectColor False -- stroke, not filled +draw hover (mn, Text (x,y) alignment w text) = do fontName' <- gets fontName fontSize' <- gets fontSize - lift $ do - setSourceRGBA r g b a - - layout <- createLayout "text" - context <- liftIO $ layoutGetContext layout - - fo <- liftIO $ cairoContextGetFontOptions context + layout <- lift $ createLayout text + context <- liftIO $ layoutGetContext layout - fontOptionsSetAntialias fo AntialiasDefault - fontOptionsSetHintStyle fo HintStyleNone - fontOptionsSetHintMetrics fo HintMetricsOff - liftIO $ cairoContextSetFontOptions context fo + fo <- liftIO $ cairoContextGetFontOptions context - liftIO $ layoutContextChanged layout + fontOptionsSetAntialias fo AntialiasDefault + fontOptionsSetHintStyle fo HintStyleNone + fontOptionsSetHintMetrics fo HintMetricsOff + liftIO $ cairoContextSetFontOptions context fo - -- This does not work with "Times Roman", but it works with a font that is - -- installed on the system - --font <- liftIO fontDescriptionNew - --liftIO $ fontDescriptionSetFamily font "Nimbus Roman No9 L, Regular" - --liftIO $ fontDescriptionSetFamily font "Times Roman" - --liftIO $ fontDescriptionSetSize font fontSize' + liftIO $ layoutContextChanged layout - -- Only fontDescriptionFromString works as expected, choosing a similar - -- alternative font when the selected one is not available - font <- liftIO $ fontDescriptionFromString fontName' - liftIO $ fontDescriptionSetSize font fontSize' - liftIO $ layoutSetFontDescription layout (Just font) + -- This does not work with "Times Roman", but it works with a font that is + -- installed on the system + --font <- liftIO fontDescriptionNew + --liftIO $ fontDescriptionSetFamily font "Nimbus Roman No9 L, Regular" + --liftIO $ fontDescriptionSetFamily font "Times Roman" + --liftIO $ fontDescriptionSetSize font fontSize' - liftIO $ layoutSetText layout text + -- Only fontDescriptionFromString works as expected, choosing a similar + -- alternative font when the selected one is not available + font <- liftIO $ fontDescriptionFromString fontName' + liftIO $ fontDescriptionSetSize font fontSize' + liftIO $ layoutSetFontDescription layout (Just font) - (_, PangoRectangle _ _ w2 h2) <- liftIO $ layoutGetExtents layout + (_, PangoRectangle _ _ w2 h2) <- liftIO $ layoutGetExtents layout - let (f, w3, h3, descent) = if w2 > w - then (w / w2, w, h2 * w / w2, 4 * w / w2) - else (1, w2, h2, 4) + let (f, w3, h3, descent) = if w2 > w + then (w / w2, w, h2 * w / w2, 4 * w / w2) + else (1, w2, h2, 4) - let x3 = case alignment of - LeftAlign -> x - CenterAlign -> x - 0.5 * w3 - RightAlign -> x - w3 - y3 = y + h3 - descent + let x3 = case alignment of + LeftAlign -> x + CenterAlign -> x - 0.5 * w3 + RightAlign -> x - w3 + y3 = y + h3 - descent + stylizedDraw False hover mn $ do moveTo x3 y3 - save scale f (-f) - showLayout layout - restore - - return [] + return $ case mn of + None -> [] + o -> [(o, (x3, y3, w3, h3))] draw _ (_, Color color filled) = do modify (\s -> if filled diff --git a/xdot.cabal b/xdot.cabal --- a/xdot.cabal +++ b/xdot.cabal @@ -1,5 +1,5 @@ name: xdot -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE category: Graphs, Graphics @@ -12,8 +12,8 @@ description: Parse Graphviz xdot files and interactively view them using GTK and Cairo. . - Currently not all xdot features are supported and only - nodes can be highlighted by hovering them and clicked. + Currently not all xdot features are supported. Nodes and + edges can be highlighted by hovering them and clicked. . For an example of using this library try the accompanying @Demo.hs@ with the dot-files in @dot-examples/@. @@ -22,11 +22,11 @@ Library Exposed-modules: Graphics.XDot.Parser Graphics.XDot.Viewer Graphics.XDot.Types Default-Language: Haskell2010 - Build-depends: base == 4.5.*, - mtl, + Build-depends: base == 4.*, + mtl >= 2.0, cairo, gtk, - graphviz, + graphviz >= 2999.14.1.0, text, polyparse Hs-source-dirs: src/