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 (intercalate, unfoldr, splitAt, findIndex)
#ifndef NATIVEUTF8
import Prelude hiding (readFile)
import System.IO.UTF8 (readFile)
#endif
import Data.Char (isSpace)
import Test.QuickCheck
import Control.Monad (liftM, liftM2, liftM3)
import Text.ParserCombinators.Parsec hiding (State)
data Flow = Msg String String String
| Action String String
| Order [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
let order = case [ ns | Order ns <- flow ] of
[] -> Nothing
(ns:_) -> Just ns
mapM_ (flowElement2dot order) flow
hs <- gets headings
same hs
flowElement2dot :: Maybe [String] -> 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 order (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
let (f',t',attrs) =
if order == Nothing
then (f,t,[])
else let (Just sls) = order
in case (findIndex (==from) sls, findIndex (==to) sls) of
(Just x, Just y) -> if x>y then (t,f,[("dir","back")]) else (f,t,[])
_ -> (f,t,[])
edge f' t' $ [("label",l)] ++ attrs
incTier
flowElement2dot _ (Order _) = return ()
mkLabel :: String -> Diagram String
mkLabel lbl = do
t <- gets numTier
return $ if null lbl then show t
else (show t ++ ": " ++ reflow lbl)
invisNode :: Diagram D.NodeId
invisNode = node [("style","invis"),("shape","point")]
reflow :: String -> String
reflow str = intercalate "\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
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 parseOrder <|> try parseMsg <|> try parseAction
parseOrder = do string "order"
is <- identifier `manyTill` newline
return $ Order is
parseMsg = do f <- identifier; string "->"; t <- identifier; m <- optionalMessage
return $ Msg f t (trim m)
parseAction = do s <- identifier; string ":"; a <- anything
return $ Action s (trim a)
optionalMessage = do
m <- option "" (try (do {string ":"; anything}))
optional newline
return m
identifier, whitespace, anything :: GenParser Char st String
identifier = do whitespace; i <- many1 (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_банк")
instance Arbitrary Message where
arbitrary = liftM ((Message).unwords.words) $ frequency [ (50, listOf' $ elements "abcxyz_->; 123банк")
, (1, return "foo -> bar")
]
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
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 (Order sl) = "order " ++ intercalate " " sl
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 "продавец" "клиент" "подписание контракта, предоставление счета"] )