diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, IlyaPortnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of IlyaPortnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dot2graphml.cabal b/dot2graphml.cabal new file mode 100644 --- /dev/null +++ b/dot2graphml.cabal @@ -0,0 +1,29 @@ +name: dot2graphml +version: 0.1.0.0 +synopsis: Converter from GraphViz .dot format to yEd GraphML +description: This package contains a converter from DOT format used by + GraphViz (http://graphviz.org) to variant of GraphML + (http://graphml.graphdrawing.org/) used by yEd + (http://www.yworks.com/en/products_yed_about.html). +homepage: http://redmine.iportnov.ru/projects/dot2graphml +license: BSD3 +license-file: LICENSE +author: IlyaPortnov +maintainer: portnov84@rambler.ru +-- copyright: +category: Graphics +build-type: Simple +cabal-version: >=1.8 + +executable dot2graphml + main-is: dot2graphml.hs + -- other-modules: + build-depends: base > 4 && < 5, + containers >= 0.4, + hxt >= 9.2, + graphviz, + text >= 0.11.2.3 + +Source-repository head + type: git + location: git://redmine.iportnov.ru/dot2graphml.git diff --git a/dot2graphml.hs b/dot2graphml.hs new file mode 100644 --- /dev/null +++ b/dot2graphml.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ViewPatterns #-} + +import Data.Sequence hiding (filter, sort) +import qualified Data.Foldable as F +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as TIO +import Data.List +import Data.Maybe +import Data.GraphViz +import Data.GraphViz.Attributes.Complete +import qualified Data.GraphViz.Types.Generalised as G +import Text.XML.HXT.Core +import Text.Printf +import System.Environment + +parseDot :: Maybe FilePath -> IO (G.DotGraph String) +parseDot mbPath = do + text <- case mbPath of + Just path -> TIO.readFile path + Nothing -> TIO.getContents + return (parseDotGraph text) + +graphml :: String +graphml = "http://graphml.graphdrawing.org/xmlns/graphml" + +yed :: String +yed = "http://www.yworks.com/xml/graphml" + +graphXml :: ArrowXml a => G.DotGraph String -> a XmlTree XmlTree +graphXml dot = + let g = mkQName "g" "graphml" graphml + sts = G.graphStatements dot + fullGraph = undeclaredNodes sts >< sts + defcolor = fromMaybe "#FFFFCC" $ getColor $ concat [ga | G.GA (GraphAttrs ga) <- F.toList sts] + in mkqelem g [sattr "xmlns" graphml, sattr "xmlns:y" yed, + sattr "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance", + sattr "xsi:schemaLocation" "http://graphml.graphdrawing.org/xmlns/graphml http://www.yworks.com/xml/schema/graphml/1.0/ygraphml.xsd"] $ + [mkelem "key" [sattr "for" "node", + sattr "id" "d0", + sattr "yfiles.type" "nodegraphics"] [], + mkelem "key" [sattr "for" "node", + sattr "id" "d1", + sattr "name" "description", + sattr "attr.type" "string"] [], + mkelem "key" [sattr "for" "edge", + sattr "id" "d2", + sattr "yfiles.type" "nodegraphics"] [], + mkelem "key" [sattr "for" "edge", + sattr "id" "d3", + sattr "name" "description", + sattr "attr.type" "string"] [], + mkelem "key" [sattr "for" "graphml", + sattr "id" "d4", + sattr "yfiles.type" "resources"] [], + mkelem "key" [sattr "for" "node", + sattr "id" "d6", + sattr "yfiles.type" "nodegraphics"] [], + mkelem "graph" ([sattr "edgedefault" "directed", + sattr "parse.order" "free", + sattr "parse.edges" (show $ nEdges fullGraph), + sattr "parse.nodes" (show $ nNodes fullGraph)] ++ idAttr (G.graphID dot)) (run defcolor fullGraph), + mkelem "data" [sattr "key" "d4"] [ + mkqelem (mkQName "y" "Resources" "") [] [] ] + ] + +nNodes sts = sum $ seqmap go sts + where + go (G.DN _) = 1 + go (G.SG (G.DotSG _ _ subgraph)) = nNodes subgraph + go _ = 0 + +nEdges sts = sum $ seqmap go sts + where + go (G.DE _) = 1 + go (G.SG (G.DotSG _ _ subgraph)) = nEdges subgraph + go _ = 0 + +seqmap f xs = F.toList $ fmap f xs + +showGID Nothing = "" +showGID (Just (Str str)) = T.unpack str +showGID (Just (Int int)) = "i" ++ show int +showGID (Just (Dbl dbl)) = "d" ++ show dbl + +idAttr Nothing = [] +idAttr x@(Just _) = [sattr "id" (showGID x)] + +idAttr' s Nothing = [sattr "id" s] +idAttr' s x = [sattr "id" (showGID x ++ s)] + +allNodeNames :: G.DotStatements String -> [String] +allNodeNames sts = concatMap go (F.toList sts) + where + go (G.DN (G.DotNode nid _)) = [nid] + go (G.SG (G.DotSG _ _ sg)) = concatMap go (F.toList sg) + go _ = [] + +undeclaredNodes :: G.DotStatements String -> G.DotStatements String +undeclaredNodes sts = + let allUsed = nub $ sort $ concat [ [from, to] | G.DE (G.DotEdge from to _) <- F.toList sts ] + declaredNodes = allNodeNames sts + mkNode name = G.DotNode name [Label (StrLabel $ T.pack name)] + in fromList $ map (G.DN . mkNode) $ filter (`notElem` declaredNodes) allUsed + +run :: ArrowXml a => String -> G.DotStatements String -> [a XmlTree XmlTree] +run baseClr sts = concat $ seqmap fromRoot sts + where + defcolor = fromMaybe baseClr $ getColor $ concat $ + [ga | G.GA (G.GraphAttrs ga) <- concatMap F.toList [sg | G.SG (G.DotSG _ _ sg) <- F.toList sts]] + + fromRoot (G.SG (G.DotSG cl gid subgraph)) = seqmap go subgraph + fromRoot (G.DE (G.DotEdge from to _)) = [mkelem "edge" [sattr "source" from, + sattr "target" to, + sattr "id" (from ++ to) ] [] ] + fromRoot (G.DN (G.DotNode nid attrs)) = [mkelem "node" [sattr "id" nid] [ynode (getLabel attrs) (Just defcolor)] ] + fromRoot x = [cmt (show x)] + + go :: ArrowXml a => G.DotStatement String -> a XmlTree XmlTree + go (G.SG (G.DotSG _ gid subgraph)) = + mkelem "node" (idAttr gid ++ [sattr "yfiles.foldertype" "group"]) [ + ygroup (getLabel $ graphAttrs subgraph) (getColor $ graphAttrs subgraph), + mkelem "graph" (idAttr' ":g" gid) (seqmap go subgraph) ] + go (G.DN (G.DotNode nid attrs)) = + mkelem "node" [sattr "id" nid] [ynode (getLabel attrs) (getColor attrs), + mkelem "data" [sattr "key" "d1"] [] ] + go (G.DE (G.DotEdge from to _)) = + mkelem "edge" [sattr "source" from, + sattr "target" to, + sattr "id" (from ++ to)] [mkelem "data" [sattr "key" "d3"] [] ] + go (G.GA ga) = cmt (show ga) + + graphAttrs sts = case [ga | G.GA (G.GraphAttrs ga) <- F.toList sts] of + [] -> [] + (ga:_) -> ga + + shapeNode = mkQName "y" "ShapeNode" "" + nodeLabel = mkQName "y" "NodeLabel" "" + geometry = mkQName "y" "Geometry" "" + fill = mkQName "y" "Fill" "" + border = mkQName "y" "BotderStyle" "" + shape = mkQName "y" "Shape" "" + proxyAutoBounds = mkQName "y" "ProxyAutoBoundsNode" "" + realizers = mkQName "y" "Realizers" "" + groupNode = mkQName "y" "GroupNode" "" + state = mkQName "y" "State" "" + + clrAttr Nothing = sattr "color" defcolor + clrAttr (Just clr) = sattr "color" clr + + ynode label color = + mkelem "data" [sattr "key" "d0"] [ + mkqelem shapeNode [] [ + mkqelem geometry [sattr "height" "30.0", sattr "width" "30.0", sattr "x" "0.0", sattr "y" "0.0"] [], + mkqelem fill [clrAttr color, sattr "transparent" "false"] [], + mkqelem border [sattr "color" "#000000", sattr "type" "line", sattr "width" "1.0"] [], + mkqelem shape [sattr "type" "rectangle"] [], + mkqelem nodeLabel [sattr "alignment" "center", + sattr "autoSizePolicy" "content", + sattr "hasBackgroundColor" "false", + sattr "modelName" "internal", + sattr "modelPosition" "c" ] [txt label] ] ] + + ygroup label color = + let lbl = mkqelem nodeLabel [sattr "height" "25.0", + sattr "alignment" "right", + sattr "autoSizePolicy" "node_width", + sattr "borderDistance" "0.0", + sattr "modelName" "internal", + sattr "modelPosition" "t", + sattr "visible" "true"] [txt label] + in mkelem "data" [sattr "key" "d6"] [ + mkqelem proxyAutoBounds [] [ + mkqelem realizers [sattr "active" "0"] [ + mkqelem groupNode [] [ + mkqelem fill [clrAttr color, sattr "transparent" "false"] [], + mkqelem state [sattr "closed" "false", + sattr "closedHeight" "50.0", + sattr "closedWidth" "50.0", + sattr "innerGraphDisplayEnabled" "false"] [], + mkqelem shape [sattr "type" "rectangle"] [], + lbl + ], + mkqelem groupNode [] [ + mkqelem fill [clrAttr color, sattr "transparent" "false"] [], + mkqelem state [sattr "closed" "true", + sattr "closedHeight" "50.0", + sattr "closedWidth" "50.0", + sattr "innerGraphDisplayEnabled" "false"] [], + lbl + ] + ] + ] + ] + +getLabel attrs = + case [lbl | Label lbl <- attrs] of + [] -> "" + (StrLabel l:_) -> renderEscapes $ T.unpack l + (l:_) -> show l + +renderEscapes :: String -> String +renderEscapes str = go str + where + go [] = [] + go [c] = [c] + go ('\\':'n':cs) = '\n': go cs + go ('\\':'l':cs) = '\n': go cs + go ('\\':'r':cs) = '\n': go cs + go (c:cs) = c: go cs + +getColor attrs = + case concat [clr | Color clr <- attrs] of + [] -> Nothing + (RGB r g b:_) -> Just $ printf "#%02x%02x%02x" r g b + _ -> Nothing + +main :: IO () +main = do + argv <- getArgs + (mbInp,mbOutp) <- case argv of + [] -> return (Nothing, Nothing) + [p] -> return (Just p, Nothing) + [p,q] -> return (Just p, Just q) + _ -> do + printf "Synopsis: dot2graphml [INPUT.dot] [OUTPUT.graphml]" + fail "Invalid command line." + graph <- parseDot mbInp + runX $ root [] [graphXml graph >>> uniqueNamespacesFromDeclAndQNames] >>> propagateNamespaces >>> writeDocument [withCheckNamespaces yes, withIndent yes] (fromMaybe "-" mbOutp) + return () +