diff --git a/Dot.hs b/Dot.hs --- a/Dot.hs +++ b/Dot.hs @@ -1,10 +1,10 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Name : Dot -- Copyright : (c) Dmitry Astapov, 2007 -- License : BSD-style (see the file LICENSE) --- +-- -- Maintainer : Dmitry Astapov -- Stability : experimental -- Portability : portable @@ -51,7 +51,7 @@ setSection s = modify (\e -> e {section = s}) -- Dot language elements -data Param = Label String | Constraint Bool | Style Style +data Param = Label String | Constraint Bool | Style Style | Shape Shape | ArrowHead String data Style = Invis | Dotted | Filled data Shape = Point | Plaintext @@ -60,21 +60,18 @@ 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 $ + emit $ unwords $ [ from_node , "->" , to_node , mkParams params , ";" - ] + ] -- Graph generation helpers mkParams :: [Param] -> String diff --git a/README b/README --- a/README +++ b/README @@ -22,4 +22,5 @@ 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. +haskell@conference.jabber.ru for win32 testing. Gwern0 helped +to adapt this to GHC 6.8.2 diff --git a/Text/UTF8.hs b/Text/UTF8.hs --- a/Text/UTF8.hs +++ b/Text/UTF8.hs @@ -58,7 +58,9 @@ import Data.List (unfoldr) -toUTF8 s = (map (chr. fromIntegral) $ encode s) +toUTF8 :: String -> String +toUTF8 s = (map (chr. fromIntegral) $ encode s) +fromUTF8 :: String -> (String, [(Error, Int)]) fromUTF8 s = decode (map (fromIntegral . ord) s) -- - UTF-8 in General - @@ -121,7 +123,7 @@ -- With the above, a stream decoder is trivial: -encode :: [Char] -> [Word8] +encode :: String -> [Word8] encode = concatMap encodeOne @@ -349,7 +351,7 @@ -- The decoder examines all input, recording decoded characters as well as -- error-index pairs along the way. -decode :: [Word8] -> ([Char], [(Error,Int)]) +decode :: [Word8] -> (String, [(Error,Int)]) decode = swap . partitionEither . decodeEmbedErrors decodeEmbedErrors :: [Word8] -> [Either (Error,Int) Char] @@ -371,4 +373,4 @@ toMaybe :: Bool -> a -> Maybe a toMaybe False _ = Nothing -toMaybe True x = Just x +toMaybe True x = Just x diff --git a/flow2dot.cabal b/flow2dot.cabal --- a/flow2dot.cabal +++ b/flow2dot.cabal @@ -1,5 +1,5 @@ -Name: flow2dot -Version: 0.2 +Name: flow2dot +Version: 0.2.1 License: BSD3 License-File: LICENSE Author: Dmitry Astapov @@ -11,14 +11,14 @@ 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 + +Tested-With: GHC ==6.8.2 +Build-Depends: base, mtl >= 1.0, containers, haskell98, QuickCheck, parsec +Build-Type: Simple 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 +Executable: flow2dot +Main-Is: flow2dot.hs Other-Modules: Text.UTF8, Dot +GHC-Options: -Wall +Extensions: FlexibleInstances diff --git a/flow2dot.hs b/flow2dot.hs --- a/flow2dot.hs +++ b/flow2dot.hs @@ -1,10 +1,10 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Name : Flow2Dot -- Copyright : (c) Dmitry Astapov, 2007 -- License : BSD-style (see the file LICENSE) --- +-- -- Maintainer : Dmitry Astapov -- Stability : experimental -- Portability : portable @@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- module Main where -import Dot +import Dot import System (getArgs) import Control.Monad.State (State,evalState,gets,modify) @@ -26,12 +26,12 @@ import Text.ParserCombinators.Parsec hiding (State) {- -Idea: In order to draw sequence (flow) diagram using graphviz we can use directed layout (dot) to +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 +strict digraph SeqDiagram { { // Those are swimline heads rank=same @@ -58,7 +58,7 @@ tier1 -> tier2; // Actual messages. Note the "constraint=false" - actor1 -> system1[label="xxx", constraint=false]; + actor1 -> system1[label="xxx", constraint=false]; system2 -> actor2[label="yyy", constraint=false]; } -} @@ -67,11 +67,12 @@ -- 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 +data Flow = Msg String String String | Action String String | Pre String deriving (Eq,Show) +main :: IO () main = do args <- getArgs case args of @@ -86,6 +87,7 @@ putStrLn $ toUTF8 $ processFlow flow -- FIXME: remove "zzzz_BODY" and rework section generation to emit body last +processFlow :: [Flow] -> String processFlow flow = evalState (flow2dot flow) (DiagS M.empty 1 (DotEnv "zzzz_BODY" M.empty)) -- | State of the diagram builder @@ -122,35 +124,39 @@ 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. +-- 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] + tir <- getTierName + inSection tir $ do addString "rank=same;" + addNode tir [Style Invis, Shape Point] l <- mkLabel message - genNextNode tier actor [Style Filled, Shape Plaintext, Label l] + genNextNode tir 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] + tir <- getTierName + inSection tir $ do addString "rank=same;" + addNode tir [Style Invis, Shape Point] + f <- genNextNode tir from [Style Invis, Shape Point] + t <- genNextNode tir to [Style Invis, Shape Point] l <- mkLabel message - addEdge f t [ Label l + addEdge f t [ Label l , Constraint False ] toNextTier +mkLabel :: String -> Diagram String mkLabel lbl = do t <- gets tier return $ show t ++ ": " ++ reflow lbl where + +reflow :: String -> String -- 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 @@ -164,17 +170,19 @@ width=3 height=1 +toNextTier :: Diagram () toNextTier = do - tier <- getTierName + tir <- getTierName prev <- getPrevTierName case prev of Nothing -> return () - Just p -> addEdge p tier [ Style Invis ] + Just p -> addEdge p tir [ 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 :: String -> String -> [Param] -> Diagram String genNextNode sec sline nodeparams = do s <- getSwimline sline case s of @@ -198,68 +206,84 @@ addEdge sline first [Style Dotted, ArrowHead "none"] return first +mkHeader :: String -> String mkHeader = map remove_underscore where remove_underscore '_' = ' ' remove_underscore x = x -- State access/modify helpers +setTier :: Int -> Diagram () setTier x = modify (\f -> f {tier=x}) +getTierName :: Diagram String getTierName = do t <- gets tier return $ "tier" ++ show t +getPrevTierName :: Diagram (Maybe String) getPrevTierName = do t <- gets tier if (t>1) then return $ Just $ "tier" ++ show (t-1) else return Nothing +incTier :: Diagram () incTier = modify (\e -> e {tier = tier e +1} ) +getSwimline :: String -> Diagram (Maybe Int) getSwimline name = do s <- gets swimlines return $ M.lookup name s +getSwimlineNodeName :: String -> Diagram String getSwimlineNodeName name = do s <- getSwimline name return $ name ++ show (fromJust s) -setSwimline name x = do +setSwimline :: String -> Int -> Diagram () +setSwimline name x = do modify (\e -> e {swimlines = M.insert name x (swimlines e)}) +incSwimline :: String -> Diagram () incSwimline name = do s <- getSwimline name setSwimline name (fromJust s+1) --- Parser + +parseFlowFromFile :: FilePath -> IO [Flow]-- Parser parseFlowFromFile fname = do raw <- readFile fname return $ parseFlow fname $ fst $ fromUTF8 raw parseFlow :: String -> String -> [Flow] parseFlow _ "" = [] -parseFlow fname str = +parseFlow fname str = case parse document fname str of Left err -> error $ unlines [ "Input:", str, "Error:", show err] Right flow -> flow +document :: GenParser Char st [Flow] document = do whitespace fl <- many flowLine eof return fl +flowLine, parseMsg, parseAction, parsePre :: GenParser Char st Flow 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, whitespace, anything :: GenParser Char st String identifier = do whitespace; i <- many (alphaNum <|> oneOf "_"); whitespace return i whitespace = many $ oneOf " \t" anything = try (anyChar `manyTill` newline) <|> many1 anyChar + +trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- Parser tests @@ -300,14 +324,17 @@ vectorOf' k gen = sequence [ gen | _ <- [1..k] ] +showFlow :: Flow -> String showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ] showFlow (Action s a) = unwords [ s, ":", a ] showFlow (Pre s) = s +prop_reparse :: [Flow] -> Bool prop_reparse x = let txt = unlines $ map showFlow x in x == parseFlow "" txt -prop_russian_k = - ( parseFlow "a->b" "A->B: клиент" == [Msg "A" "B" "клиент"] ) && +prop_russian_k :: Bool +prop_russian_k = + ( parseFlow "a->b" "A->B: клиент" == [Msg "A" "B" "клиент"] ) && ( parseFlow "prod" "продавец -> клиент: подписание контракта, предоставление счета" == [Msg "продавец" "клиент" "подписание контракта, предоставление счета"] )