flow2dot 0.9.0.3 → 0.9.1

raw patch · 13 files changed

+378/−506 lines, 13 filesdep +dotgendep +flow2dotdep −haskell98dep −utf8-stringsetup-changedbinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dotgen, flow2dot

Dependencies removed: haskell98, utf8-string

API changes (from Hackage documentation)

Files

• ChangeLog +0/−53
• ChangeLog.md +61/−0
• LICENSE +25/−23
• README +0/−41
• README.md +41/−0
• Setup.hs +0/−3
• Text/Dot.hs +0/−176
• Text/FlowDiagram.hs +118/−162
• flow2dot.cabal +75/−38
• flow2dot.hs +0/−4
• sample.flow +6/−6
• sample.png binary
• test/test.hs +52/−0

@@ -1,53 +0,0 @@-tagged 0.7--  * Added Order directive (see sample.flow for usage)-  * Fix: identifier could not be empty-  * Removing useles import-  * Preserve UTF8 chars in "reflow"-  * Fix to preserve UTF8 chars in "showDot" (again)-  * Imported Dot.hs from dotgen 0.4.1-  * Fixed "lost edge" errors from graphviz--tagged 0.6.1--  * Forgot to add Text.Dot local override to cabal. Thnx to dons for spotting it--tagged 0.6--  * Fixed repo URL in README-  * Made sources compilable with QuickCheck2-  * Dotgen kills UTF-8 in graph attributes. Incorporated patched version of dotgen-0.2 into flow2dot until it will be fixed upstream-  * Added quickCheck.hs and rebuild.sh--tagged 0.5.1--  * Moved all flow diagram processing to separate module (exposed from this package)--tagged 0.4-  * Documentation fixes-  * Switched to `dotgen` package for all graphviz generation needs.-	    Dropped support of preformatted strings in flow files.--tagged 0.3.1-  * Fixed links to repo and docs--tagged 0.3-  * Ditched Text.UTF8 in favor of utf8-string library-  * Quotes inside messages are now properly escaped for Dot. Sample updated accordingly.--tagged 0.2.1-  * Version bump to 0.2.1 - ready for GHC 6.8.2-  * -Wall-  * +LANGUAGE pragmas--tagged 0.2-  * Some minor clarifications in docs-  * Dropped regex-based parser in favor of parsec-based due to issues with Unicode-  * Added QuickCheck to cabal, added LICENSE to Dot.hs-  * Added QuickCheck for Flow parser/pretty-printer-  * Moved graph generation into separate module-  * Added UTF8 module-  * cabalization--tagged 0.1-  * initial version

@@ -0,0 +1,61 @@+2020-06-16+==========+Migrated to github, cleaned up sources++Version bump to 0.9.1++Pre-github Changelog+====================+tagged 0.7++  * Added Order directive (see sample.flow for usage)+  * Fix: identifier could not be empty+  * Removing useles import+  * Preserve UTF8 chars in "reflow"+  * Fix to preserve UTF8 chars in "showDot" (again)+  * Imported Dot.hs from dotgen 0.4.1+  * Fixed "lost edge" errors from graphviz++tagged 0.6.1++  * Forgot to add Text.Dot local override to cabal. Thnx to dons for spotting it++tagged 0.6++  * Fixed repo URL in README+  * Made sources compilable with QuickCheck2+  * Dotgen kills UTF-8 in graph attributes. Incorporated patched version of dotgen-0.2 into flow2dot until it will be fixed upstream+  * Added quickCheck.hs and rebuild.sh++tagged 0.5.1++  * Moved all flow diagram processing to separate module (exposed from this package)++tagged 0.4+  * Documentation fixes+  * Switched to `dotgen` package for all graphviz generation needs.+	    Dropped support of preformatted strings in flow files.++tagged 0.3.1+  * Fixed links to repo and docs++tagged 0.3+  * Ditched Text.UTF8 in favor of utf8-string library+  * Quotes inside messages are now properly escaped for Dot. Sample updated accordingly.++tagged 0.2.1+  * Version bump to 0.2.1 - ready for GHC 6.8.2+  * -Wall+  * +LANGUAGE pragmas++tagged 0.2+  * Some minor clarifications in docs+  * Dropped regex-based parser in favor of parsec-based due to issues with Unicode+  * Added QuickCheck to cabal, added LICENSE to Dot.hs+  * Added QuickCheck for Flow parser/pretty-printer+  * Moved graph generation into separate module+  * Added UTF8 module+  * cabalization++tagged 0.1+  * initial version

