diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 --- a/ChangeLog +++ /dev/null @@ -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 diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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. - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -import Distribution.Simple -main = defaultMain diff --git a/Text/Dot.hs b/Text/Dot.hs deleted file mode 100644 --- a/Text/Dot.hs +++ /dev/null @@ -1,176 +0,0 @@ --- | --- Module: Text.Dot --- Copyright: Andy Gill --- License: BSD3 --- --- Maintainer: Andy Gill --- 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 () - diff --git a/Text/FlowDiagram.hs b/Text/FlowDiagram.hs --- a/Text/FlowDiagram.hs +++ b/Text/FlowDiagram.hs @@ -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 "продавец" "клиент" "подписание контракта, предоставление счета"] ) diff --git a/flow2dot.cabal b/flow2dot.cabal --- a/flow2dot.cabal +++ b/flow2dot.cabal @@ -1,42 +1,79 @@ -Name: flow2dot -Version: 0.9.0.3 -License: BSD3 -License-File: LICENSE -Author: Dmitry Astapov -Maintainer: Dmitry Astapov -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 (source) - and (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 +maintainer: Dmitry Astapov +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 diff --git a/flow2dot.hs b/flow2dot.hs --- a/flow2dot.hs +++ b/flow2dot.hs @@ -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 () diff --git a/sample.flow b/sample.flow --- a/sample.flow +++ b/sample.flow @@ -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 diff --git a/sample.png b/sample.png new file mode 100644 Binary files /dev/null and b/sample.png differ diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -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