diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -2,14 +2,17 @@
Generate Graphviz documents from a Haskell representation.
+## Getting Started
+
```
-cabal configure
-cabal build
+cabal sandbox init
+cabal configure --enable-tests
+cabal install --only-dependencies --enable-tests
```
## Usage
-
+
The objects supported by DataFlow is:
@@ -29,13 +32,14 @@
module Main where
import DataFlow.Core
+import DataFlow.Graphviz.Renderer
import DataFlow.DFD
main :: IO ()
-main = printDfd $
- Diagram "My Diagram" [
+main = putStr $ renderGraphviz $ asDFD $
+ Diagram (Just "Webapp") [
TrustBoundary "browser" "Browser" [
- Function "webapp" "Webapp"
+ Function "client" "Client"
],
TrustBoundary "aws" "Amazon AWS" [
Function "server" "Web Server",
@@ -43,11 +47,11 @@
],
InputOutput "analytics" "Google Analytics",
- Flow "webapp" "server" "Request /" "",
+ Flow "client" "server" "Request /" "",
Flow "server" "logs" "Log" "User IP",
- Flow "server" "webapp" "Response" "User Profile",
+ Flow "server" "client" "Response" "User Profile",
- Flow "webapp" "analytics" "Log" "Page Navigation"
+ Flow "client" "analytics" "Log" "Page Navigation"
]
```
@@ -59,13 +63,12 @@
That should generate something like the following.
-
+
## Building the Examples
```bash
-cabal install
-make -C example
+make -C examples
```
## Release
diff --git a/dataflow.cabal b/dataflow.cabal
--- a/dataflow.cabal
+++ b/dataflow.cabal
@@ -1,5 +1,5 @@
name: dataflow
-version: 0.4.2.0
+version: 0.5.0.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
@@ -17,10 +17,11 @@
build-type: Simple
extra-source-files: README.md,
LICENSE,
- example/example.hs,
- example/example.svg,
- example/legend.hs,
- example/legend.svg
+ examples/webapp.hs,
+ examples/webapp.svg,
+ examples/legend.hs,
+ examples/legend.svg,
+ examples/Makefile
cabal-version: >=1.10
source-repository head
@@ -30,6 +31,8 @@
library
exposed-modules:
DataFlow.Core,
+ DataFlow.Graphviz,
+ DataFlow.Graphviz.Renderer,
DataFlow.DFD
build-depends:
base >=4 && <4.8,
@@ -37,3 +40,15 @@
containers >= 0.4
hs-source-dirs: src
default-language: Haskell2010
+
+test-suite spec
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ default-language: Haskell98
+ hs-source-dirs: test
+ build-depends:
+ base,
+ HUnit,
+ hspec == 2.*,
+ dataflow
+ ghc-options: -Wall
diff --git a/example/example.hs b/example/example.hs
deleted file mode 100644
--- a/example/example.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Main where
-
-import DataFlow.Core
-import DataFlow.DFD
-
-main :: IO ()
-main = printDfd $
- Diagram "My Diagram" [
- TrustBoundary "browser" "Browser" [
- Function "webapp" "Webapp"
- ],
- TrustBoundary "aws" "Amazon AWS" [
- Function "server" "Web Server",
- Database "logs" "Logs"
- ],
- InputOutput "analytics" "Google Analytics",
-
- Flow "webapp" "server" "Request /" "",
- Flow "server" "logs" "Log" "User IP",
- Flow "server" "webapp" "Response" "User Profile",
-
- Flow "webapp" "analytics" "Log" "Page Navigation"
- ]
diff --git a/example/example.svg b/example/example.svg
deleted file mode 100644
--- a/example/example.svg
+++ /dev/null
@@ -1,70 +0,0 @@
-
-
-
-
-
diff --git a/example/legend.hs b/example/legend.hs
deleted file mode 100644
--- a/example/legend.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Main where
-
-import DataFlow.Core
-import DataFlow.DFD
-
-main :: IO ()
-main = printDfd $
- Diagram "Legend" [
- TrustBoundary "trust" "TrustBoundary" [
- Function "function" "Function",
- Database "database" "Database",
- InputOutput "io" "InputOutput"
- ],
- Flow "function" "io" "Flow" "",
- Flow "function" "database" "Flow" ""
- ]
-
diff --git a/example/legend.svg b/example/legend.svg
deleted file mode 100644
--- a/example/legend.svg
+++ /dev/null
@@ -1,46 +0,0 @@
-
-
-
-
-
diff --git a/examples/Makefile b/examples/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/Makefile
@@ -0,0 +1,13 @@
+SOURCES=$(shell find *.hs)
+TARGETS=$(SOURCES:%.hs=%.svg)
+
+%.svg: %.hs
+ @echo "$< -> $@"
+ @runhaskell -i../src $< | dot -Tsvg > $@
+
+svg: $(TARGETS)
+
+clean:
+ rm -f $(TARGETS)
+
+all: svg
diff --git a/examples/legend.hs b/examples/legend.hs
new file mode 100644
--- /dev/null
+++ b/examples/legend.hs
@@ -0,0 +1,19 @@
+module Main where
+
+import DataFlow.Core
+import DataFlow.Graphviz.Renderer
+import DataFlow.DFD
+
+main :: IO ()
+main = putStr $ renderGraphviz $ asDFD $
+ Diagram Nothing [
+ TrustBoundary "trust" "TrustBoundary" [
+ Function "function" "Function",
+ Database "database" "Database",
+ InputOutput "io" "InputOutput"
+ ],
+ Flow "function" "io" "Flow" "",
+ Flow "io" "function" "Flow" "(backwards)",
+ Flow "function" "database" "Flow" ""
+ ]
+
diff --git a/examples/legend.svg b/examples/legend.svg
new file mode 100644
--- /dev/null
+++ b/examples/legend.svg
@@ -0,0 +1,52 @@
+
+
+
+
+
diff --git a/examples/webapp.hs b/examples/webapp.hs
new file mode 100644
--- /dev/null
+++ b/examples/webapp.hs
@@ -0,0 +1,24 @@
+module Main where
+
+import DataFlow.Core
+import DataFlow.Graphviz.Renderer
+import DataFlow.DFD
+
+main :: IO ()
+main = putStr $ renderGraphviz $ asDFD $
+ Diagram (Just "Webapp") [
+ TrustBoundary "browser" "Browser" [
+ Function "client" "Client"
+ ],
+ TrustBoundary "aws" "Amazon AWS" [
+ Function "server" "Web Server",
+ Database "logs" "Logs"
+ ],
+ InputOutput "analytics" "Google
Analytics",
+
+ Flow "client" "server" "Request /" "",
+ Flow "server" "logs" "Log" "User IP",
+ Flow "server" "client" "Response" "User Profile",
+
+ Flow "client" "analytics" "Log" "Page Navigation"
+ ]
diff --git a/examples/webapp.svg b/examples/webapp.svg
new file mode 100644
--- /dev/null
+++ b/examples/webapp.svg
@@ -0,0 +1,71 @@
+
+
+
+
+
diff --git a/src/DataFlow/Core.hs b/src/DataFlow/Core.hs
--- a/src/DataFlow/Core.hs
+++ b/src/DataFlow/Core.hs
@@ -4,30 +4,9 @@
Operation,
Description,
Diagram(..),
- Object(..),
- Renderer,
- evalDiagram,
- write,
- writeln,
- nextStep,
- indent,
- dedent,
- withIndent,
- blank,
- label,
- tag,
- bold,
- table,
- tr,
- td,
- Enclosing(..),
- objectWith,
- attrs
+ Object(..)
) where
-import Control.Monad.State
-import Control.Monad.Writer
-
-- | An identifier corresponding to those in Graphviz.
type ID = String
-- | The name of a 'Diagram' or 'Object'.
@@ -38,7 +17,7 @@
type Description = String
-- | The top level diagram.
-data Diagram = Diagram Name [Object]
+data Diagram = Diagram (Maybe Name) [Object]
-- | An object in a diagram.
data Object =
@@ -52,112 +31,3 @@
| Database ID Name
-- | Describes the flow of data between two objects.
| Flow ID ID Operation Description deriving (Show, Eq)
-
-type Indent = Int
-type IndentNext = Bool
-type Step = Int
-data RendererState = RendererState Indent IndentNext Step
-
--- | The Renderer represents some output generator that runs on a 'Diagram'.
-type Renderer t = WriterT [String] (State RendererState) t
-
--- | 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 -> Renderer ()
-write s = do
- (RendererState n indentNext step) <- lift get
- if indentNext
- then tell [replicate n ' ' ++ s]
- else tell [s]
- put $ RendererState n False step
-
--- | Write a string to the output (with linefeed).
-writeln :: String -> Renderer ()
-writeln s = do
- write s
- write "\n"
- modify $ \(RendererState n _ s') -> RendererState n True s'
-
-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 :: Renderer Int
-nextStep = do
- incrStep
- (RendererState _ _ s) <- lift get
- return s
-
--- | Increase indent with 2 spaces.
-indent :: Renderer ()
-indent = modify $ \(RendererState n indentNext s) -> RendererState (n + 2) indentNext s
-
--- | Decrease indent with 2 spaces.
-dedent :: Renderer ()
-dedent = modify $ \(RendererState n indentNext s) -> RendererState (n - 2) indentNext s
-
--- | Indent the output of gen with 2 spaces.
-withIndent :: Renderer () -> Renderer ()
-withIndent gen = do
- indent
- gen
- dedent
-
--- | Write a blank line.
-blank :: Renderer ()
-blank = tell [""]
-
--- | Write a label with the output of gen as its contents.
-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 -> 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 'Renderer'.
-bold :: Renderer () -> Renderer ()
-bold = tag "b" ""
-
--- | Write a \ tag, with attributes, surrounding the output of
--- another 'Renderer'.
-table :: String -> Renderer () -> Renderer ()
-table = tag "table"
-
--- | Write a \ tag surrounding the output of another 'Renderer'.
-tr :: Renderer () -> Renderer ()
-tr = tag "tr" ""
-
--- | 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 'Renderer' as
--- its contents.
-objectWith :: Enclosing -> ID -> Renderer () -> Renderer ()
-objectWith enc id' attributes =
- do
- blank
- writeln $ id' ++ " " ++ before enc
- withIndent attributes
- writeln $ after enc
- where before Brackets = "["
- before CurlyBrackets = "{"
- after Brackets = "]"
- after CurlyBrackets = "}"
-
--- | Write an attributes declaration for the given 'ID'.
-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,124 +1,105 @@
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 RenderDFD t where
- dfd :: t -> DFDRenderer ()
-
-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
+import Text.Printf
+import qualified DataFlow.Core as C
+import DataFlow.Graphviz
+import DataFlow.Graphviz.EdgeNormalization
-register :: (ID, ID) -> DFDState ()
-register k = do
- m <- get
- put $ Map.insert k True m
- return ()
+inQuotes :: String -> String
+inQuotes s = "\"" ++ s ++ "\""
-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
+inAngleBrackets :: String -> String
+inAngleBrackets s = "<" ++ s ++ ">"
-instance RenderDFD Object where
- dfd (InputOutput id' name) =
- return $ objectWith Brackets id' $ do
- writeln "shape = square;"
- writeln "style = bold;"
- label $ bold $ write name
+label :: String -> Attr
+label s = Attr (ID "label") (ID $ inAngleBrackets s)
- dfd (TrustBoundary id' name objects) = do
- renderObjects <- mapM dfd objects
- return $ do
- blank
- 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 "}"
+bold :: String -> String
+bold s = "" ++ s ++ ""
- dfd (Function id' name) = return $ objectWith Brackets id' $ do
- writeln "shape = circle;"
- label $ bold $ write name
+italic :: String -> String
+italic s = "" ++ s ++ ""
- dfd (Database id' name) = return $ objectWith Brackets id' $ do
- label $
- table "sides=\"TB\" cellborder=\"0\"" $
- tr $
- td $
- bold $ write name
- writeln "shape = none;"
+convertObject :: C.Object -> StmtList
- 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 "]"
+convertObject (C.InputOutput id' name) = [
+ NodeStmt (ID id') [
+ Attr (ID "shape") (ID "square"),
+ Attr (ID "style") (ID "bold"),
+ label $ bold name
+ ]
+ ]
-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
+convertObject (C.TrustBoundary id' name objects) =
+ let sgId = (ID $ "cluster_" ++ id')
+ objectStmts = convertObjects objects
+ 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
+ in [SubgraphStmt $ Subgraph sgId stmts]
- writeln "labelloc = \"t\";"
- label $ bold $ write title
- writeln "fontsize = 20;"
+convertObject (C.Function id' name) =
+ [
+ NodeStmt (ID id') [
+ Attr (ID "shape") (ID "circle"),
+ label $ bold name
+ ]
+ ]
- writeln "nodesep = 1;"
- writeln "rankdir = LR;"
+convertObject (C.Database id' name) =
+ [
+ NodeStmt (ID id') [
+ Attr (ID "shape") (ID "none"),
+ label $ printf "" (bold name)
+ ]
+ ]
- sequence_ renderObjects
+convertObject (C.Flow i1 i2 op desc) =
+ [
+ EdgeStmt (EdgeExpr (IDOperand (NodeID (ID i1) Nothing))
+ Arrow
+ (IDOperand (NodeID (ID i2) Nothing))) [
+ label $
+ let d = if null desc then ""
+ else "" ++ desc ++ ""
+ in bold op ++ "
" ++ d
+ ]
+ ]
- writeln "}"
+convertObjects :: [C.Object] -> StmtList
+convertObjects = concatMap convertObject
--- | Generates the DFD output as a String.
-evalDfd :: Diagram -> String
-evalDfd d = evalDiagram (evalState (dfd d) Map.empty)
+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")
+ ]
--- | Prints the DFD output to stdout.
-printDfd :: Diagram -> IO ()
-printDfd = putStr . evalDfd
+asDFD :: C.Diagram -> Graph
+asDFD (C.Diagram (Just name) objects) =
+ normalize $ Digraph (ID $ inQuotes name) $
+ let lbl = EqualsStmt (ID "label") (ID $ inAngleBrackets $ bold name)
+ in lbl : defaultGraphStmts ++ convertObjects objects
+asDFD (C.Diagram Nothing objects) =
+ normalize $ Digraph (ID "Untitled") $
+ defaultGraphStmts ++ convertObjects objects
diff --git a/src/DataFlow/Graphviz.hs b/src/DataFlow/Graphviz.hs
new file mode 100644
--- /dev/null
+++ b/src/DataFlow/Graphviz.hs
@@ -0,0 +1,40 @@
+-- | DataFlow.Graphviz provides a model corresponding to the Graphviz language
+-- described at http://www.graphviz.org/content/dot-language. All features
+-- in the grammar are not supported.
+module DataFlow.Graphviz where
+
+newtype ID = ID String deriving (Eq, Ord)
+
+instance Show ID where
+ show (ID i) = i
+
+data Attr = Attr ID ID deriving (Show, Eq)
+type AttrList = [Attr]
+
+data Compass = N | NE | E | SE | S | SW | W | NW | C deriving (Show, Eq, Ord)
+
+data Port = Port (Maybe ID) Compass deriving (Show, Eq, Ord)
+
+data NodeID = NodeID ID (Maybe Port) deriving (Show, Eq, Ord)
+
+data Subgraph = Subgraph ID StmtList deriving (Show, Eq)
+
+data EdgeOperator = Arrow | Line deriving (Show, Eq)
+
+data EdgeOperand = IDOperand NodeID
+ | SubgraphOperand Subgraph deriving (Show, Eq)
+
+data EdgeExpr = EdgeExpr EdgeOperand EdgeOperator EdgeOperand deriving (Show, Eq)
+
+data AttrStmtType = Graph | Node | Edge deriving (Show, Eq)
+
+data Stmt = NodeStmt ID AttrList
+ | EdgeStmt EdgeExpr AttrList
+ | AttrStmt AttrStmtType AttrList
+ | EqualsStmt ID ID
+ | SubgraphStmt Subgraph deriving (Show, Eq)
+
+type StmtList = [Stmt]
+
+-- TODO: Support undirected graph
+data Graph = Digraph ID StmtList deriving (Show, Eq)
diff --git a/src/DataFlow/Graphviz/Renderer.hs b/src/DataFlow/Graphviz/Renderer.hs
new file mode 100644
--- /dev/null
+++ b/src/DataFlow/Graphviz/Renderer.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module DataFlow.Graphviz.Renderer (
+ renderGraphviz
+ ) where
+
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.Char
+import Text.Printf
+import DataFlow.Graphviz
+
+type Indent = Int
+type IndentNext = Bool
+type Step = Int
+data RendererState = RendererState Indent IndentNext Step
+
+-- | The Renderer represents some output generator that runs on a 'Diagram'.
+type Renderer t = WriterT [String] (State RendererState) t
+
+class Renderable t where
+ render :: t -> Renderer ()
+
+-- | Write a string to the output (no linefeed).
+write :: String -> Renderer ()
+write s = do
+ (RendererState n indentNext step) <- lift get
+ if indentNext
+ then tell [replicate n ' ' ++ s]
+ else tell [s]
+ put $ RendererState n False step
+
+-- | Write a string to the output (with linefeed).
+writeln :: String -> Renderer ()
+writeln s = do
+ write s
+ write "\n"
+ modify $ \(RendererState n _ s') -> RendererState n True s'
+
+-- | Increase indent with 2 spaces.
+indent :: Renderer ()
+indent = modify $ \(RendererState n indentNext s) -> RendererState (n + 2) indentNext s
+
+-- | Decrease indent with 2 spaces.
+dedent :: Renderer ()
+dedent = modify $ \(RendererState n indentNext s) -> RendererState (n - 2) indentNext s
+
+-- | Indent the output of gen with 2 spaces.
+withIndent :: Renderer () -> Renderer ()
+withIndent gen = do
+ indent
+ gen
+ dedent
+
+instance Renderable ID where
+ render (ID s) = write s
+
+instance Renderable Attr where
+ render (Attr i1 i2) = writeln $ printf "%s = %s;" (show i1) (show i2)
+
+instance Renderable AttrList where
+ render = mapM_ render
+
+instance Renderable Port where
+ render (Port (Just id') c) =
+ write $ printf "%s:%s" (show id') (map toLower $ show c)
+ render (Port Nothing c) =
+ write $ map toLower $ show c
+
+instance Renderable NodeID where
+ render (NodeID id' (Just port)) = do
+ render id'
+ write ":"
+ render port
+ render (NodeID id' Nothing) = render id'
+
+instance Renderable Subgraph where
+ render (Subgraph id' []) =
+ writeln $ printf "subgraph %s {}" (show id')
+ render (Subgraph id' stmts) = do
+ writeln $ printf "subgraph %s {" (show id')
+ withIndent $ render stmts
+ writeln "}"
+
+instance Renderable EdgeOperator where
+ render Arrow = write " -> "
+ render Line = write " -- "
+
+instance Renderable EdgeOperand where
+ render (IDOperand nodeId) = render nodeId
+ render (SubgraphOperand sg) = render sg
+
+instance Renderable EdgeExpr where
+ render (EdgeExpr o1 operator o2) = do
+ render o1
+ render operator
+ render o2
+
+instance Renderable AttrStmtType where
+ render = write . map toLower . show
+
+inBrackets :: Renderer () -> Renderer ()
+inBrackets r = do
+ writeln " ["
+ withIndent r
+ writeln "]"
+
+instance Renderable Stmt where
+ render (NodeStmt id' []) = do
+ render id'
+ writeln ""
+ render (NodeStmt id' attrs) = do
+ render id'
+ inBrackets $ render attrs
+ render (EdgeStmt expr []) = do
+ render expr
+ writeln ";"
+ render (EdgeStmt expr attrs) = do
+ render expr
+ inBrackets $ render attrs
+ render (AttrStmt t []) = do
+ render t
+ writeln " []"
+ render (AttrStmt t attrs) = do
+ render t
+ inBrackets $ render attrs
+ render (EqualsStmt i1 i2) = do
+ render i1
+ write " = "
+ render i2
+ writeln ";"
+ render (SubgraphStmt sg) = render sg
+
+instance Renderable StmtList where
+ render = mapM_ render
+
+instance Renderable Graph where
+ render (Digraph id' stmts) = do
+ writeln $ printf "digraph %s {" (show id')
+ withIndent $ render stmts
+ writeln "}"
+
+renderString :: Renderer () -> String
+renderString r =
+ concat $ evalState (execWriterT r) (RendererState 0 False 0)
+
+renderGraphviz :: Graph -> String
+renderGraphviz = renderString . render
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}