@@ -1,27 +1,29 @@-Copyright (C) 2007 Dmitry Astapov+BSD 3-Clause License +Copyright (c) 2007-2020, Dmitry Astapov+All rights reserved.+ Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met: +modification, are permitted provided that the following conditions are met: -1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.  -2. 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.  -3. The names of the authors may not be used to endorse or promote-   products derived from this software without specific prior written-   permission. +1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer. -THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. +2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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.

@@ -1,41 +0,0 @@-This is a tool to generate nice sequence (flow) diagrams from-textual descriptions, written in Haskell.--This tool generates a diagram _description_, which could be made into-a nice picture with help of Graphviz (www.graphviz.org)--To try it out, run:-  runhaskell flow2dot.hs sample.flow | dot -T png -o sample.png-and view "sample.png" with your favorite picture viewer. If you-dont get a nice picture and get something else (for example, ugly-segfault from dot), try upgrading to latest Graphviz (2.12 or later)--If you want to use national alphabets, make sure that your .flow files-are encoded in UTF-8. If you want to tweak the output - read Dot manual-and use it for scaling, colors, pagination etc.--Latest version could be obtained via:-  darcs pull http://adept.linux.kiev.ua:8080/repos/flow2dot/--License     :  BSD-style (see the file LICENSE)-Send patches to dastapov@gmail.com (using "darcs send")--Thanks to Cale, quicksilver and roconnor from #haskell for-suggestions on how to modularize this. Thanks to Dema from-haskell@conference.jabber.ru for win32 testing. Gwern0 helped-to adapt this to GHC 6.8.2. Radoslav Dorcik sent in parser improvements.-Mike Shigorin and Denis Smirnov packaged for Alt Linux and provided feedback-on compatibility with different GHC versions. Vasyl Vaskul reported bugs.--Known issues-============--* Dot < 2.12 will most likely segfault on files generated by flow2dot--* If your version of dot complains about "Error: lost n1 n2 edge", try using-flow2dot-fix-dot-lost-edges in place of dot:--   runhaskell flow2dot your.flow | flow2dot-fix-dot-lost-edges -T png -o your.png--Trick is to remove 'constraint="false"' from all edges that dot reports as lost.-

@@ -0,0 +1,41 @@+This is a tool to generate nice sequence (flow) diagrams from+textual descriptions, written in Haskell.++This tool generates a diagram _description_, which could be made into+a nice picture with help of Graphviz (www.graphviz.org)++To try it out, run:+  runhaskell flow2dot.hs sample.flow | dot -T png -o sample.png+and view "sample.png" with your favorite picture viewer. If you+dont get a nice picture and get something else (for example, ugly+segfault from dot), try upgrading to latest Graphviz (2.12 or later)++If you want to use national alphabets, make sure that your .flow files+are encoded in UTF-8. If you want to tweak the output - read Dot manual+and use it for scaling, colors, pagination etc.++Latest version could be obtained via:+  darcs pull http://adept.linux.kiev.ua:8080/repos/flow2dot/++License     :  BSD-style (see the file LICENSE)+Send patches to dastapov@gmail.com (using "darcs send")++Thanks to Cale, quicksilver and roconnor from #haskell for+suggestions on how to modularize this. Thanks to Dema from+haskell@conference.jabber.ru for win32 testing. Gwern0 helped+to adapt this to GHC 6.8.2. Radoslav Dorcik sent in parser improvements.+Mike Shigorin and Denis Smirnov packaged for Alt Linux and provided feedback+on compatibility with different GHC versions. Vasyl Vaskul reported bugs.++Known issues+============++* Dot < 2.12 will most likely segfault on files generated by flow2dot++* If your version of dot complains about "Error: lost n1 n2 edge", try using+flow2dot-fix-dot-lost-edges in place of dot:++   runhaskell flow2dot your.flow | flow2dot-fix-dot-lost-edges -T png -o your.png++Trick is to remove 'constraint="false"' from all edges that dot reports as lost.+

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-import Distribution.Simple-main = defaultMain

