diff --git a/Dot.hs b/Dot.hs deleted file mode 100644 --- a/Dot.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Name : Dot --- Copyright : (c) Dmitry Astapov, 2007 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Dmitry Astapov --- Stability : experimental --- Portability : portable --- --- Library for generatin Graphviz (www.graphviz.org) documents ------------------------------------------------------------------------------ -module Dot ( inSection - , addString - , addNode - , addEdge - , Style(..) - , Shape(..) - , Param(..) - ,UsesDotEnv(..) - ,DotEnv(..) - ) where - -import Control.Monad.State (gets, modify, State) -import qualified Data.Map as M -import Data.List (intersperse) - --- Since order of declaration matter for dot, we need to be able to generate nodes --- "in the past". FIXME: document -type Section = String -type Contents = [String] -type Dotcument = M.Map Section Contents - -data DotEnv = DotEnv { section::Section - -- ^ name of the current graph section - , dotcument :: Dotcument - -- ^ name of section => section contents - } - -class Monad m => UsesDotEnv m where - getDotcument :: m Dotcument - setDotcument :: Dotcument -> m () - getSection :: m Section - setSection :: Section -> m () - -instance UsesDotEnv (State DotEnv) where - getDotcument = gets dotcument - setDotcument d = modify (\e -> e {dotcument = d}) - getSection = gets section - setSection s = modify (\e -> e {section = s}) - --- Dot language elements -data Param = Label String | Constraint Bool | Style Style - | Shape Shape | ArrowHead String -data Style = Invis | Dotted | Filled -data Shape = Point | Plaintext - --- Generating functions -addString :: UsesDotEnv m => String -> m () -addString = emit - -addNode :: UsesDotEnv m => String -> [Param] -> m () -addNode name params = emit $ unwords [name, mkParams params, ";"] - -addEdge :: UsesDotEnv m => String -> String -> [Param] -> m () -addEdge from_node to_node params = - emit $ unwords $ - [ from_node - , "->" - , to_node - , mkParams params - , ";" - ] - --- Graph generation helpers -mkParams :: [Param] -> String -mkParams [] = "" -mkParams p = "[" ++ concat (intersperse "," (map show p)) ++ "]" - -emit :: UsesDotEnv m => String -> m () -emit s = do - sec <- getSection - d <- getDotcument - setDotcument $ M.insertWith (++) sec [s] d - -inSection :: UsesDotEnv m => String -> m a -> m () -inSection name f = do - sec <- getSection - setSection name - f - setSection sec - --- Prettyprinters -instance Show Param where - show (Label l) = "label=\""++quote l++"\"" - where - quote "" = "" - quote s = concatMap quote' s - quote' '"' = "\\\"" - quote' x = [x] - show (Style s) = "style="++show s - show (Constraint x) = "constraint=" ++ showB x - where - showB False = "false" - showB True = "true" - show (Shape x) = "shape=" ++ show x - show (ArrowHead x) = "arrowhead="++x - -instance Show Style where - show Invis = "invis" - show Dotted = "dotted" - show Filled = "filled" - -instance Show Shape where - show Point = "point" - show Plaintext = "plaintext" diff --git a/flow2dot.cabal b/flow2dot.cabal --- a/flow2dot.cabal +++ b/flow2dot.cabal @@ -1,5 +1,5 @@ Name: flow2dot -Version: 0.3.1 +Version: 0.4 License: BSD3 License-File: LICENSE Author: Dmitry Astapov @@ -10,15 +10,13 @@ and (output). Homepage: http://adept.linux.kiev.ua:8080/repos/flow2dot Category: Tool -Stability: Works-for-me, passes tests, generates diagrams +Stability: beta Tested-With: GHC ==6.8.2, GHC ==6.10.1 -Build-Depends: base, mtl >= 1.0, containers, haskell98, QuickCheck, parsec, utf8-string +Build-Depends: base, mtl >= 1.0, containers, haskell98, QuickCheck, parsec, utf8-string, dotgen >= 0.2 Build-Type: Simple Extra-Source-Files: README Executable: flow2dot Main-Is: flow2dot.hs -Other-Modules: Dot GHC-Options: -Wall -Extensions: FlexibleInstances diff --git a/flow2dot.hs b/flow2dot.hs --- a/flow2dot.hs +++ b/flow2dot.hs @@ -1,35 +1,32 @@ -{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Name : Flow2Dot --- Copyright : (c) Dmitry Astapov, 2007 +-- Copyright : (c) Dmitry Astapov, 2007-2009 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Dmitry Astapov --- Stability : experimental +-- Stability : beta -- Portability : portable -- ----------------------------------------------------------------------------- module Main where -import Dot - +import qualified Text.Dot as D import System (getArgs) -import Control.Monad.State (State,evalState,gets,modify) -import qualified Data.Map as M -import Data.List (intersperse,unfoldr,splitAt) +import Control.Monad.State (StateT, evalStateT, gets, modify, lift) +import qualified Data.Map as M (Map, empty, lookup, insert) +import Data.List (intersperse, unfoldr, splitAt) import Prelude hiding (putStrLn, readFile) import System.IO.UTF8 (putStrLn, readFile) -import Data.Maybe (fromJust) import Data.Char (isSpace) import Test.QuickCheck import Control.Monad (liftM, liftM2, liftM3) import Text.ParserCombinators.Parsec hiding (State) +import Data.Char (chr) {- Idea: In order to draw sequence (flow) diagram using graphviz we can use directed layout (dot) to -generate "skeleton" of the diagram and draw message lines and action boxes over it in "constraint=false" mode, -so that they would not disturb the "skeleton". +generate "skeleton" of the diagram and draw message lines and action boxes Diagram could look like this: strict digraph SeqDiagram @@ -67,10 +64,8 @@ -- | Flow consists of: -- 1)Messages: from ---(message)---> to -- 2)Actions: "system" performs "action" --- 3)Preformatted strings which are passed to output as-is data Flow = Msg String String String | Action String String - | Pre String deriving (Eq,Show) main :: IO () @@ -87,79 +82,69 @@ flow <- parseFlowFromFile fname putStrLn $ processFlow flow --- FIXME: remove "zzzz_BODY" and rework section generation to emit body last -processFlow :: [Flow] -> String -processFlow flow = evalState (flow2dot flow) (DiagS M.empty 1 (DotEnv "zzzz_BODY" M.empty)) - -- | State of the diagram builder -data DiagS = DiagS { swimlines::M.Map String Int - -- ^ name, number of nodes - , tier :: Int +data DiagS = DiagS { swimlines::M.Map String D.NodeId + -- ^ name of the swimline, ID of the last node on it + , numTier :: Int -- ^ number of the next diagram tier - , dotEnv :: DotEnv + , headings :: [D.NodeId] + -- ^ IDs of all "swimline start" nodes } -type Diagram = State DiagS - -instance UsesDotEnv (State DiagS) where - getDotcument = gets (dotcument . dotEnv) - setDotcument d = modify (\e -> let de = dotEnv e in e {dotEnv = de {dotcument = d}}) - getSection = gets (section . dotEnv) - setSection s = modify (\e -> let de = dotEnv e in e {dotEnv = de {section = s}}) +type Diagram = StateT DiagS D.Dot +processFlow :: [Flow] -> String +processFlow flow = + ("strict "++) $ D.showDot $ evalStateT (flow2dot flow) (DiagS M.empty 1 []) + -- NB: "strict" is VERY important here + -- Without it, "dot" segfaults while rendering diagram (dot 2.12) -flow2dot :: [Flow] -> Diagram String +flow2dot :: [Flow] -> Diagram () flow2dot flow = do - inSection "HEADING" $ addString "rank=same" mapM_ flowElement2dot flow - d <- getDotcument - return $ header ++ (concatMap genSection $ M.toList d) ++ footer - where - -- NB: "strict" is VERY important here - -- Without it, "dot" segfaults while rendering diagram (dot 2.12) - header = "strict digraph Seq {\n" - footer = "}\n" - genSection ("zzzz_BODY",contents) = unlines (reverse contents) - genSection (name,contents) = "{ //" ++ name ++ "\n" ++ unlines (reverse contents) ++ "}\n" + hs <- gets headings + same hs flowElement2dot :: Flow -> Diagram () --- Pass preformatted lines to output as-is -flowElement2dot (Pre l) = addString l -- Make a graph block where swimline nodes for the current tier will be put. -- Populate tier with "tier anchor" node -- Generate nodes for message/action on all required swimlines -- Connect generated nodes, if necessary -- Connect tier to previous, which will ensure that tiers are ordered properly flowElement2dot (Action actor message) = do - tir <- getTierName - inSection tir $ do addString "rank=same;" - addNode tir [Style Invis, Shape Point] + tier <- invisNode l <- mkLabel message - genNextNode tir actor [Style Filled, Shape Plaintext, Label l] - toNextTier + a <- node [("style","filled"),("shape","plaintext"),("label",l)] + same [tier,a] + connectToPrev actor a + connectToPrev "___tier" tier + incTier flowElement2dot (Msg from to message) = do - tir <- getTierName - inSection tir $ do addString "rank=same;" - addNode tir [Style Invis, Shape Point] - f <- genNextNode tir from [Style Invis, Shape Point] - t <- genNextNode tir to [Style Invis, Shape Point] + tier <- invisNode + f <- invisNode + t <- invisNode + same [f,t,tier] + l <- mkLabel message - addEdge f t [ Label l - , Constraint False - ] - toNextTier + connectToPrev from f + connectToPrev to t + connectToPrev "___tier" tier + edge f t [("label",l) {-,("constraint","false")-} ] -- This is not needed with recent graphviz + incTier + mkLabel :: String -> Diagram String mkLabel lbl = do - t <- gets tier + t <- gets numTier return $ show t ++ ": " ++ reflow lbl - where +invisNode :: Diagram D.NodeId +invisNode = node [("style","invis"),("shape","point")] reflow :: String -> String -- FIXME: for now, you have to hardcode desired width/height ratio -reflow str = concat $ intersperse "\\n" $ map unwords $ splitInto words_in_row w +reflow str = concat $ intersperse [chr 10] $ map unwords $ splitInto words_in_row w where w = words str z = length w rows = z*height `div` (height+width) @@ -171,41 +156,25 @@ width=3 height=1 -toNextTier :: Diagram () -toNextTier = do - tir <- getTierName - prev <- getPrevTierName - case prev of - Nothing -> return () - Just p -> addEdge p tir [ Style Invis ] - incTier - -- Return the ID of the next node in the swimline `name', - -- generating all required nodes and swimline connections along the way -genNextNode :: String -> String -> [Param] -> Diagram String -genNextNode sec sline nodeparams = do +connectToPrev :: String -> D.NodeId -> Diagram () +connectToPrev "___tier" _ = return () +connectToPrev sline currNode = do s <- getSwimline sline case s of -- Swimline already exists - (Just _) -> do prev <- getSwimlineNodeName sline - incSwimline sline - next <- getSwimlineNodeName sline - -- Add new swimline node - inSection sec $ addNode next nodeparams - -- Connect it to the rest of swimline - addEdge prev next [Style Dotted, ArrowHead "none"] - return next + (Just prevNode) -> do edge prevNode currNode [("style","dotted"),("arrowhead","none")] + setSwimline sline currNode -- Otherwise, swimline hase to be created - (Nothing) -> do setSwimline sline 1 - -- Add heading - inSection "HEADING" $ addNode sline [Label (mkHeader sline)] - -- Add first node - first <- getSwimlineNodeName sline - inSection sec $ addNode first nodeparams - -- Connect it to the start of swimline - addEdge sline first [Style Dotted, ArrowHead "none"] - return first + (Nothing) -> do setSwimline sline currNode + -- Add heading node + -- TODO: inSection "HEADING" $ addNode sline [Label (mkHeader sline)] + heading <- node [("label", mkHeader sline)] + addHeading heading + setSwimline sline heading + -- Retry connecting + connectToPrev sline currNode mkHeader :: String -> String mkHeader = map remove_underscore @@ -213,45 +182,37 @@ remove_underscore '_' = ' ' remove_underscore x = x +------------------------------ -- State access/modify helpers -setTier :: Int -> Diagram () -setTier x = modify (\f -> f {tier=x}) - -getTierName :: Diagram String -getTierName = do - t <- gets tier - return $ "tier" ++ show t - -getPrevTierName :: Diagram (Maybe String) -getPrevTierName = do - t <- gets tier - if (t>1) then return $ Just $ "tier" ++ show (t-1) - else return Nothing +------------------------------ incTier :: Diagram () -incTier = modify (\e -> e {tier = tier e +1} ) +incTier = modify (\e -> e {numTier = numTier e +1} ) -getSwimline :: String -> Diagram (Maybe Int) +getSwimline :: String -> Diagram (Maybe D.NodeId) getSwimline name = do s <- gets swimlines return $ M.lookup name s -getSwimlineNodeName :: String -> Diagram String -getSwimlineNodeName name = do - s <- getSwimline name - return $ name ++ show (fromJust s) - -setSwimline :: String -> Int -> Diagram () +setSwimline :: String -> D.NodeId -> Diagram () setSwimline name x = do modify (\e -> e {swimlines = M.insert name x (swimlines e)}) -incSwimline :: String -> Diagram () -incSwimline name = do - s <- getSwimline name - setSwimline name (fromJust s+1) +addHeading :: D.NodeId -> Diagram () +addHeading x = do + modify (\e -> e {headings = x:(headings e)}) +------------------------------------------------ +-- Lifting Text.Dot functions to the State monad +------------------------------------------------ +same = lift . D.same +node = lift . D.node +edge f t args = lift $ D.edge f t args -parseFlowFromFile :: FilePath -> IO [Flow]-- Parser +--------- +-- Parser +--------- +parseFlowFromFile :: FilePath -> IO [Flow] parseFlowFromFile fname = do raw <- readFile fname return $ parseFlow fname raw @@ -270,13 +231,12 @@ eof return fl -flowLine, parseMsg, parseAction, parsePre :: GenParser Char st Flow -flowLine = try parseMsg <|> try parseAction <|> parsePre +flowLine, parseMsg, parseAction :: GenParser Char st Flow +flowLine = try parseMsg <|> try parseAction parseMsg = do f <- identifier; string "->"; t <- identifier; string ":"; m <- anything return $ Msg f t (trim m) parseAction = do s <- identifier; string ":"; a <- anything return $ Action s (trim a) -parsePre = liftM Pre anything identifier, whitespace, anything :: GenParser Char st String identifier = do whitespace; i <- many (alphaNum <|> oneOf "_"); whitespace @@ -306,7 +266,6 @@ instance Arbitrary Flow where arbitrary = frequency [ (10, liftM3 Msg mkName mkName mkMsg) , (5, liftM2 Action mkName mkMsg) - , (2, liftM Pre mkMsg) ] where mkName = do Name n <- arbitrary; return n @@ -328,7 +287,6 @@ showFlow :: Flow -> String showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ] showFlow (Action s a) = unwords [ s, ":", a ] -showFlow (Pre s) = s prop_reparse :: [Flow] -> Bool prop_reparse x =