module Text.FlowDiagram ( flow2dot
, parseFlow
, parseFlowFromFile
, showFlow
, Flow(..)
) where
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 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)
data Flow = Msg String String String
| Action String String
deriving (Eq,Show)
data DiagS = DiagS { swimlines::M.Map String D.NodeId
, numTier :: Int
, headings :: [D.NodeId]
}
type Diagram = StateT DiagS D.Dot
flow2dot :: [Flow] -> String
flow2dot flow =
("strict "++) $ D.showDot $ evalStateT (flow2dot' flow) (DiagS M.empty 1 [])
flow2dot' :: [Flow] -> Diagram ()
flow2dot' flow = do
mapM_ flowElement2dot flow
hs <- gets headings
same hs
flowElement2dot :: Flow -> Diagram ()
flowElement2dot (Action actor message) = do
tier <- invisNode
l <- mkLabel message
a <- node [("style","filled"),("shape","plaintext"),("label",l)]
same [tier,a]
connectToPrev actor a
connectToPrev "___tier" tier
incTier
flowElement2dot (Msg from to message) = do
tier <- invisNode
f <- invisNode
t <- invisNode
same [f,t,tier]
l <- mkLabel message
connectToPrev from f
connectToPrev to t
connectToPrev "___tier" tier
edge f t [("label",l) ]
incTier
mkLabel :: String -> Diagram String
mkLabel lbl = do
t <- gets numTier
return $ show t ++ ": " ++ reflow lbl
invisNode :: Diagram D.NodeId
invisNode = node [("style","invis"),("shape","point")]
reflow :: String -> String
reflow str = concat $ intersperse [chr 10] $ 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
connectToPrev :: String -> D.NodeId -> Diagram ()
connectToPrev "___tier" _ = return ()
connectToPrev sline currNode = do
s <- getSwimline sline
case s of
(Just prevNode) -> do edge prevNode currNode [("style","dotted"),("arrowhead","none")]
setSwimline sline currNode
(Nothing) -> do setSwimline sline currNode
heading <- node [("label", mkHeader sline)]
addHeading heading
setSwimline sline heading
connectToPrev sline currNode
mkHeader :: String -> String
mkHeader = map remove_underscore
where
remove_underscore '_' = ' '
remove_underscore x = x
incTier :: Diagram ()
incTier = modify (\e -> e {numTier = numTier e +1} )
getSwimline :: String -> Diagram (Maybe D.NodeId)
getSwimline name = do
s <- gets swimlines
return $ M.lookup name s
setSwimline :: String -> D.NodeId -> Diagram ()
setSwimline name x = do
modify (\e -> e {swimlines = M.insert name x (swimlines e)})
addHeading :: D.NodeId -> Diagram ()
addHeading x = do
modify (\e -> e {headings = x:(headings e)})
same = lift . D.same
node = lift . D.node
edge f t args = lift $ D.edge f t args
parseFlowFromFile :: FilePath -> IO [Flow]
parseFlowFromFile fname = do
raw <- readFile fname
return $ parseFlow fname 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 :: GenParser Char st [Flow]
document = do
whitespace
fl <- many flowLine
eof
return fl
flowLine, parseMsg, parseAction :: GenParser Char st Flow
flowLine = try parseMsg <|> try parseAction
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
return i
whitespace = many $ oneOf " \t"
anything = try (anyChar `manyTill` newline) <|> many1 anyChar
trim :: String -> String
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
newtype Name = Name String
newtype Message = Message String
instance Arbitrary Name where
arbitrary = liftM Name (listOf' $ elements "abcxyz_банк")
coarbitrary = undefined
instance Arbitrary Message where
arbitrary = liftM ((Message).unwords.words) $ frequency [ (50, listOf' $ elements "abcxyz_->; 123банк")
, (1, return "foo -> bar")
]
coarbitrary = undefined
instance Arbitrary Flow where
arbitrary = frequency [ (10, liftM3 Msg mkName mkName mkMsg)
, (5, liftM2 Action mkName mkMsg)
]
where
mkName = do Name n <- arbitrary; return n
mkMsg = do Message m <- arbitrary; return m
coarbitrary = undefined
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 :: Flow -> String
showFlow (Msg f t m) = unwords [ f, " -> ", t, ":", m ]
showFlow (Action s a) = unwords [ s, ":", a ]
prop_reparse :: [Flow] -> Bool
prop_reparse x =
let txt = unlines $ map showFlow x
in x == parseFlow "" txt
prop_russian_k :: Bool
prop_russian_k =
( parseFlow "a->b" "A->B: клиент" == [Msg "A" "B" "клиент"] ) &&
( parseFlow "prod" "продавец -> клиент: подписание контракта, предоставление счета" == [Msg "продавец" "клиент" "подписание контракта, предоставление счета"] )