@@ -1,176 +0,0 @@--- |--- Module: Text.Dot--- Copyright: Andy Gill--- License: BSD3------ Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable--- Portability: portable------ This module provides a simple interface for building .dot graph files, for input into the dot and graphviz tools. --- It includes a monadic interface for building graphs.--module Text.Dot -	( -	  -- * Dot-	  Dot		-- abstract-	  -- * Nodes-	, node-	, NodeId	-- abstract-	, userNodeId-	, userNode-	  -- * Edges-	, edge-        , edge'-	, (.->.)-	  -- * Showing a graph-	, showDot-	  -- * Other combinators-	, scope-	, attribute-	, share-	, same-	, cluster-	  -- * Simple netlist generation-	, netlistGraph-	) where--import Data.Char-import qualified Data.Map as M-import qualified Data.Set as S--data DotGraph = DotGraph [GraphElement]--data NodeId = NodeId String-	    | UserNodeId Int--instance Show NodeId where-  show (NodeId str) = str-  show (UserNodeId i) -	| i < 0     = "u_" ++ show (negate i)-	| otherwise = "u" ++ show i--data GraphElement = GraphAttribute String String-		  | GraphNode NodeId        [(String,String)]-		  | GraphEdge NodeId NodeId [(String,String)]-		  | GraphEdge' NodeId (Maybe String) NodeId (Maybe String) [(String,String)]-		  | Scope           [GraphElement]-		  | SubGraph NodeId [GraphElement]--data Dot a = Dot { unDot :: Int -> ([GraphElement],Int,a) }--instance Monad Dot where-  return a = Dot $ \ uq -> ([],uq,a)-  m >>= k  = Dot $ \ uq -> case unDot m uq of-			   (g1,uq',r) -> case unDot (k r) uq' of-					   (g2,uq2,r2) -> (g1 ++ g2,uq2,r2)---- | 'node' takes a list of attributes, generates a new node, and gives a 'NodeId'.-node      :: [(String,String)] -> Dot NodeId-node attrs = Dot $ \ uq -> let nid = NodeId $ "n" ++ show uq -			  in ( [ GraphNode nid attrs ],succ uq,nid)----- | 'userNodeId' allows a user to use their own (Int-based) node id's, without needing to remap them.-userNodeId :: Int -> NodeId-userNodeId i = UserNodeId i---- | 'userNode' takes a NodeId, and adds some attributes to that node. -userNode :: NodeId -> [(String,String)] -> Dot ()-userNode nId attrs = Dot $ \ uq -> ( [GraphNode nId attrs ],uq,())---- | 'edge' generates an edge between two 'NodeId's, with attributes.-edge      :: NodeId -> NodeId -> [(String,String)] -> Dot ()-edge  from to attrs = Dot (\ uq -> ( [ GraphEdge from to attrs ],uq,()))---- | 'edge' generates an edge between two 'NodeId's, with optional node sub-labels, and attributes.-edge'      :: NodeId -> Maybe String -> NodeId -> Maybe String -> [(String,String)] -> Dot ()-edge'  from optF to optT attrs = Dot (\ uq -> ( [ GraphEdge' from optF to optT attrs ],uq,()))---- | '.->.' generates an edge between two 'NodeId's.-(.->.) from to = edge from to []---- | 'scope' groups a subgraph together; in dot these are the subgraphs inside "{" and "}".-scope     :: Dot a -> Dot a-scope (Dot fn) = Dot (\ uq -> case fn uq of-			      ( elems,uq',a) -> ([Scope elems],uq',a))---- | 'share' is when a set of nodes share specific attributes. Usually used for layout tweaking.-share :: [(String,String)] -> [NodeId] -> Dot ()-share attrs nodeids = Dot $ \ uq -> -      ( [ Scope ( [ GraphAttribute name val | (name,val) <- attrs]-	       ++ [ GraphNode nodeid [] | nodeid <- nodeids ]-	       ) -        ], uq, ())---- | 'same' provides a combinator for a common pattern; a set of 'NodeId's with the same rank.-same :: [NodeId] -> Dot ()-same = share [("rank","same")]----- | 'cluster' builds an explicit, internally named subgraph (called cluster). -cluster :: Dot a -> Dot (NodeId,a)-cluster (Dot fn) = Dot (\ uq -> -		let cid = NodeId $ "cluster_" ++ show uq -		in case fn (succ uq) of-		    (elems,uq',a) -> ([SubGraph cid elems],uq',(cid,a)))---- | 'attribute' gives a attribute to the current scope.-attribute :: (String,String) -> Dot ()-attribute (name,val) = Dot (\ uq -> ( [  GraphAttribute name val ],uq,()))---- 'showDot' renders a dot graph as a 'String'.-showDot :: Dot a -> String-showDot (Dot dm) = case dm 0 of-		    (elems,_,_) -> "digraph G {\n" ++ unlines (map showGraphElement elems) ++ "\n}\n"--showGraphElement (GraphAttribute name val) = showAttr (name,val) ++ ";"-showGraphElement (GraphNode nid attrs)           = show nid ++ showAttrs attrs ++ ";"-showGraphElement (GraphEdge from to attrs) = show from ++ " -> " ++ show to ++  showAttrs attrs ++ ";"-showGraphElement (GraphEdge' from optF to optT attrs) = showName from optF ++ " -> " ++ showName to optT ++  showAttrs attrs ++ ";"-    where showName n Nothing = show n-          showName n (Just t) = show n ++ ":" ++ t-showGraphElement (Scope elems) = "{\n" ++ unlines (map showGraphElement elems) ++ "\n}"-showGraphElement (SubGraph nid elems) = "subgraph " ++ show nid ++ " {\n" ++ unlines (map showGraphElement elems) ++ "\n}"--showAttrs [] = ""-showAttrs xs = "[" ++ showAttrs' xs ++ "]"-    where-	-- never empty list-	showAttrs' [a]    = showAttr a-	showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as--showAttr (name,val) = name ++ "=\""   ++ foldr showsDotChar "" val ++ "\""--showsDotChar '"'  = ("\\\"" ++)-showsDotChar '\\' = ("\\\\" ++)-showsDotChar x    | ord x < 32 = showLitChar x-                  | otherwise  = ([x]++)----- | 'netlistGraph' generates a simple graph from a netlist.-netlistGraph :: (Ord a) -          => (b -> [(String,String)])   -- ^ Attributes for each node-          -> (b -> [a])                 -- ^ Out edges leaving each node-          -> [(a,b)] 			-- ^ The netlist-	  -> Dot ()-netlistGraph attrFn outFn assocs = do-    let nodes = S.fromList $ [ a | (a,_) <- assocs ]-    let outs  = S.fromList $ [ o | (_,b) <- assocs-				 , o <- outFn b -			     ]-    nodeTab <- sequence [ do nd <- node (attrFn b)-                             return (a,nd)-                        | (a,b) <- assocs ]-    otherTab <- sequence [ do nd <- node []-                              return (o,nd)-                         | o <- S.toList outs-                         , o `S.notMember` nodes-                         ]-    let fm = M.fromList (nodeTab ++ otherTab)-    sequence_ [ (fm M.! src) .->. (fm M.! dst)-              | (dst,b) <- assocs-              , src     <- outFn b-              ]-    return ()-

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Converts flow diagrams to the Graphviz (Dot) files for subsequent rendering into nice pictures.@@ -11,72 +10,47 @@                         ) 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 (intercalate, unfoldr, splitAt, findIndex)-#ifndef NATIVEUTF8-import Prelude hiding (readFile)-import System.IO.UTF8 (readFile)-#endif-import Data.Maybe (catMaybes)+import Control.Monad.State (StateT, evalStateT, gets, modify, lift, zipWithM, zipWithM_, foldM, when)+import qualified Data.Map as M (Map, empty, lookup, insert, union, fromList)+import Data.List (intercalate, unfoldr, splitAt, findIndex, nub, sort)+import System.IO (readFile)+import Data.Maybe (catMaybes, isJust, fromMaybe) import Data.Char (isSpace)-import Test.QuickCheck-import Control.Monad (liftM, liftM2, liftM3) import Text.ParserCombinators.Parsec hiding (State)  {- 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];-}--}+type Swimline = String  -- | Flow could include messages and actions, one item per source line-data Flow = Msg String String String+data Flow = Msg Swimline Swimline String           -- ^ Message (from, to, message text). Syntax in the source file: @from -> to: message text@-          | Action String String+          | Action Swimline String           -- ^ Action (actor, message text). Syntax in the source file: @actor: message text@-          | Order [String]+          | Order [Swimline]           -- ^ Tries to put swimlines in the specified order. Syntax: @order swimline1 swimline2 ...@             deriving (Eq,Show) +isOrder (Order _) = True+isOrder _         = False++isMsg (Msg _ _ _) = True+isMsg _           = False++names flow = nub $ flip concatMap flow $ \elt ->+  case elt of+    Msg from to _ -> [from,to]+    Action a _ -> [a]+    Order _ -> []+    + -- | 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+data DiagS = DiagS { nodes :: M.Map (Int,Swimline) D.NodeId+                   -- ^ all the nodes of the graph, indexed by tier and swimline name                    }  type Diagram = StateT DiagS D.Dot@@ -84,46 +58,97 @@ -- | '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 [])+  ("strict "++) $ D.showDot $ evalStateT (flow2dot' flow) (DiagS M.empty)     -- NB: "strict" is VERY important here     -- Without it, "dot" segfaults while rendering diagram (dot 2.12)  flow2dot' :: [Flow] -> Diagram () flow2dot' flow = do+  -- Avoid curved edges at all cost+  attribute ("splines","line")+     let order = case [ ns | Order ns <- flow ] of                 []     -> Nothing                 -- Only the first Order directive would be taken into account                 (ns:_) -> Just ns-  mapM_ (flowElement2dot order) flow-  hs <- gets headings-  same hs+      flow' = filter (not.isOrder) flow+      swimlines = names flow' -flowElement2dot :: Maybe [String] -> Flow -> Diagram ()--- Make a graph block where swimline nodes for the current tier will be put.--- Populate tier with "tier anchor" node+  -- check order+  case order of+    Just order' | sort order' /= sort swimlines -> do+      error "order statement must mention all swimlines"+    _ -> return ()+  +  -- Create nodes for flow elements+  flip mapM_ (zip [0..] flow') $ \(tier,elt) -> do+    namedNodes <- flowElement2dot tier order elt+    addNodes $ M.fromList $ [ ((tier,swimline),node) | (swimline,node)<-namedNodes ]++  -- Add nodes on all the remaining places on all the swimlines+  -- We don't add nodes on the same tier as Msg elements to avoid dot trying to route+  -- Msg edge around those invisible support nodes.+  flip mapM_ [ (tier, sline) | sline <- swimlines+                             , (tier,elt) <-zip [0..] flow'+                             , not (isMsg elt) ] $ \(tier,sline) -> do+    n <- findNode tier sline+    case n of+      Just _ -> return ()+      Nothing -> do+          id <- invisNode+          addNodes (M.fromList [((tier,sline),id)])++  -- create swimline headers+  headers <- flip mapM (fromMaybe swimlines order) $ \sline ->+    node [ ("label", mkHeader sline)+         , ("shape","box")+         ]+  same (headers)++  -- apply order, if any+  when (isJust order) $ do+    zipWithM_ (\h1 h2 -> edge h1 h2 [ ("style","invis")+                                    , ("weight","1") -- this edge is weak compared to verticals+                                    ])+      headers (drop 1 headers)+  +  -- connect all nodes on all swimlines+  -- first, lets group them by tier+  nodesByTier <- flip mapM [ tier | (tier,_) <-zip [0..] flow' ] $ \tier ->+    mapM (findNode tier) [ line | line <- swimlines ]++  -- then, we descend through the tiers connectin nodes to the previous node on+  -- the same swimline, starting from headers+  _ <- foldM (\prevNodes thisTier -> do+          same $ catMaybes thisTier+          zipWithM (\prevNode maybeThisNode ->+                      case maybeThisNode of+                        Just thisNode -> do+                          edge prevNode thisNode+                            [("style","dotted")+                            ,("arrowhead","none")+                            ,("weight","1000") -- these edges want to be+                                               -- very vertical+                            ]+                          return thisNode+                        Nothing -> return prevNode)+            prevNodes thisTier)+         headers nodesByTier+  return ()++flowElement2dot :: Int -> Maybe [String] -> Flow -> Diagram [(String,D.NodeId)] -- 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+flowElement2dot tier _ (Action actor message) = do+  l <- mkLabel tier message   a <- node [("style","filled"),("shape","plaintext"),("label",l)]-  same [tier,a]-  connectToPrev actor a-  connectToPrev "___tier" tier-  incTier+  return [(actor,a)] -flowElement2dot order (Msg from to message) = do-  tier <- invisNode+flowElement2dot tier order (Msg from to message) = do   f    <- invisNode   t    <- invisNode-  same [f,t,tier] -  l <- mkLabel message+  l <- mkLabel tier message -  connectToPrev from f-  connectToPrev to t-  connectToPrev "___tier" tier   let (f',t',attrs) =          if order == Nothing            then (f,t,[])@@ -132,26 +157,24 @@                          (Just x, Just y) -> if x>y then (t,f,[("dir","back")]) else (f,t,[])                          _                -> (f,t,[]) -  edge f' t' $ [("label",l)] ++ attrs-  incTier+  edge f' t' $ [("label",l)+               ,("constraint","false") -- avoid pushing recipient node down+               ,("labelfloat","true") -- be a bit sloppy with label placement+               ] ++ attrs+  return [(from,f),(to,t)]      -- Order setting is done in Msg processing-flowElement2dot _ (Order _) = return ()--+flowElement2dot _ _ (Order _) = return [] -mkLabel :: String -> Diagram String-mkLabel lbl = do-  t <- gets numTier-  return $ if null lbl then show t-                       else (show t ++ ": " ++ reflow lbl)+mkLabel :: Int -> String -> Diagram String+mkLabel tier lbl = do+  return $ if null lbl then ""+                       else (show (tier+1) ++ ": " ++ 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--- FIXME: (tail $ init $ show) trick is needed to work around dotgen-0.2 limitations reflow str = intercalate "\n" $ map unwords $ splitInto words_in_row w       where w = words str             z = length w@@ -161,28 +184,10 @@             chunk 0 lst = Just (lst, [])             chunk n lst = Just $ splitAt n lst             splitInto n = unfoldr (chunk n)+            -- FIXME: for now, you have to hardcode desired width/height ratio             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-                       heading <- node [("label", mkHeader sline),("shape","box")]-                       addHeading heading-                       setSwimline sline heading-                       -- Retry connecting-                       connectToPrev sline currNode- mkHeader :: String -> String mkHeader = map remove_underscore   where@@ -193,21 +198,14 @@ -- 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)})+addNodes :: M.Map (Int,String) D.NodeId -> Diagram ()+addNodes newNodes = do+  modify (\e -> e {nodes = M.union (nodes e) newNodes}) -addHeading :: D.NodeId -> Diagram ()-addHeading x = do-  modify (\e -> e {headings = x:(headings e)})+findNode :: Int -> String -> Diagram (Maybe D.NodeId)+findNode tier line = do+  ns <- gets nodes+  return $ M.lookup (tier, line) ns  ------------------------------------------------ -- Lifting Text.Dot functions to the State monad@@ -215,6 +213,7 @@ same = lift . D.same node = lift . D.node edge f t args = lift $ D.edge f t args+attribute = lift . D.attribute  --------- -- Parser@@ -268,52 +267,9 @@ 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_банк")--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")-                                                          ]--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---- 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 (Order sl)   = "order " ++ intercalate " " sl 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 "продавец" "клиент" "подписание контракта, предоставление счета"] )

