diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -16,11 +16,12 @@
* `TrustBoundary`
* `InputOutput`
* `Function`
+* `Database`
* `Flow`
These are composed in a `Diagram` to get something printable.
-For more information see the [Hackage site](https://hackage.haskell.org/package/dataflow).
+For more on Haskell data types, see [the Hackage site](https://hackage.haskell.org/package/dataflow).
## Example
@@ -70,5 +71,5 @@
## Release
```bash
-cabal clean && cabal build && cabal haddock && cabal sdist && cabal upload dist/dataflow-*.tar.gz
+cabal clean && cabal build && cabal sdist && cabal upload dist/dataflow-*.tar.gz
```
diff --git a/dataflow.cabal b/dataflow.cabal
--- a/dataflow.cabal
+++ b/dataflow.cabal
@@ -1,5 +1,5 @@
name: dataflow
-version: 0.4.1.0
+version: 0.4.2.0
synopsis: Generate Graphviz documents from a Haskell representation.
description: Outputs .dot files that can be processed by the dot
command. Currently it only supports the DFD output format
@@ -33,6 +33,7 @@
DataFlow.DFD
build-depends:
base >=4 && <4.8,
- mtl >=2.2
+ mtl >=2.2,
+ containers >= 0.4
hs-source-dirs: src
default-language: Haskell2010
diff --git a/example/example.svg b/example/example.svg
--- a/example/example.svg
+++ b/example/example.svg
@@ -10,14 +10,14 @@
My Diagram
My Diagram
-cluster_browser
-
-Browser
-
cluster_aws
Amazon AWS
+cluster_browser
+
+Browser
+
webapp
@@ -32,7 +32,7 @@
webapp->server
-webappserver->
+(1) Request /
analytics
diff --git a/src/DataFlow/Core.hs b/src/DataFlow/Core.hs
--- a/src/DataFlow/Core.hs
+++ b/src/DataFlow/Core.hs
@@ -5,7 +5,7 @@
Description,
Diagram(..),
Object(..),
- Gen,
+ Renderer,
evalDiagram,
write,
writeln,
@@ -56,97 +56,97 @@
type Indent = Int
type IndentNext = Bool
type Step = Int
-data GenState = GenState Indent IndentNext Step
+data RendererState = RendererState Indent IndentNext Step
--- | The Gen represents some output generator that runs on a 'Diagram'..
-type Gen t = WriterT [String] (State GenState) t
+-- | The Renderer represents some output generator that runs on a 'Diagram'.
+type Renderer t = WriterT [String] (State RendererState) t
--- | Run the 'Gen' and get the output as a 'String'.
-evalDiagram :: Gen () -> String
-evalDiagram g = concat $ evalState (execWriterT g) (GenState 0 False 0)
+-- | Run the 'Renderer' and get the output as a 'String'.
+evalDiagram :: Renderer () -> String
+evalDiagram g = concat $ evalState (execWriterT g) (RendererState 0 False 0)
-- | Write a string to the output (no linefeed).
-write :: String -> Gen ()
+write :: String -> Renderer ()
write s = do
- (GenState n indentNext step) <- lift get
+ (RendererState n indentNext step) <- lift get
if indentNext
then tell [replicate n ' ' ++ s]
else tell [s]
- put $ GenState n False step
+ put $ RendererState n False step
-- | Write a string to the output (with linefeed).
-writeln :: String -> Gen ()
+writeln :: String -> Renderer ()
writeln s = do
write s
write "\n"
- modify $ \(GenState n _ s') -> GenState n True s'
+ modify $ \(RendererState n _ s') -> RendererState n True s'
-incrStep :: Gen ()
-incrStep = modify $ \(GenState n indentNext s') -> GenState n indentNext (s' + 1)
+incrStep :: Renderer ()
+incrStep = modify $ \(RendererState n indentNext s') -> RendererState n indentNext (s' + 1)
-- | Get the next \"step\" number (the order of flow arrows in the diagram).
-nextStep :: Gen Int
+nextStep :: Renderer Int
nextStep = do
incrStep
- (GenState _ _ s) <- lift get
+ (RendererState _ _ s) <- lift get
return s
-- | Increase indent with 2 spaces.
-indent :: Gen ()
-indent = modify $ \(GenState n indentNext s) -> GenState (n + 2) indentNext s
+indent :: Renderer ()
+indent = modify $ \(RendererState n indentNext s) -> RendererState (n + 2) indentNext s
-- | Decrease indent with 2 spaces.
-dedent :: Gen ()
-dedent = modify $ \(GenState n indentNext s) -> GenState (n - 2) indentNext s
+dedent :: Renderer ()
+dedent = modify $ \(RendererState n indentNext s) -> RendererState (n - 2) indentNext s
-- | Indent the output of gen with 2 spaces.
-withIndent :: Gen () -> Gen ()
+withIndent :: Renderer () -> Renderer ()
withIndent gen = do
indent
gen
dedent
-- | Write a blank line.
-blank :: Gen ()
+blank :: Renderer ()
blank = tell [""]
-- | Write a label with the output of gen as its contents.
-label :: Gen () -> Gen ()
+label :: Renderer () -> Renderer ()
label contents = do
write "label = <"
contents
writeln ">;"
-- | Write an HTML tag t with the output of gen as its contents.
-tag :: String -> String -> Gen () -> Gen ()
+tag :: String -> String -> Renderer () -> Renderer ()
tag t a contents = do
write $ "<" ++ t ++ (if null a then "" else " " ++ a) ++ ">"
contents
write $ ""
--- | Write a \ tag surrounding the output of another 'Gen'.
-bold :: Gen () -> Gen ()
+-- | Write a \ tag surrounding the output of another 'Renderer'.
+bold :: Renderer () -> Renderer ()
bold = tag "b" ""
-- | Write a \ tag, with attributes, surrounding the output of
--- another 'Gen'.
-table :: String -> Gen () -> Gen ()
+-- another 'Renderer'.
+table :: String -> Renderer () -> Renderer ()
table = tag "table"
--- | Write a \ tag surrounding the output of another 'Gen'.
-tr :: Gen () -> Gen ()
+-- | Write a \ tag surrounding the output of another 'Renderer'.
+tr :: Renderer () -> Renderer ()
tr = tag "tr" ""
--- | Write a \ tag surrounding the output of another 'Gen'.
-td :: Gen () -> Gen ()
+-- | Write a \ tag surrounding the output of another 'Renderer'.
+td :: Renderer () -> Renderer ()
td = tag "td" ""
-- | The enclosing characters in a block.
data Enclosing = Brackets | CurlyBrackets
--- | Write an object with the given 'Enclosing' characters, 'ID' and 'Gen' as
+-- | Write an object with the given 'Enclosing' characters, 'ID' and 'Renderer' as
-- its contents.
-objectWith :: Enclosing -> ID -> Gen () -> Gen ()
+objectWith :: Enclosing -> ID -> Renderer () -> Renderer ()
objectWith enc id' attributes =
do
blank
@@ -159,5 +159,5 @@
after CurlyBrackets = "}"
-- | Write an attributes declaration for the given 'ID'.
-attrs :: ID -> String -> Gen ()
+attrs :: ID -> String -> Renderer ()
attrs id' = objectWith Brackets id' . writeln
diff --git a/src/DataFlow/DFD.hs b/src/DataFlow/DFD.hs
--- a/src/DataFlow/DFD.hs
+++ b/src/DataFlow/DFD.hs
@@ -1,34 +1,73 @@
module DataFlow.DFD where
+import Control.Monad.Identity
+import Control.Monad.State
+import Data.Map (Map)
+import qualified Data.Map as Map
import DataFlow.Core
+type DFDState v = State (Map (ID, ID) Bool) v
+type DFDRenderer t = DFDState (Renderer t)
+
-- | Type class for types that can be rendered as DFD.
-class DFD t where
- dfd :: t -> Gen ()
+class RenderDFD t where
+ dfd :: t -> DFDRenderer ()
-instance DFD Object where
- dfd (InputOutput id' name) = objectWith Brackets id' $ do
- writeln "shape = square;"
- writeln "style = bold;"
- label $ bold $ write name
+return' :: t -> DFDRenderer t
+return' v = return . lift . return $ v
+exists :: (ID, ID) -> DFDState Bool
+exists k = do
+ m <- get
+ return $ case Map.lookup k m of
+ (Just _) -> True
+ _ -> False
+
+register :: (ID, ID) -> DFDState ()
+register k = do
+ m <- get
+ put $ Map.insert k True m
+ return ()
+
+shouldInvert :: (ID, ID) -> DFDState Bool
+shouldInvert k@(i1, i2) = do
+ e <- exists k
+ if e
+ then return False
+ else do
+ ie <- exists (i2, i1)
+ if ie
+ then return True
+ else do
+ register k
+ return False
+
+instance RenderDFD Object where
+ dfd (InputOutput id' name) =
+ return $ objectWith Brackets id' $ do
+ writeln "shape = square;"
+ writeln "style = bold;"
+ label $ bold $ write name
+
dfd (TrustBoundary id' name objects) = do
- blank
- writeln $ "subgraph cluster_" ++ id' ++ " {"
- withIndent $ do
- mapM_ dfd objects
+ renderObjects <- mapM dfd objects
+ return $ do
blank
- writeln "fontsize = 10;"
- writeln "fontcolor = grey30;"
- label $ write name
- writeln "graph[style = dashed, color=grey30];"
- writeln "}"
+ writeln $ "subgraph cluster_" ++ id' ++ " {"
+ withIndent $ do
+ blank
+ sequence_ renderObjects
+ writeln "fontsize = 10;"
+ writeln "fontcolor = grey30;"
+ label $ write name
+ writeln "graph[style = dashed, color=grey30];"
+ writeln "}"
- dfd (Function id' name) = objectWith Brackets id' $ do
+ dfd (Function id' name) = return $ objectWith Brackets id' $ do
writeln "shape = circle;"
label $ bold $ write name
- dfd (Database id' name) = objectWith Brackets id' $ do
+ dfd (Database id' name) = return $ objectWith Brackets id' $ do
label $
table "sides=\"TB\" cellborder=\"0\"" $
tr $
@@ -36,40 +75,49 @@
bold $ write name
writeln "shape = none;"
- dfd (Flow i1 i2 operation description) = do
- step <- nextStep
- blank
- writeln $ i1 ++ " -> " ++ i2 ++ " ["
- withIndent $
- label $ do
- bold $ write $ "(" ++ show step ++ ") " ++ operation
- write "
"
- write description
- writeln "]"
-
-instance DFD Diagram where
- dfd (Diagram title objects) = do
- writeln $ "digraph \"" ++ title ++ "\" {"
- withIndent $ do
- attrs "graph" "fontname=\"sans-serif\""
- attrs "node" "fontname=\"sans-serif\""
- attrs "edge" "fontname=\"sans-serif\", fontsize=12"
+ dfd (Flow i1 i2 operation description)= do
+ back <- shouldInvert (i1, i2)
+ return $ do
+ step <- nextStep
blank
+ if back
+ then writeln $ i2 ++ " -> " ++ i1 ++ " ["
+ else writeln $ i1 ++ " -> " ++ i2 ++ " ["
+ withIndent $ do
+ when back $
+ writeln "dir = back;"
+ label $ do
+ bold $ write $ "(" ++ show step ++ ") " ++ operation
+ write "
"
+ write description
+ writeln "]"
- writeln "labelloc = \"t\";"
- label $ bold $ write title
- writeln "fontsize = 20;"
+instance RenderDFD Diagram where
+ dfd (Diagram title objects) =
+ do
+ renderObjects <- mapM dfd objects
+ return $ do
+ writeln $ "digraph \"" ++ title ++ "\" {"
+ withIndent $ do
+ attrs "graph" "fontname=\"sans-serif\""
+ attrs "node" "fontname=\"sans-serif\""
+ attrs "edge" "fontname=\"sans-serif\", fontsize=12"
+ blank
- writeln "nodesep = 1;"
- writeln "rankdir = LR;"
+ writeln "labelloc = \"t\";"
+ label $ bold $ write title
+ writeln "fontsize = 20;"
- mapM_ dfd objects
+ writeln "nodesep = 1;"
+ writeln "rankdir = LR;"
- writeln "}"
+ sequence_ renderObjects
+ writeln "}"
+
-- | Generates the DFD output as a String.
evalDfd :: Diagram -> String
-evalDfd = evalDiagram . dfd
+evalDfd d = evalDiagram (evalState (dfd d) Map.empty)
-- | Prints the DFD output to stdout.
printDfd :: Diagram -> IO ()