flow2dot 0.6.1 → 0.7
raw patch · 5 files changed
+144/−35 lines, 5 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Text.FlowDiagram: Order :: [String] -> Flow
Files
- ChangeLog +53/−0
- Text/Dot.hs +49/−1
- Text/FlowDiagram.hs +37/−13
- flow2dot-fix-dot-lost-edges +0/−16
- flow2dot.cabal +5/−5
+ ChangeLog view
@@ -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
Text/Dot.hs view
@@ -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 ()+
Text/FlowDiagram.hs view
@@ -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
− flow2dot-fix-dot-lost-edges
@@ -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
flow2dot.cabal view
@@ -1,5 +1,5 @@ Name: flow2dot-Version: 0.6.1+Version: 0.7 License: BSD3 License-File: LICENSE Author: Dmitry Astapov <dastapov@gmail.com>@@ -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