@@ -1,42 +1,79 @@-Name:    flow2dot-Version: 0.9.0.3-License: BSD3-License-File: LICENSE-Author: Dmitry Astapov <dastapov@gmail.com>-Maintainer: Dmitry Astapov <dastapov@gmail.com>-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.6--Tested-With:        GHC >=6.10.4-Build-Type:         Simple-Extra-Source-Files: README ChangeLog sample.flow+cabal-version: 1.12 -Library-  hs-source-dirs: .-  Extensions: CPP-  Exposed-Modules: Text.FlowDiagram-  Other-Modules:   Text.Dot-  Build-Depends:   base >=3 && <=5, mtl >= 1.0, containers, QuickCheck, parsec, utf8-string-  if impl(ghc >= 7.0)-    cpp-options: -DNATIVEUTF8-  if impl(ghc < 7.2.1)-    Build-Depends: haskell98+-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 53fe3a5ecd77c08ff5a698606e70baced2b51cb4a2868c18fa8d092a9e48b557 -Executable  flow2dot-  hs-source-dirs: .-  Main-Is:       flow2dot.hs-  Extensions: CPP-  Other-Modules:   Text.Dot-                   Text.FlowDiagram-  if impl(ghc >= 7.0)-    cpp-options: -DNATIVEUTF8+name:           flow2dot+version:        0.9.1+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.+category:       Tool, Console+stability:      stable+homepage:       https://github.com/adept/flow2dot+bug-reports:    https://github.com/adept/flow2dot/issues+author:         Dmitry Astapov <dastapov@gmail.com>+maintainer:     Dmitry Astapov <dastapov@gmail.com>+license:        BSD3+license-file:   LICENSE+tested-with:    GHC ==6.10.4, GHC ==8.8.3+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+    sample.flow+    sample.png  source-repository head-  type:     darcs-  location: http://patch-tag.com/r/adept/flow2dot+  type: git+  location: https://github.com/adept/flow2dot++library+  exposed-modules:+      Text.FlowDiagram+  other-modules:+      Paths_flow2dot+  hs-source-dirs:+      ./.+  build-depends:+      base >=3 && <=5+    , containers+    , dotgen+    , mtl >=1.0+    , parsec+  default-language: Haskell2010++executable flow2dot+  main-is: flow2dot.hs+  other-modules:+      Text.FlowDiagram+      Paths_flow2dot+  hs-source-dirs:+      ./.+  build-depends:+      base >=3 && <=5+    , containers+    , dotgen+    , flow2dot+    , mtl >=1.0+    , parsec+  default-language: Haskell2010++test-suite flow2dot-test+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      Paths_flow2dot+  hs-source-dirs:+      test+  build-depends:+      QuickCheck+    , base >=3 && <=5+    , containers+    , dotgen+    , flow2dot+    , mtl >=1.0+    , parsec+  default-language: Haskell2010

