module DataFlow.DFD where
import Text.Printf
import Control.Monad
import Control.Monad.State
import qualified DataFlow.Core as C
import DataFlow.Graphviz
import DataFlow.Graphviz.EdgeNormalization
type Step = Int
type DFD v = State Step v
incrStep :: DFD ()
incrStep = modify (+ 1)
nextStep :: DFD Int
nextStep = do
incrStep
get
inQuotes :: String -> String
inQuotes s = "\"" ++ s ++ "\""
inAngleBrackets :: String -> String
inAngleBrackets s = "<" ++ s ++ ">"
label :: String -> Attr
label "" = Attr (ID "label") (ID "")
label s = Attr (ID "label") (ID $ inAngleBrackets s)
bold :: String -> String
bold "" = ""
bold s = "<b>" ++ s ++ "</b>"
italic :: String -> String
italic "" = ""
italic s = "<i>" ++ s ++ "</i>"
small :: String -> String
small "" = ""
small s = printf "<font point-size=\"10\">%s</font>" s
color :: String -> String -> String
color _ "" = ""
color c s = printf "<font color=\"%s\">%s</font>" c s
convertObject :: C.Object -> DFD StmtList
convertObject (C.InputOutput id' name) = return [
NodeStmt (ID id') [
Attr (ID "shape") (ID "square"),
Attr (ID "style") (ID "bold"),
label $ printf "<table border=\"0\" cellborder=\"0\" cellpadding=\"2\"><tr><td>%s</td></tr></table>" (bold name)
]
]
convertObject (C.TrustBoundary id' name objects) = do
objectStmts <- convertObjects objects
let sgId = ID $ "cluster_" ++ id'
sgAttrStmt = AttrStmt Graph [
Attr (ID "fontsize") (ID "10"),
Attr (ID "fontcolor") (ID "grey35"),
Attr (ID "style") (ID "dashed"),
Attr (ID "color") (ID "grey35"),
label $ italic name
]
stmts = sgAttrStmt : objectStmts
return [SubgraphStmt $ Subgraph sgId stmts]
convertObject (C.Function id' name) = return [
NodeStmt (ID id') [
Attr (ID "shape") (ID "circle"),
label $ bold name
]
]
convertObject (C.Database id' name) = return [
NodeStmt (ID id') [
Attr (ID "shape") (ID "none"),
label $ printf "<table sides=\"TB\" cellborder=\"0\"><tr><td>%s</td></tr></table>" (bold name)
]
]
convertObject (C.Flow i1 i2 op desc) = do
step <- nextStep
let stepStr = color "#3184e4" $ bold $ printf "(%d) " step
return [
EdgeStmt (EdgeExpr (IDOperand (NodeID (ID i1) Nothing))
Arrow
(IDOperand (NodeID (ID i2) Nothing))) [
label $ stepStr ++ bold op ++ "<br/>" ++ small desc
]
]
convertObjects :: [C.Object] -> DFD StmtList
convertObjects = liftM concat . mapM convertObject
defaultGraphStmts :: StmtList
defaultGraphStmts = [
AttrStmt Graph [
Attr (ID "fontname") (ID "Arial"),
Attr (ID "fontsize") (ID "14")
],
AttrStmt Node [
Attr (ID "fontname") (ID "Arial"),
Attr (ID "fontsize") (ID "14")
],
AttrStmt Edge [
Attr (ID "shape") (ID "none"),
Attr (ID "fontname") (ID "Arial"),
Attr (ID "fontsize") (ID "12")
],
EqualsStmt (ID "labelloc") (ID $ inQuotes "t"),
EqualsStmt (ID "fontsize") (ID "20"),
EqualsStmt (ID "nodesep") (ID "1"),
EqualsStmt (ID "rankdir") (ID "t")
]
convertDiagram :: C.Diagram -> DFD Graph
convertDiagram (C.Diagram (Just name) objects) = do
let lbl = EqualsStmt (ID "label") (ID $ inAngleBrackets $ bold name)
objs <- convertObjects objects
let stmts = lbl : defaultGraphStmts ++ objs
return $ normalize $ Digraph (ID $ inQuotes name) stmts
convertDiagram (C.Diagram Nothing objects) = do
objs <- convertObjects objects
return $ normalize $ Digraph (ID "Untitled") $ defaultGraphStmts ++ objs
asDFD :: C.Diagram -> Graph
asDFD d = evalState (convertDiagram d) 0