flow2dot (empty) → 0.2
raw patch · 7 files changed
+881/−0 lines, 7 filesdep +QuickCheckdep +basedep +haskell98build-type:Customsetup-changed
Dependencies added: QuickCheck, base, haskell98, mtl, parsec
Files
- Dot.hs +115/−0
- LICENSE +27/−0
- README +25/−0
- Setup.hs +3/−0
- Text/UTF8.hs +374/−0
- flow2dot.cabal +24/−0
- flow2dot.hs +313/−0
+ Dot.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Name : Dot+-- Copyright : (c) Dmitry Astapov, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Library for generatin Graphviz (www.graphviz.org) documents+-----------------------------------------------------------------------------+module Dot ( inSection+ , addString+ , addNode+ , addEdge+ , Style(..)+ , Shape(..)+ , Param(..)+ ,UsesDotEnv(..)+ ,DotEnv(..)+ ) where++import Control.Monad.State (gets, modify, State)+import qualified Data.Map as M+import Data.List (intersperse)++-- Since order of declaration matter for dot, we need to be able to generate nodes+-- "in the past". FIXME: document+type Section = String+type Contents = [String]+type Dotcument = M.Map Section Contents++data DotEnv = DotEnv { section::Section+ -- ^ name of the current graph section+ , dotcument :: Dotcument+ -- ^ name of section => section contents+ }++class Monad m => UsesDotEnv m where+ getDotcument :: m Dotcument+ setDotcument :: Dotcument -> m ()+ getSection :: m Section+ setSection :: Section -> m ()++instance UsesDotEnv (State DotEnv) where+ getDotcument = gets dotcument+ setDotcument d = modify (\e -> e {dotcument = d})+ getSection = gets section+ setSection s = modify (\e -> e {section = s})++-- Dot language elements+data Param = Label String | Constraint Bool | Style Style + | Shape Shape | ArrowHead String+data Style = Invis | Dotted | Filled+data Shape = Point | Plaintext++-- Generating functions+addString :: UsesDotEnv m => String -> m ()+addString = emit++addNodeDefaults :: UsesDotEnv m => [Param] -> m ()+addNodeDefaults params = addNode "node" params++addNode :: UsesDotEnv m => String -> [Param] -> m ()+addNode name params = emit $ unwords [name, mkParams params, ";"]++addEdge :: UsesDotEnv m => String -> String -> [Param] -> m ()+addEdge from_node to_node params =+ emit $ unwords $ + [ from_node+ , "->"+ , to_node+ , mkParams params+ , ";"+ ] ++-- Graph generation helpers+mkParams :: [Param] -> String+mkParams [] = ""+mkParams p = "[" ++ concat (intersperse "," (map show p)) ++ "]"++emit :: UsesDotEnv m => String -> m ()+emit s = do+ sec <- getSection+ d <- getDotcument+ setDotcument $ M.insertWith (++) sec [s] d++inSection :: UsesDotEnv m => String -> m a -> m ()+inSection name f = do+ sec <- getSection+ setSection name+ f+ setSection sec++-- Prettyprinters+instance Show Param where+ show (Label l) = "label=\""++l++"\""+ show (Style s) = "style="++show s+ show (Constraint x) = "constraint=" ++ showB x+ where+ showB False = "false"+ showB True = "true"+ show (Shape x) = "shape=" ++ show x+ show (ArrowHead x) = "arrowhead="++x++instance Show Style where+ show Invis = "invis"+ show Dotted = "dotted"+ show Filled = "filled"++instance Show Shape where+ show Point = "point"+ show Plaintext = "plaintext"
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (C) 2007 Dmitry Astapov++Redistribution and use in source and binary forms, with or without+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. ++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.
+ README view
@@ -0,0 +1,25 @@+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/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.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ Text/UTF8.hs view
@@ -0,0 +1,374 @@+{-++Copyright (c) 2002, members of the Haskell Internationalisation Working+Group All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+* 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.+* Neither the name of the Haskell Internationalisation Working Group 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 OWNER 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.++This module provides lazy stream encoding/decoding facilities for UTF-8,+the Unicode Transformation Format with 8-bit words.++2002-09-02 Sven Moritz Hallberg <pesco@gmx.de>++-}++{-++2007-04-30 Henning Thielemann:+Slight changes to make decode lazy.+The calls of 'reverse' in the original version have broken laziness+and thus had memory leaks.++-}++module Text.UTF8+ ( fromUTF8, toUTF8,+ encode, decode,+ decodeEmbedErrors,+ encodeOne, decodeOne,+ Error, -- Haddock does not want to document signatures with private types+ -- these functions should be moved to a utility module+ ) where++import Data.Char (ord, chr)+import Data.Word (Word8, Word16, Word32)+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))++import Data.List (unfoldr)++toUTF8 s = (map (chr. fromIntegral) $ encode s) +fromUTF8 s = decode (map (fromIntegral . ord) s)++-- - UTF-8 in General -++-- Adapted from the Unicode standard, version 3.2,+-- Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):++-- Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte+-- 000000000xxxxxxx 0xxxxxxx+-- 00000yyyyyxxxxxx 110yyyyy 10xxxxxx+-- zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx+-- 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++-- Also from the Unicode standard, version 3.2,+-- Table 3.1B "Legal UTF-8 Byte Sequences":++-- Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte+-- U+0000..U+007F 00..7F+-- U+0080..U+07FF C2..DF 80..BF+-- U+0800..U+0FFF E0 A0..BF 80..BF+-- U+1000..U+CFFF E1..EC 80..BF 80..BF+-- U+D000..U+D7FF ED 80..9F 80..BF+-- U+D800..U+DFFF ill-formed+-- U+E000..U+FFFF EE..EF 80..BF 80..BF+-- U+10000..U+3FFFF F0 90..BF 80..BF 80..BF+-- U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF+-- U+100000..U+10FFFF F4 80..8F 80..BF 80..BF++++-- - Encoding Functions -++-- Must the encoder ensure that no illegal byte sequences are output or+-- can we trust the Haskell system to supply only legal values?+-- For now I include error case for the surrogate values U+D800..U+DFFF and+-- out-of-range scalars.++-- The function is pretty much a transscript of table 3.1B with error checks.+-- It dispatches the actual encoding to functions specific to the number of+-- required bytes.++encodeOne :: Char -> [Word8]+encodeOne c+ -- The report guarantees in (6.1.2) that this won't happen:+ -- | n < 0 = error "encodeUTF8: ord returned a negative value"+ | n < 0x0080 = encodeOne_onebyte n8+ | n < 0x0800 = encodeOne_twobyte n16+ | n < 0xD800 = encodeOne_threebyte n16+ | n < 0xE000 = error "encodeUTF8: ord returned a surrogate value"+ | n < 0x10000 = encodeOne_threebyte n16+ -- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.+ | n < 0x10FFFF = encodeOne_fourbyte n32+ | otherwise = error "encodeUTF8: ord returned a value above 0x10FFFF"+ where+ n = ord c :: Int+ n8 = fromIntegral n :: Word8+ n16 = fromIntegral n :: Word16+ n32 = fromIntegral n :: Word32+++-- With the above, a stream decoder is trivial:++encode :: [Char] -> [Word8]+encode = concatMap encodeOne+++-- Now follow the individual encoders for certain numbers of bytes...+-- _+-- / | __ ___ __ __+-- / ^| // /__/ // //+-- /.==| \\ //_ // //+-- It's // || // \_/_//_//_ and it's here to stay!++encodeOne_onebyte :: Word8 -> [Word8]+encodeOne_onebyte cp = [cp]+++-- 00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx++encodeOne_twobyte :: Word16 -> [Word8]+encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]+ where+ xs, ys :: Word8+ ys = fromIntegral (shiftR cp 6)+ xs = (fromIntegral cp) .&. 0x3F+++-- zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx++encodeOne_threebyte :: Word16 -> [Word8]+encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)]+ where+ xs, ys, zs :: Word8+ xs = (fromIntegral cp) .&. 0x3F+ ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+ zs = fromIntegral (shiftR cp 12)+++-- 000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++encodeOne_fourbyte :: Word32 -> [Word8]+encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs]+ where+ xs, ys, zs, us :: Word8+ xs = (fromIntegral cp) .&. 0x3F+ ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+ zs = (fromIntegral (shiftR cp 12)) .&. 0x3F+ us = fromIntegral (shiftR cp 18)++++-- - Decoding -++-- The decoding is a bit more involved. The byte sequence could contain all+-- sorts of corruptions. The user must be able to either notice or ignore these+-- errors.++-- I will first look at the decoding of a single character. The process+-- consumes a certain number of bytes from the input. It returns the+-- remaining input and either an error and the index of its occurance in the+-- byte sequence or the decoded character.++data Error++-- The first byte in a sequence starts with either zero, two, three, or four+-- ones and one zero to indicate the length of the sequence. If it doesn't,+-- it is invalid. It is dropped and the next byte interpreted as the start+-- of a new sequence.++ = InvalidFirstByte++-- All bytes in the sequence except the first match the bit pattern 10xxxxxx.+-- If one doesn't, it is invalid. The sequence up to that point is dropped+-- and the "invalid" byte interpreted as the start of a new sequence. The error+-- includes the length of the partial sequence and the number of expected bytes.++ | InvalidLaterByte Int -- the byte at relative index n was invalid++-- If a sequence ends prematurely, it has been truncated. It dropped and+-- decoding stops. The error reports the actual and expected lengths of the+-- sequence.++ | Truncated Int Int -- only n of m expected bytes were present++-- Some sequences would represent code points which would be encoded as a+-- shorter sequence by a conformant encoder. Such non-shortest sequences are+-- considered erroneous and dropped. The error reports the actual and+-- expected number of bytes used.++ | NonShortest Int Int -- n instead of m bytes were used++-- Unicode code points are in the range of [0..0x10FFFF]. Any values outside+-- of those bounds are simply invalid.++ | ValueOutOfBounds++-- There is no such thing as "surrogate pairs" any more in UTF-8. The+-- corresponding code points now form illegal byte sequences.++ | Surrogate+ deriving (Show, Eq)+++-- Second, third, and fourth bytes share the common requirement to start+-- with the bit sequence 10. So, here's the function to check that property.++first_bits_not_10 :: Word8 -> Bool+first_bits_not_10 b+ | (b.&.0xC0) /= 0x80 = True+ | otherwise = False+++-- Erm, OK, the single-character decoding function's return type is a bit+-- longish. It is a tripel:++-- - The first component contains the decoded character or an error+-- if the byte sequence was erroneous.+-- - The second component contains the number of bytes that were consumed+-- from the input.+-- - The third component contains the remaining bytes of input.++decodeOne :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne bs@(b1:rest)+ | b1 < 0x80 = decodeOne_onebyte bs+ | b1 < 0xC0 = (Left InvalidFirstByte, 1, rest)+ | b1 < 0xE0 = decodeOne_twobyte bs+ | b1 < 0xF0 = decodeOne_threebyte bs+ | b1 < 0xF5 = decodeOne_fourbyte bs+ | otherwise = (Left ValueOutOfBounds, 1, rest)+decodeOne [] = error "UTF8.decodeOne: No input"+++-- 0xxxxxxx -> 000000000xxxxxxx++decodeOne_onebyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_onebyte (b:bs) = (Right (cpToChar b), 1, bs)+decodeOne_onebyte[] = error "UTF8.decodeOne_onebyte: No input (can't happen)"++cpToChar :: Integral a => a -> Char+cpToChar = chr . fromIntegral+++-- 110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx++decodeOne_twobyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_twobyte (_:[])+ = (Left (Truncated 1 2), 1, [])+decodeOne_twobyte (b1:b2:bs)+ | b1 < 0xC2 = (Left (NonShortest 2 1), 2, bs)+ | first_bits_not_10 b2 = (Left (InvalidLaterByte 1), 1, (b2:bs))+ | otherwise = (Right (cpToChar result), 2, bs)+ where+ xs, ys, result :: Word32+ xs = fromIntegral (b2.&.0x3F)+ ys = fromIntegral (b1.&.0x1F)+ result = shiftL ys 6 .|. xs+decodeOne_twobyte[] = error "UTF8.decodeOne_twobyte: No input (can't happen)"+++-- 1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx++decodeOne_threebyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_threebyte (_:[]) = threebyte_truncated 1+decodeOne_threebyte (_:_:[]) = threebyte_truncated 2+decodeOne_threebyte bs@(b1:b2:b3:rest)+ | first_bits_not_10 b2+ = (Left (InvalidLaterByte 1), 1, drop 1 bs)+ | first_bits_not_10 b3+ = (Left (InvalidLaterByte 2), 2, drop 2 bs)+ | result < 0x0080+ = (Left (NonShortest 3 1), 3, rest)+ | result < 0x0800+ = (Left (NonShortest 3 2), 3, rest)+ | result >= 0xD800 && result < 0xE000+ = (Left Surrogate, 3, rest)+ | otherwise+ = (Right (cpToChar result), 3, rest)+ where+ xs, ys, zs, result :: Word32+ xs = fromIntegral (b3.&.0x3F)+ ys = fromIntegral (b2.&.0x3F)+ zs = fromIntegral (b1.&.0x0F)+ result = shiftL zs 12 .|. shiftL ys 6 .|. xs+decodeOne_threebyte[]+ = error "UTF8.decodeOne_threebyte: No input (can't happen)"++threebyte_truncated :: Int -> (Either Error Char, Int, [Word8])+threebyte_truncated n = (Left (Truncated n 3), n, [])+++-- 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx++decodeOne_fourbyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_fourbyte (_:[]) = fourbyte_truncated 1+decodeOne_fourbyte (_:_:[]) = fourbyte_truncated 2+decodeOne_fourbyte (_:_:_:[]) = fourbyte_truncated 3+decodeOne_fourbyte bs@(b1:b2:b3:b4:rest)+ | first_bits_not_10 b2+ = (Left (InvalidLaterByte 1), 1, drop 1 bs)+ | first_bits_not_10 b3+ = (Left (InvalidLaterByte 2), 2, drop 2 bs)+ | first_bits_not_10 b4+ = (Left (InvalidLaterByte 3), 3, drop 3 bs)+ | result < 0x0080+ = (Left (NonShortest 4 1), 4, rest)+ | result < 0x0800+ = (Left (NonShortest 4 2), 4, rest)+ | result < 0x10000+ = (Left (NonShortest 4 3), 4, rest)+ | result > 0x10FFFF+ = (Left ValueOutOfBounds, 4, rest)+ | otherwise+ = (Right (cpToChar result), 4, rest)+ where+ xs, ys, zs, us, result :: Word32+ xs = fromIntegral (b4 .&. 0x3F)+ ys = fromIntegral (b3 .&. 0x3F)+ zs = fromIntegral (b2 .&. 0x3F)+ us = fromIntegral (b1 .&. 0x07)+ result = xs .|. shiftL ys 6 .|. shiftL zs 12 .|. shiftL us 18+decodeOne_fourbyte[]+ = error "UTF8.decodeOne_fourbyte: No input (can't happen)"++fourbyte_truncated :: Int -> (Either Error Char, Int, [Word8])+fourbyte_truncated n = (Left (Truncated n 4), n, [])+++-- The decoder examines all input, recording decoded characters as well as+-- error-index pairs along the way.++decode :: [Word8] -> ([Char], [(Error,Int)])+decode = swap . partitionEither . decodeEmbedErrors++decodeEmbedErrors :: [Word8] -> [Either (Error,Int) Char]+decodeEmbedErrors =+ unfoldr (\(pos,xs) ->+ toMaybe+ (not $ null xs)+ (let (c,n,rest) = decodeOne xs+ in (either (\err -> Left (err,pos)) Right c,+ (pos+n,rest)))) .+ (,) 0++swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)++partitionEither :: [Either a b] -> ([a], [b])+partitionEither =+ foldr (\x ~(ls,rs) -> either (\l -> (l:ls,rs)) (\r -> (ls,r:rs)) x) ([],[])++toMaybe :: Bool -> a -> Maybe a+toMaybe False _ = Nothing+toMaybe True x = Just x
+ flow2dot.cabal view
@@ -0,0 +1,24 @@+Name: flow2dot +Version: 0.2+License: BSD3+License-File: LICENSE+Author: Dmitry Astapov <dastapov@gmail.com>+Maintainer: Dmitry Astapov <dastapov@gmail.com>+Synopsis: Generates sequence diagrams from textual descriptions+Description: Generates sequence diagrams from textual descriptions with help of Graphviz graph drawing tool.+ Check out <http://adept.linux.kiev.ua/repos/flow2dot/sample.flow> (source)+ and <http://adept.linux.kiev.ua/repos/flow2dot/sample.png> (output).+Homepage: http://adept.linux.kiev.ua/repos/flow2dot+Category: Tool+Stability: Works-for-me, passes tests, generates diagrams+Tested-With: GHC ==6.6.1+Build-Depends: base, mtl >= 1.0, parsec, haskell98, QuickCheck+Extra-Source-Files: README++Executable: flow2dot+Hs-Source-Dirs: . +Main-Is: flow2dot.hs+GHC-Options: -fwarn-duplicate-exports -fwarn-incomplete-patterns+ -fwarn-overlapping-patterns -fwarn-unused-imports+ -fwarn-unused-binds+Other-Modules: Text.UTF8, Dot
+ flow2dot.hs view
@@ -0,0 +1,313 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Name : Flow2Dot+-- Copyright : (c) Dmitry Astapov, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Main where++import Dot ++import System (getArgs)+import Control.Monad.State (State,evalState,gets,modify)+import qualified Data.Map as M+import Data.List (intersperse,unfoldr,splitAt)+import Text.UTF8 (fromUTF8, toUTF8)+import Data.Maybe (fromJust)+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 over it in "constraint=false" mode,+so that they would not disturb the "skeleton".++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];+}+-}++-- | Flow consists of:+-- 1)Messages: from ---(message)---> to+-- 2)Actions: "system" performs "action"+-- 3)Preformatted strings which are passed to output as-is+data Flow = Msg String String String + | Action String String+ | Pre String+ deriving (Eq,Show)++main = do+ args <- getArgs+ case args of+ [fname] -> process fname+ _ -> do print "Usage: flow2dot file.flow > file.dot"+++-- | Process a .flow file and output generated .dot diagram+process :: FilePath -> IO ()+process fname = do+ flow <- parseFlowFromFile fname+ putStrLn $ toUTF8 $ processFlow flow++-- FIXME: remove "zzzz_BODY" and rework section generation to emit body last+processFlow flow = evalState (flow2dot flow) (DiagS M.empty 1 (DotEnv "zzzz_BODY" M.empty))++-- | State of the diagram builder+data DiagS = DiagS { swimlines::M.Map String Int+ -- ^ name, number of nodes+ , tier :: Int+ -- ^ number of the next diagram tier+ , dotEnv :: DotEnv+ }++type Diagram = State DiagS++instance UsesDotEnv (State DiagS) where+ getDotcument = gets (dotcument . dotEnv)+ setDotcument d = modify (\e -> let de = dotEnv e in e {dotEnv = de {dotcument = d}})+ getSection = gets (section . dotEnv)+ setSection s = modify (\e -> let de = dotEnv e in e {dotEnv = de {section = s}})+++flow2dot :: [Flow] -> Diagram String+flow2dot flow = do+ inSection "HEADING" $ addString "rank=same"+ mapM_ flowElement2dot flow+ d <- getDotcument+ return $ header ++ (concatMap genSection $ M.toList d) ++ footer+ where+ -- NB: "strict" is VERY important here+ -- Without it, "dot" segfaults while rendering diagram (dot 2.12)+ header = "strict digraph Seq {\n"+ footer = "}\n"+ genSection ("zzzz_BODY",contents) = unlines (reverse contents)+ genSection (name,contents) = "{ //" ++ name ++ "\n" ++ unlines (reverse contents) ++ "}\n"++flowElement2dot :: Flow -> Diagram ()+-- Pass preformatted lines to output as-is+flowElement2dot (Pre l) = addString l+-- Make a graph block where swimline nodes for the current tier will be put. +-- Populate tier with "tier anchor" node+-- Generate nodes for message/action on all required swimlines+-- Connect generated nodes, if necessary+-- Connect tier to previous, which will ensure that tiers are ordered properly+flowElement2dot (Action actor message) = do+ tier <- getTierName+ inSection tier $ do addString "rank=same;"+ addNode tier [Style Invis, Shape Point]+ l <- mkLabel message+ genNextNode tier actor [Style Filled, Shape Plaintext, Label l] + toNextTier+flowElement2dot (Msg from to message) = do+ tier <- getTierName+ inSection tier $ do addString "rank=same;"+ addNode tier [Style Invis, Shape Point]+ f <- genNextNode tier from [Style Invis, Shape Point]+ t <- genNextNode tier to [Style Invis, Shape Point]+ l <- mkLabel message+ addEdge f t [ Label l + , Constraint False+ ]+ toNextTier++mkLabel lbl = do+ t <- gets tier+ return $ show t ++ ": " ++ reflow lbl+ where++-- FIXME: for now, you have to hardcode desired width/height ratio+reflow str = concat $ intersperse "\\n" $ map unwords $ splitInto words_in_row w+ where w = words str+ z = length w+ rows = z*height `div` (height+width)+ words_in_row = rows*width `div` height+ chunk _ [] = Nothing+ chunk 0 lst = Just (lst, [])+ chunk n lst = Just $ splitAt n lst+ splitInto n = unfoldr (chunk n)+ width=3+ height=1++toNextTier = do+ tier <- getTierName+ prev <- getPrevTierName+ case prev of+ Nothing -> return ()+ Just p -> addEdge p tier [ Style Invis ]+ incTier+++-- Return the ID of the next node in the swimline `name',+-- generating all required nodes and swimline connections along the way+genNextNode sec sline nodeparams = do+ s <- getSwimline sline+ case s of+ -- Swimline already exists+ (Just _) -> do prev <- getSwimlineNodeName sline+ incSwimline sline+ next <- getSwimlineNodeName sline+ -- Add new swimline node+ inSection sec $ addNode next nodeparams+ -- Connect it to the rest of swimline+ addEdge prev next [Style Dotted, ArrowHead "none"]+ return next+ -- Otherwise, swimline hase to be created+ (Nothing) -> do setSwimline sline 1+ -- Add heading+ inSection "HEADING" $ addNode sline [Label (mkHeader sline)]+ -- Add first node+ first <- getSwimlineNodeName sline+ inSection sec $ addNode first nodeparams+ -- Connect it to the start of swimline+ addEdge sline first [Style Dotted, ArrowHead "none"]+ return first++mkHeader = map remove_underscore+ where+ remove_underscore '_' = ' '+ remove_underscore x = x++-- State access/modify helpers+setTier x = modify (\f -> f {tier=x})++getTierName = do+ t <- gets tier+ return $ "tier" ++ show t++getPrevTierName = do+ t <- gets tier+ if (t>1) then return $ Just $ "tier" ++ show (t-1)+ else return Nothing++incTier = modify (\e -> e {tier = tier e +1} )++getSwimline name = do+ s <- gets swimlines+ return $ M.lookup name s++getSwimlineNodeName name = do+ s <- getSwimline name+ return $ name ++ show (fromJust s)++setSwimline name x = do + modify (\e -> e {swimlines = M.insert name x (swimlines e)})++incSwimline name = do+ s <- getSwimline name+ setSwimline name (fromJust s+1)++-- Parser+parseFlowFromFile fname = do+ raw <- readFile fname+ return $ parseFlow fname $ fst $ fromUTF8 raw++parseFlow :: String -> String -> [Flow]+parseFlow _ "" = []+parseFlow fname str = + case parse document fname str of+ Left err -> error $ unlines [ "Input:", str, "Error:", show err]+ Right flow -> flow++document = do+ whitespace+ fl <- many flowLine+ eof+ return fl++flowLine = try parseMsg <|> try parseAction <|> parsePre+parseMsg = do f <- identifier; string "->"; t <- identifier; string ":"; m <- anything+ return $ Msg f t (trim m)+parseAction = do s <- identifier; string ":"; a <- anything+ return $ Action s (trim a)+parsePre = liftM Pre anything+identifier = do whitespace; i <- many (alphaNum <|> oneOf "_"); whitespace+ return i+whitespace = many $ oneOf " \t"+anything = try (anyChar `manyTill` newline) <|> many1 anyChar+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_банк")+ coarbitrary = undefined++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")+ ]+ coarbitrary = undefined++instance Arbitrary Flow where+ arbitrary = frequency [ (10, liftM3 Msg mkName mkName mkMsg)+ , (5, liftM2 Action mkName mkMsg)+ , (2, liftM Pre mkMsg)+ ]+ where+ mkName = do Name n <- arbitrary; return n+ mkMsg = do Message m <- arbitrary; return m+ coarbitrary = undefined++-- 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] ]+++showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ]+showFlow (Action s a) = unwords [ s, ":", a ]+showFlow (Pre s) = s++prop_reparse x =+ let txt = unlines $ map showFlow x+ in x == parseFlow "" txt++prop_russian_k = + ( parseFlow "a->b" "A->B: клиент" == [Msg "A" "B" "клиент"] ) && + ( parseFlow "prod" "продавец -> клиент: подписание контракта, предоставление счета" == [Msg "продавец" "клиент" "подписание контракта, предоставление счета"] )