module Text.FlowDiagram ( flow2dot
, parseFlow
, parseFlowFromFile
, showFlow
, Flow(..)
) where
import qualified Text.Dot as D
import Control.Monad.State (StateT, evalStateT, gets, modify, lift, zipWithM, zipWithM_, foldM, when)
import qualified Data.Map as M (Map, empty, lookup, insert, union, fromList)
import Data.List (intercalate, unfoldr, splitAt, findIndex, nub, sort)
import System.IO (readFile)
import Data.Maybe (catMaybes, isJust, fromMaybe)
import Data.Char (isSpace)
import Text.ParserCombinators.Parsec hiding (State)
type Swimline = String
data Flow = Msg Swimline Swimline String
| Action Swimline String
| Order [Swimline]
deriving (Eq,Show)
isOrder (Order _) = True
isOrder _ = False
isMsg (Msg _ _ _) = True
isMsg _ = False
names flow = nub $ flip concatMap flow $ \elt ->
case elt of
Msg from to _ -> [from,to]
Action a _ -> [a]
Order _ -> []
data DiagS = DiagS { nodes :: M.Map (Int,Swimline) D.NodeId
}
type Diagram = StateT DiagS D.Dot
flow2dot :: [Flow] -> String
flow2dot flow =
("strict "++) $ D.showDot $ evalStateT (flow2dot' flow) (DiagS M.empty)
flow2dot' :: [Flow] -> Diagram ()
flow2dot' flow = do
attribute ("splines","line")
let order = case [ ns | Order ns <- flow ] of
[] -> Nothing
(ns:_) -> Just ns
flow' = filter (not.isOrder) flow
swimlines = names flow'
case order of
Just order' | sort order' /= sort swimlines -> do
error "order statement must mention all swimlines"
_ -> return ()
flip mapM_ (zip [0..] flow') $ \(tier,elt) -> do
namedNodes <- flowElement2dot tier order elt
addNodes $ M.fromList $ [ ((tier,swimline),node) | (swimline,node)<-namedNodes ]
flip mapM_ [ (tier, sline) | sline <- swimlines
, (tier,elt) <-zip [0..] flow'
, not (isMsg elt) ] $ \(tier,sline) -> do
n <- findNode tier sline
case n of
Just _ -> return ()
Nothing -> do
id <- invisNode
addNodes (M.fromList [((tier,sline),id)])
headers <- flip mapM (fromMaybe swimlines order) $ \sline ->
node [ ("label", mkHeader sline)
, ("shape","box")
]
same (headers)
when (isJust order) $ do
zipWithM_ (\h1 h2 -> edge h1 h2 [ ("style","invis")
, ("weight","1")
])
headers (drop 1 headers)
nodesByTier <- flip mapM [ tier | (tier,_) <-zip [0..] flow' ] $ \tier ->
mapM (findNode tier) [ line | line <- swimlines ]
_ <- foldM (\prevNodes thisTier -> do
same $ catMaybes thisTier
zipWithM (\prevNode maybeThisNode ->
case maybeThisNode of
Just thisNode -> do
edge prevNode thisNode
[("style","dotted")
,("arrowhead","none")
,("weight","1000")
]
return thisNode
Nothing -> return prevNode)
prevNodes thisTier)
headers nodesByTier
return ()
flowElement2dot :: Int -> Maybe [String] -> Flow -> Diagram [(String,D.NodeId)]
flowElement2dot tier _ (Action actor message) = do
l <- mkLabel tier message
a <- node [("style","filled"),("shape","plaintext"),("label",l)]
return [(actor,a)]
flowElement2dot tier order (Msg from to message) = do
f <- invisNode
t <- invisNode
l <- mkLabel tier message
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)
,("constraint","false")
,("labelfloat","true")
] ++ attrs
return [(from,f),(to,t)]
flowElement2dot _ _ (Order _) = return []
mkLabel :: Int -> String -> Diagram String
mkLabel tier lbl = do
return $ if null lbl then ""
else (show (tier+1) ++ ": " ++ 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
mkHeader :: String -> String
mkHeader = map remove_underscore
where
remove_underscore '_' = ' '
remove_underscore x = x
addNodes :: M.Map (Int,String) D.NodeId -> Diagram ()
addNodes newNodes = do
modify (\e -> e {nodes = M.union (nodes e) newNodes})
findNode :: Int -> String -> Diagram (Maybe D.NodeId)
findNode tier line = do
ns <- gets nodes
return $ M.lookup (tier, line) ns
same = lift . D.same
node = lift . D.node
edge f t args = lift $ D.edge f t args
attribute = lift . D.attribute
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 $ catMaybes fl
flowLine, parseMsg, parseAction :: GenParser Char st (Maybe Flow)
flowLine = try parseOrder <|> try parseMsg <|> try parseAction <|> parseComment <|> parseBlank
parseOrder = do string "order"
is <- identifier `manyTill` newline
return $ Just $ Order is
parseMsg = do f <- identifier; string "->"; t <- identifier; m <- optionalMessage
return $ Just $ Msg f t (trim m)
parseAction = do s <- identifier; string ":"; a <- anything
return $ Just $ Action s (trim a)
parseBlank = do whitespace; newline; return Nothing
parseComment = do whitespace; string "#"; anything; return Nothing
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
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 ]