flow2dot 0.3.1 → 0.4
raw patch · 3 files changed
+79/−240 lines, 3 filesdep +dotgen
Dependencies added: dotgen
Files
- Dot.hs +0/−117
- flow2dot.cabal +3/−5
- flow2dot.hs +76/−118
− Dot.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--------------------------------------------------------------------------------- |--- Name : Dot--- Copyright : (c) Dmitry Astapov, 2007--- License : BSD-style (see the file LICENSE)------ Maintainer : Dmitry Astapov <dastapov@gmail.com>--- 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"
flow2dot.cabal view
@@ -1,5 +1,5 @@ Name: flow2dot-Version: 0.3.1+Version: 0.4 License: BSD3 License-File: LICENSE Author: Dmitry Astapov <dastapov@gmail.com>@@ -10,15 +10,13 @@ and <http://adept.linux.kiev.ua:8080/repos/flow2dot/sample.png> (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
flow2dot.hs view
@@ -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 <dastapov@gmail.com>--- 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 =