module DataFlow.DFD where
import Text.Printf
import Control.Monad
import Control.Monad.State
import qualified Data.Map as M
import qualified DataFlow.Core as C
import DataFlow.Attributes
import DataFlow.Graphviz
import DataFlow.Graphviz.EdgeNormalization
type DFDState = Int
type DFD v = State DFDState v
incrStep :: DFD ()
incrStep = modify (+ 1)
-- | Get the next \"step\" number (the order of flow arrows in the diagram).
nextStep :: DFD Int
nextStep = do
incrStep
get
inQuotes :: String -> String
inQuotes s = "\"" ++ s ++ "\""
inAngleBrackets :: String -> String
inAngleBrackets s = "<" ++ s ++ ">"
label :: String -> Attr
label "" = Attr "label" ""
label s = Attr "label" $ inAngleBrackets s
bold :: String -> String
bold "" = ""
bold s = "" ++ s ++ ""
italic :: String -> String
italic "" = ""
italic s = "" ++ s ++ ""
small :: String -> String
small "" = ""
small s = printf "%s" s
color :: String -> String -> String
color _ "" = ""
color c s = printf "%s" c s
convertNode :: C.Node -> DFD StmtList
convertNode (C.InputOutput id' attrs) = return [
NodeStmt id' [
Attr "shape" "square",
Attr "style" "bold",
label $
printf "
"
(bold $ getTitleOrBlank attrs)
]
]
convertNode (C.Function id' attrs) = return [
NodeStmt id' [
Attr "shape" "circle",
label $ bold $ getTitleOrBlank attrs
]
]
convertNode (C.Database id' attrs) = return [
NodeStmt id' [
Attr "shape" "none",
label $ printf ""
(bold $ getTitleOrBlank attrs)
]
]
convertNodes :: [C.Node] -> DFD StmtList
convertNodes = liftM concat . mapM convertNode
convertFlow :: C.Flow -> DFD StmtList
convertFlow (C.Flow i1 i2 attrs) = do
s <- nextStep
let stepStr = color "#3184e4" $ bold $ printf "(%d) " s
asRows :: C.Value -> [String]
asRows (C.String s) = lines s
asRows (C.Array vs) = concatMap asRows vs
rowsToTable :: [String] -> String
rowsToTable rows =
printf "" r
where r = concatMap (printf "%s |
") rows :: String
rows = case (M.lookup "operation" attrs, M.lookup "data" attrs) of
(Just op, Just d) -> (stepStr ++ bold (show op)) : map small (asRows d)
(Just op, Nothing) -> [stepStr ++ bold (show op)]
(Nothing, Just d) -> stepStr : map small (asRows d)
_ -> []
return [
EdgeStmt (EdgeExpr (IDOperand (NodeID i1 Nothing))
Arrow
(IDOperand (NodeID i2 Nothing))) [
label $ rowsToTable rows
]
]
convertFlows :: [C.Flow] -> DFD StmtList
convertFlows = liftM concat . mapM convertFlow
convertRootNode :: C.RootNode -> DFD StmtList
convertRootNode (C.TrustBoundary id' attrs nodes) = do
nodeStmts <- convertNodes nodes
let sgId = "cluster_" ++ id'
defaultSgAttrs = [
Attr "fontsize" "10",
Attr "fontcolor" "grey35",
Attr "style" "dashed",
Attr "color" "grey35"]
sgAttrs = case getTitle attrs of
Just title -> defaultSgAttrs ++ [label $ italic title]
Nothing -> defaultSgAttrs
sgAttrStmt = AttrStmt Graph sgAttrs
stmts = sgAttrStmt : nodeStmts
return [SubgraphStmt $ Subgraph sgId stmts]
convertRootNode (C.Node n) = convertNode n
convertRootNodes :: [C.RootNode] -> DFD StmtList
convertRootNodes = liftM concat . mapM convertRootNode
defaultGraphStmts :: StmtList
defaultGraphStmts = [
AttrStmt Graph [
Attr "fontname" "Arial",
Attr "fontsize" "14"
],
AttrStmt Node [
Attr "fontname" "Arial",
Attr "fontsize" "14"
],
AttrStmt Edge [
Attr "shape" "none",
Attr "fontname" "Arial",
Attr "fontsize" "12"
],
EqualsStmt "labelloc" (inQuotes "t"),
EqualsStmt "fontsize" "20",
EqualsStmt "nodesep" "1",
EqualsStmt "rankdir" "t"
]
convertDiagram :: C.Diagram -> DFD Graph
convertDiagram (C.Diagram attrs rootNodes flows) = do
n <- convertRootNodes rootNodes
f <- convertFlows flows
return $ case M.lookup "title" attrs of
Just title ->
let lbl = EqualsStmt "label" (inAngleBrackets $ show title)
stmts = lbl : defaultGraphStmts ++ n ++ f
in normalize $ Digraph (inQuotes $ show title) stmts
Nothing ->
normalize $ Digraph "Untitled" $ defaultGraphStmts ++ n ++ f
asDFD :: C.Diagram -> Graph
asDFD d = evalState (convertDiagram d) 0