flow2dot 0.4 → 0.5
raw patch · 3 files changed
+296/−306 lines, 3 files
Files
- Text/FlowDiagram.hs +288/−0
- flow2dot.cabal +8/−7
- flow2dot.hs +0/−299
+ Text/FlowDiagram.hs view
@@ -0,0 +1,288 @@+{-|+Converts flow diagrams to the Graphviz (Dot) files for subsequent rendering+into nice pictures.+-}+module Text.FlowDiagram ( flow2dot+ , parseFlow+ , parseFlowFromFile+ , showFlow+ , Flow(..)+ ) where++import qualified Text.Dot as D+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 (readFile)+import System.IO.UTF8 (readFile)+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++Diagram could look like this:+strict digraph SeqDiagram+{+ { // Those are swimline heads+ rank=same+ actor [label="Some actor"];+ system [label="Some system"];+ }+ { //tier1+ rank=same+ node[style=invis,shape=point];+ tier1; // this is an "anchor" for 1st diagram tier+ actor1; // this is a 1st point on "actor" swimline+ system1; // this is a 1st point on "system" swimline+ }+ { //tier2+ rank=same+ node[style=invis,shape=point];+ tier2; // anchor for 2nd diagram tier+ actor2; // this is a 2nd point on "actor" swimline+ system2; // this is a 2nd point on "system" swimline+ }+ // Main body++ // Tiers ordering. We link "anchor" nodes and Dot will do the rest+ tier1 -> tier2;++ // Actual messages. Note the "constraint=false"+ actor1 -> system1[label="xxx", constraint=false];+ system2 -> actor2[label="yyy", constraint=false];+}+-}++-- | Flow could include messages and actions, one item per source line+data Flow = Msg String String String+ -- ^ Message (from, to, message text). Syntax in the source file: @from -> to: message text@+ | Action String String+ -- ^ Action (actor, message text). Syntax in the source file: @actor: message text@+ deriving (Eq,Show)++-- | State of the diagram builder+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+ , headings :: [D.NodeId]+ -- ^ IDs of all "swimline start" nodes+ }++type Diagram = StateT DiagS D.Dot++-- | 'flow2dot' take a list of flow diagram items (`Flow') and converts them to Graphviz code+flow2dot :: [Flow] -> String+flow2dot 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 ()+flow2dot' flow = do+ mapM_ flowElement2dot flow+ hs <- gets headings+ same hs++flowElement2dot :: Flow -> Diagram ()+-- 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+ tier <- invisNode+ l <- mkLabel message+ a <- node [("style","filled"),("shape","plaintext"),("label",l)]+ same [tier,a]+ connectToPrev actor a+ connectToPrev "___tier" tier+ incTier++flowElement2dot (Msg from to message) = do+ tier <- invisNode+ f <- invisNode+ t <- invisNode+ same [f,t,tier]++ l <- mkLabel message++ 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 numTier+ return $ show t ++ ": " ++ reflow lbl++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 [chr 10] $ map unwords $ splitInto words_in_row w+ where w = words str+ z = length w+ rows = z*height `div` (height+width)+ words_in_row = rows*width `div` height+ chunk _ [] = Nothing+ chunk 0 lst = Just (lst, [])+ chunk n lst = Just $ splitAt n lst+ splitInto n = unfoldr (chunk n)+ width=3+ height=1++-- Return the ID of the next node in the swimline `name',+-- generating all required nodes and swimline connections along the way+connectToPrev :: String -> D.NodeId -> Diagram ()+connectToPrev "___tier" _ = return ()+connectToPrev sline currNode = do+ s <- getSwimline sline+ case s of+ -- Swimline already exists+ (Just prevNode) -> do edge prevNode currNode [("style","dotted"),("arrowhead","none")]+ setSwimline sline currNode+ -- Otherwise, swimline hase to be created+ (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+ where+ remove_underscore '_' = ' '+ remove_underscore x = x++------------------------------+-- State access/modify helpers+------------------------------++incTier :: Diagram ()+incTier = modify (\e -> e {numTier = numTier e +1} )++getSwimline :: String -> Diagram (Maybe D.NodeId)+getSwimline name = do+ s <- gets swimlines+ return $ M.lookup name s++setSwimline :: String -> D.NodeId -> Diagram ()+setSwimline name x = do+ modify (\e -> e {swimlines = M.insert name x (swimlines e)})++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++---------+-- Parser+---------+-- | Parse specified file and return Flow Diagram contained therein.+-- All syntax errors are thrown via 'error'+parseFlowFromFile :: FilePath -> IO [Flow]+parseFlowFromFile fname = do+ raw <- readFile fname+ return $ parseFlow fname raw++-- | Parse given string and return Flow Diagram contained therein.+-- All syntax errors are thrown via 'error'+parseFlow :: String -> String -> [Flow]+parseFlow _ "" = []+parseFlow fname str =+ case parse document fname str of+ Left err -> error $ unlines [ "Input:", str, "Error:", show err]+ Right flow -> flow++document :: GenParser Char st [Flow]+document = do+ whitespace+ fl <- many flowLine+ eof+ return fl++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)++identifier, whitespace, anything :: GenParser Char st String+identifier = do whitespace; i <- many (alphaNum <|> oneOf "_"); whitespace+ return i+whitespace = many $ oneOf " \t"+anything = try (anyChar `manyTill` newline) <|> many1 anyChar++trim :: String -> String+trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- Parser tests+newtype Name = Name String+newtype Message = Message String++instance Arbitrary Name where+ arbitrary = liftM Name (listOf' $ elements "abcxyz_банк")+ coarbitrary = undefined++instance Arbitrary Message where+ -- words.unwords trick is needed to prevent Messages which contain only spaces+ arbitrary = liftM ((Message).unwords.words) $ frequency [ (50, listOf' $ elements "abcxyz_->; 123банк")+ -- One special case which i decided to hard-code+ , (1, return "foo -> bar")+ ]+ coarbitrary = undefined++instance Arbitrary Flow where+ arbitrary = frequency [ (10, liftM3 Msg mkName mkName mkMsg)+ , (5, liftM2 Action mkName mkMsg)+ ]+ where+ mkName = do Name n <- arbitrary; return n+ mkMsg = do Message m <- arbitrary; return m+ coarbitrary = undefined++-- Taken from a unreleased version of quickcheck+-- Just added ' to the names+-- / Kolmodin+listOf' :: Gen a -> Gen [a]+listOf' gen = sized $ \n ->+ do k <- choose (1,n)+ vectorOf' k gen++vectorOf' :: Int -> Gen a -> Gen [a]+vectorOf' k gen = sequence [ gen | _ <- [1..k] ]+++-- | Print element of the flow diagram as String+showFlow :: Flow -> String+showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ]+showFlow (Action s a) = unwords [ s, ":", a ]++prop_reparse :: [Flow] -> Bool+prop_reparse x =+ let txt = unlines $ map showFlow x+ in x == parseFlow "" txt++prop_russian_k :: Bool+prop_russian_k =+ ( parseFlow "a->b" "A->B: клиент" == [Msg "A" "B" "клиент"] ) &&+ ( parseFlow "prod" "продавец -> клиент: подписание контракта, предоставление счета" == [Msg "продавец" "клиент" "подписание контракта, предоставление счета"] )
flow2dot.cabal view
@@ -1,22 +1,23 @@ Name: flow2dot-Version: 0.4+Version: 0.5 License: BSD3 License-File: LICENSE Author: Dmitry Astapov <dastapov@gmail.com> Maintainer: Dmitry Astapov <dastapov@gmail.com>-Synopsis: Generates sequence diagrams from textual descriptions+Synopsis: Library and binary to generate sequence/flow diagrams from plain text source Description: Generates sequence diagrams from textual descriptions with help of Graphviz graph drawing tool. Check out <http://adept.linux.kiev.ua:8080/repos/flow2dot/sample.flow> (source) and <http://adept.linux.kiev.ua:8080/repos/flow2dot/sample.png> (output). Homepage: http://adept.linux.kiev.ua:8080/repos/flow2dot Category: Tool Stability: beta+Cabal-Version: >= 1.2 -Tested-With: GHC ==6.8.2, GHC ==6.10.1-Build-Depends: base, mtl >= 1.0, containers, haskell98, QuickCheck, parsec, utf8-string, dotgen >= 0.2+Tested-With: GHC >=6.8.2 Build-Type: Simple Extra-Source-Files: README -Executable: flow2dot-Main-Is: flow2dot.hs-GHC-Options: -Wall+Library+ Exposed-Modules: Text.FlowDiagram+ Build-Depends: base, mtl >= 1.0, containers, haskell98, QuickCheck, parsec, utf8-string, dotgen >= 0.2+
− flow2dot.hs
@@ -1,299 +0,0 @@--------------------------------------------------------------------------------- |--- Name : Flow2Dot--- Copyright : (c) Dmitry Astapov, 2007-2009--- License : BSD-style (see the file LICENSE)------ Maintainer : Dmitry Astapov <dastapov@gmail.com>--- Stability : beta--- Portability : portable----------------------------------------------------------------------------------module Main where--import qualified Text.Dot as D-import System (getArgs)-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.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--Diagram could look like this:-strict digraph SeqDiagram-{- { // Those are swimline heads- rank=same- actor [label="Some actor"];- system [label="Some system"];- }- { //tier1- rank=same- node[style=invis,shape=point];- tier1; // this is an "anchor" for 1st diagram tier- actor1; // this is a 1st point on "actor" swimline- system1; // this is a 1st point on "system" swimline- }- { //tier2- rank=same- node[style=invis,shape=point];- tier2; // anchor for 2nd diagram tier- actor2; // this is a 2nd point on "actor" swimline- system2; // this is a 2nd point on "system" swimline- }- // Main body-- // Tiers ordering. We link "anchor" nodes and Dot will do the rest- tier1 -> tier2;-- // Actual messages. Note the "constraint=false"- actor1 -> system1[label="xxx", constraint=false];- system2 -> actor2[label="yyy", constraint=false];-}--}---- | Flow consists of:--- 1)Messages: from ---(message)---> to--- 2)Actions: "system" performs "action"-data Flow = Msg String String String- | Action String String- deriving (Eq,Show)--main :: IO ()-main = do- args <- getArgs- case args of- [fname] -> process fname- _ -> do print "Usage: flow2dot file.flow > file.dot"----- | Process a .flow file and output generated .dot diagram-process :: FilePath -> IO ()-process fname = do- flow <- parseFlowFromFile fname- putStrLn $ processFlow flow---- | State of the diagram builder-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- , headings :: [D.NodeId]- -- ^ IDs of all "swimline start" nodes- }--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 ()-flow2dot flow = do- mapM_ flowElement2dot flow- hs <- gets headings- same hs--flowElement2dot :: Flow -> Diagram ()--- 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- tier <- invisNode- l <- mkLabel message- a <- node [("style","filled"),("shape","plaintext"),("label",l)]- same [tier,a]- connectToPrev actor a- connectToPrev "___tier" tier- incTier--flowElement2dot (Msg from to message) = do- tier <- invisNode- f <- invisNode- t <- invisNode- same [f,t,tier]-- l <- mkLabel message-- 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 numTier- return $ show t ++ ": " ++ reflow lbl--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 [chr 10] $ map unwords $ splitInto words_in_row w- where w = words str- z = length w- rows = z*height `div` (height+width)- words_in_row = rows*width `div` height- chunk _ [] = Nothing- chunk 0 lst = Just (lst, [])- chunk n lst = Just $ splitAt n lst- splitInto n = unfoldr (chunk n)- width=3- height=1---- Return the ID of the next node in the swimline `name',--- generating all required nodes and swimline connections along the way-connectToPrev :: String -> D.NodeId -> Diagram ()-connectToPrev "___tier" _ = return ()-connectToPrev sline currNode = do- s <- getSwimline sline- case s of- -- Swimline already exists- (Just prevNode) -> do edge prevNode currNode [("style","dotted"),("arrowhead","none")]- setSwimline sline currNode- -- Otherwise, swimline hase to be created- (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- where- remove_underscore '_' = ' '- remove_underscore x = x----------------------------------- State access/modify helpers---------------------------------incTier :: Diagram ()-incTier = modify (\e -> e {numTier = numTier e +1} )--getSwimline :: String -> Diagram (Maybe D.NodeId)-getSwimline name = do- s <- gets swimlines- return $ M.lookup name s--setSwimline :: String -> D.NodeId -> Diagram ()-setSwimline name x = do- modify (\e -> e {swimlines = M.insert name x (swimlines e)})--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-------------- Parser-----------parseFlowFromFile :: FilePath -> IO [Flow]-parseFlowFromFile fname = do- raw <- readFile fname- return $ parseFlow fname raw--parseFlow :: String -> String -> [Flow]-parseFlow _ "" = []-parseFlow fname str =- case parse document fname str of- Left err -> error $ unlines [ "Input:", str, "Error:", show err]- Right flow -> flow--document :: GenParser Char st [Flow]-document = do- whitespace- fl <- many flowLine- eof- return fl--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)--identifier, whitespace, anything :: GenParser Char st String-identifier = do whitespace; i <- many (alphaNum <|> oneOf "_"); whitespace- return i-whitespace = many $ oneOf " \t"-anything = try (anyChar `manyTill` newline) <|> many1 anyChar--trim :: String -> String-trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace---- Parser tests-newtype Name = Name String-newtype Message = Message String--instance Arbitrary Name where- arbitrary = liftM Name (listOf' $ elements "abcxyz_банк")- coarbitrary = undefined--instance Arbitrary Message where- -- words.unwords trick is needed to prevent Messages which contain only spaces- arbitrary = liftM ((Message).unwords.words) $ frequency [ (50, listOf' $ elements "abcxyz_->; 123банк")- -- One special case which i decided to hard-code- , (1, return "foo -> bar")- ]- coarbitrary = undefined--instance Arbitrary Flow where- arbitrary = frequency [ (10, liftM3 Msg mkName mkName mkMsg)- , (5, liftM2 Action mkName mkMsg)- ]- where- mkName = do Name n <- arbitrary; return n- mkMsg = do Message m <- arbitrary; return m- coarbitrary = undefined---- Taken from a unreleased version of quickcheck--- Just added ' to the names--- / Kolmodin-listOf' :: Gen a -> Gen [a]-listOf' gen = sized $ \n ->- do k <- choose (1,n)- vectorOf' k gen--vectorOf' :: Int -> Gen a -> Gen [a]-vectorOf' k gen = sequence [ gen | _ <- [1..k] ]---showFlow :: Flow -> String-showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ]-showFlow (Action s a) = unwords [ s, ":", a ]--prop_reparse :: [Flow] -> Bool-prop_reparse x =- let txt = unlines $ map showFlow x- in x == parseFlow "" txt--prop_russian_k :: Bool-prop_russian_k =- ( parseFlow "a->b" "A->B: клиент" == [Msg "A" "B" "клиент"] ) &&- ( parseFlow "prod" "продавец -> клиент: подписание контракта, предоставление счета" == [Msg "продавец" "клиент" "подписание контракта, предоставление счета"] )