packages feed

flow2dot 0.2 → 0.2.1

raw patch · 5 files changed

+76/−49 lines, 5 filesdep +containers

Dependencies added: containers

Files

Dot.hs view
@@ -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 <dastapov@gmail.com> -- 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
README view
@@ -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
Text/UTF8.hs view
@@ -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
flow2dot.cabal view
@@ -1,5 +1,5 @@-Name:    flow2dot -Version: 0.2+Name:    flow2dot+Version: 0.2.1 License: BSD3 License-File: LICENSE Author: Dmitry Astapov <dastapov@gmail.com>@@ -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
flow2dot.hs view
@@ -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 <dastapov@gmail.com> -- 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 "продавец" "клиент" "подписание контракта, предоставление счета"] )