@@ -13,10 +13,6 @@ module Main where  import Text.FlowDiagram-#ifndef NATIVEUTF8-import System.IO.UTF8 (putStrLn)-import Prelude hiding (putStrLn)-#endif import System.Environment (getArgs)  main :: IO ()

@@ -1,9 +1,9 @@ order a b c d-a -> b: let's play "catch a ball"!+a -> b: let's toss a frisbee b -> c: i'll pass it along-c: what to do next?+c: where do I throw it next? c -> a-a: "hello d!"-a -> c: d wants to play too!-c -> d: ok, here you go: catch!-d: oops..+a: "Hello d!"+a -> c: "d wants to play too!"+c -> d: "ok, catch!"+d: oops.. frisbee fell

binary file changed (absent → 28416 bytes)

@@ -0,0 +1,52 @@+import Text.FlowDiagram+import Test.QuickCheck+import Control.Monad (liftM, liftM2, liftM3)++-- Parser tests+newtype Name = Name String+newtype Message = Message String+++instance Arbitrary Name where+  arbitrary = liftM Name (listOf' $ elements "abcxyz_банк")++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")+                                                          ]++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++-- 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] ]+++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 "продавец" "клиент" "подписание контракта, предоставление счета"] )++main = do+  quickCheck prop_reparse+  quickCheck prop_russian_k