diff --git a/Dot.hs b/Dot.hs new file mode 100644 --- /dev/null +++ b/Dot.hs @@ -0,0 +1,115 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Name : Dot +-- Copyright : (c) Dmitry Astapov, 2007 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Dmitry Astapov +-- 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" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/Text/UTF8.hs b/Text/UTF8.hs new file mode 100644 --- /dev/null +++ b/Text/UTF8.hs @@ -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 + +-} + +{- + +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 diff --git a/flow2dot.cabal b/flow2dot.cabal new file mode 100644 --- /dev/null +++ b/flow2dot.cabal @@ -0,0 +1,24 @@ +Name: flow2dot +Version: 0.2 +License: BSD3 +License-File: LICENSE +Author: Dmitry Astapov +Maintainer: Dmitry Astapov +Synopsis: Generates sequence diagrams from textual descriptions +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/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 diff --git a/flow2dot.hs b/flow2dot.hs new file mode 100644 --- /dev/null +++ b/flow2dot.hs @@ -0,0 +1,313 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Name : Flow2Dot +-- Copyright : (c) Dmitry Astapov, 2007 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Dmitry Astapov +-- 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 "продавец" "клиент" "подписание контракта, предоставление счета"] )