xdot 0.1 → 0.2
raw patch · 5 files changed
+106/−104 lines, 5 filesdep ~basedep ~graphvizdep ~mtl
Dependency ranges changed: base, graphviz, mtl
Files
- Demo.hs +17/−15
- src/Graphics/XDot/Parser.hs +25/−27
- src/Graphics/XDot/Types.hs +7/−0
- src/Graphics/XDot/Viewer.hs +51/−56
- xdot.cabal +6/−6
Demo.hs view
@@ -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
src/Graphics/XDot/Parser.hs view
@@ -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
src/Graphics/XDot/Types.hs view
@@ -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 -- <http://www.graphviz.org/doc/info/output.html#d:xdot> for more information
src/Graphics/XDot/Viewer.hs view
@@ -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
xdot.cabal view
@@ -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/