diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,53 @@ +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/Text/Dot.hs b/Text/Dot.hs --- a/Text/Dot.hs +++ b/Text/Dot.hs @@ -21,6 +21,7 @@ , userNode -- * Edges , edge + , edge' , (.->.) -- * Showing a graph , showDot @@ -30,8 +31,14 @@ , 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 @@ -46,6 +53,7 @@ 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] @@ -75,6 +83,10 @@ 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 [] @@ -115,6 +127,9 @@ 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}" @@ -125,4 +140,37 @@ showAttrs' [a] = showAttr a showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as -showAttr (name,val) = name ++ "=\"" ++ val ++ "\"" +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 @@ -12,14 +12,13 @@ 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 Data.List (intercalate, unfoldr, splitAt, findIndex) 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 @@ -62,7 +61,9 @@ 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@ + -- ^ Action (actor, message text). Syntax in the source file: @actor: message text@ + | Order [String] + -- ^ Tries to put swimlines in the specified order. Syntax: @order swimline1 swimline2 ...@ deriving (Eq,Show) -- | State of the diagram builder @@ -85,17 +86,21 @@ flow2dot' :: [Flow] -> Diagram () flow2dot' flow = do - mapM_ flowElement2dot flow + 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 -flowElement2dot :: Flow -> Diagram () +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 -- 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 +flowElement2dot _ (Action actor message) = do tier <- invisNode l <- mkLabel message a <- node [("style","filled"),("shape","plaintext"),("label",l)] @@ -104,7 +109,7 @@ connectToPrev "___tier" tier incTier -flowElement2dot (Msg from to message) = do +flowElement2dot order (Msg from to message) = do tier <- invisNode f <- invisNode t <- invisNode @@ -115,9 +120,22 @@ connectToPrev from f connectToPrev to t connectToPrev "___tier" tier - edge f t [("label",l) ,("constraint","false") ] + let (f',t',attrs) = + if order == Nothing + then (f,t,[]) + else let (Just sls) = order + in case (findIndex (==from) sls, findIndex (==to) sls) of + (Just x, Just y) -> if x>y then (t,f,[("dir","back")]) else (f,t,[]) + _ -> (f,t,[]) + + edge f' t' $ [("label",l)] ++ attrs incTier + +-- Order setting is done in Msg processing +flowElement2dot _ (Order _) = return () + + mkLabel :: String -> Diagram String mkLabel lbl = do t <- gets numTier @@ -129,7 +147,7 @@ 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 = tail $ init $ show $ concat $ intersperse [chr 10] $ map unwords $ splitInto words_in_row w +reflow str = intercalate "\n" $ map unwords $ splitInto words_in_row w where w = words str z = length w rows = z*height `div` (height+width) @@ -154,7 +172,6 @@ -- 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 @@ -221,14 +238,17 @@ return fl flowLine, parseMsg, parseAction :: GenParser Char st Flow -flowLine = try parseMsg <|> try parseAction +flowLine = try parseOrder <|> try parseMsg <|> try parseAction +parseOrder = do string "order" + is <- identifier `manyTill` newline + return $ Order is 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 +identifier = do whitespace; i <- many1 (alphaNum <|> oneOf "_"); whitespace return i whitespace = many $ oneOf " \t" anything = try (anyChar `manyTill` newline) <|> many1 anyChar @@ -242,6 +262,7 @@ 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 @@ -249,6 +270,7 @@ -- 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) @@ -257,6 +279,7 @@ 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 @@ -272,7 +295,8 @@ -- | Print element of the flow diagram as String showFlow :: Flow -> String -showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ] +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 diff --git a/flow2dot-fix-dot-lost-edges b/flow2dot-fix-dot-lost-edges deleted file mode 100644 --- a/flow2dot-fix-dot-lost-edges +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/bash -# Fix generated diagram for dot 2.20.x to remove complains about "Lost edges" -input=$(mktemp) -log=$(mktemp) -cat > $input -dot "$@" < $input 2> $log -[ -s $log ] && ( - sedpgm=$(mktemp) - while read foo foo f t foo ; do - echo "/$f -> $t/s/,constraint=\"false\"//;" >> $sedpgm - done < $log - sed -f $sedpgm < $input | dot "$@" - rm $log - rm $sedpgm -) -rm $input diff --git a/flow2dot.cabal b/flow2dot.cabal --- a/flow2dot.cabal +++ b/flow2dot.cabal @@ -1,5 +1,5 @@ Name: flow2dot -Version: 0.6.1 +Version: 0.7 License: BSD3 License-File: LICENSE Author: Dmitry Astapov @@ -13,14 +13,14 @@ Stability: beta Cabal-Version: >= 1.2 -Tested-With: GHC >=6.8.2 +Tested-With: GHC >=6.10.4 Build-Type: Simple -Extra-Source-Files: README flow2dot-fix-dot-lost-edges +Extra-Source-Files: README ChangeLog Library Exposed-Modules: Text.FlowDiagram - Other-Modules: Text.Dot - Build-Depends: base, mtl >= 1.0, containers, haskell98, QuickCheck, parsec, utf8-string + Other-Modules: Text.Dot + Build-Depends: base >=3 && <4, mtl >= 1.0, containers, haskell98, QuickCheck, parsec, utf8-string Executable flow2dot Main-Is: flow2dot.hs