diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,24 @@ -The MIT License (MIT) - -Copyright (c) 2015 Oskar Wickström - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: +Copyright (c) 2015, Sony Mobile AB +All rights reserved. -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,63 +1,45 @@ # DataFlow -Generate Graphviz documents from a Haskell representation. - -## Getting Started +Render graphs using a declarative markup. Currently supports DFD +(http://en.wikipedia.org/wiki/Data_flow_diagram) and sequence diagrams +(http://plantuml.sourceforge.net/sequence.html). -``` -cabal install dataflow@0.6.0.0 -``` +![DFD Output](examples/webapp.dfd.png) ## Usage -![Legend](https://rawgit.com/owickstrom/dataflow/master/examples/legend.svg) - -The objects supported by DataFlow is: +So you want to you use DataFlow? Then please read [Usage](USAGE.md). -* `boundary` -* `io` -* `function` -* `database` -* `->` +## Setup -These are composed in a `diagram` to get something printable. +```bash +cabal sandbox init # optional +cabal install --only-dependencies --enable-tests +cabal configure --enable-tests +``` -## Example +## Build +```bash +cabal build ``` -diagram 'Webapp' { - boundary 'Browser' { - function client 'Client' - } - boundary 'Amazon AWS' { - function server 'Web Server' - database logs 'Logs' - } - io analytics 'Google
Analytics' - client -> server 'Request /' '' - server -> logs 'Log' 'User IP' - server -> client 'Response' 'User Profile' - client -> analytics 'Log' 'Page Navigation' -} -``` +## Install -Then generate your output with dot. +If you initialized a sandbox the executable will end up in the sandbox, i.e. +`.cabal-sandbox/bin/dataflow`. If you have no sandbox it will end up in +`~/.cabal/bin/dataflow`. If you get any stange errors during install try a `cabal clean` ```bash -dataflow dfd webapp.flow | dot -Tsvg > webapp.svg +cabal install ``` -That should generate something like the following. - -![Example Output](https://rawgit.com/owickstrom/dataflow/master/examples/webapp.svg) - -## Build +## Tests -``` -cabal sandbox init -cabal configure --enable-tests -cabal install --only-dependencies --enable-tests +```bash +./run-tests.sh +# or... +./watch-tests.sh ``` ## Building the Examples @@ -65,12 +47,7 @@ ```bash make -C examples ``` -## Haskell Docs -See [the Hackage site](https://hackage.haskell.org/package/dataflow). - -## Release +## License -```bash -cabal clean && cabal build && cabal sdist && cabal upload dist/dataflow-*.tar.gz -``` +BSD-3, see [LICENSE](LICENSE). diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -1,15 +1,16 @@ module Main where import System.Environment -import DataFlow.Core import DataFlow.Reader import DataFlow.DFD +import DataFlow.SequenceDiagram import DataFlow.Graphviz.Renderer +import DataFlow.PlantUML.Renderer data Command = DFD | Lint usage :: String -usage = "Usage: dataflow (dfd|lint) FILE" +usage = "Usage: dataflow (dfd|seq) FILE" dfd :: FilePath -> IO () dfd path = do @@ -18,9 +19,18 @@ (Left err) -> print err (Right diagram) -> putStr $ renderGraphviz $ asDFD diagram +seq' :: FilePath -> IO () +seq' path = do + res <- readDiagramFile path + case res of + (Left err) -> print err + (Right diagram) -> putStr $ renderPlantUML $ asSequenceDiagram diagram + + main :: IO () main = do args <- getArgs case args of ["dfd", path] -> dfd path + ["seq", path] -> seq' path _ -> fail usage diff --git a/dataflow.cabal b/dataflow.cabal --- a/dataflow.cabal +++ b/dataflow.cabal @@ -1,46 +1,51 @@ name: dataflow -version: 0.6.0.0 +version: 0.6.1.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 - (http://en.wikipedia.org/wiki/Data_flow_diagram). Support - for a Graphviz-like input format (instead of using the - data structures in Haskell) is planned. -homepage: https://github.com/owickstrom/dataflow -license: MIT +description: Render graphs using a declarative markup. Currently + supports DFD (http://en.wikipedia.org/wiki/Data_flow_diagram) + and sequence diagrams (http://plantuml.sourceforge.net/sequence.html). +homepage: https://github.com/sonyxperiadev/dataflow +license: BSD3 license-file: LICENSE -author: Oskar Wickström +author: Oskar Wickström (Sony Mobile Communications) maintainer: oskar.wickstrom@gmail.com -copyright: oskar.wickstrom@gmail.com +copyright: Sony Mobile Communications category: Code Generation, Compiler, Graphs build-type: Simple extra-source-files: README.md, LICENSE, examples/webapp.flow, - examples/webapp.svg, + examples/webapp.seq.png, + examples/webapp.dfd.png, examples/legend.flow, - examples/legend.svg, + examples/legend.seq.png, + examples/legend.dfd.png, examples/Makefile cabal-version: >=1.10 source-repository head type: git - location: git@github.com:owickstrom/dataflow.git + location: git@github.com:sonyxperiadev/dataflow.git library exposed-modules: DataFlow.Core, DataFlow.Reader, + DataFlow.PrettyRenderer, DataFlow.Graphviz, DataFlow.Graphviz.EdgeNormalization, DataFlow.Graphviz.Renderer, + DataFlow.PlantUML, + DataFlow.PlantUML.Renderer, + DataFlow.SequenceDiagram, DataFlow.DFD build-depends: base >=4 && <4.8, mtl >=2.2, containers >= 0.4, - parsec + MissingH, + parsec >= 3.1.9 hs-source-dirs: src default-language: Haskell2010 diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,17 +1,27 @@ SOURCES=$(shell find *.flow) -TARGETS=$(SOURCES:%.flow=%.svg) +DFD_TARGETS=$(SOURCES:%.flow=%.dfd.png) +SEQ_TARGETS=$(SOURCES:%.flow=%.seq.png) DATAFLOW=../dist/build/DataFlow/dataflow +PLANTUML=/tmp/dataflow-build/plantuml.jar $(DATAFLOW): cd .. && cabal build -%.svg: %.flow $(DATAFLOW) +$(PLANTUML): + @mkdir -p /tmp/dataflow-build + @wget -qO $(PLANTUML) "http://downloads.sourceforge.net/project/plantuml/plantuml.jar?r=http%3A%2F%2Fsourceforge.net%2Fprojects%2Fplantuml%2F%3Fsource%3Dtyp_redirect&ts=1428479663&use_mirror=freefr" + +%.dfd.png: %.flow $(DATAFLOW) @echo "$< -> $@" - @$(DATAFLOW) dfd $< | dot -Nfontname=Courier -Efontname=Courier -Tsvg > $@ + @$(DATAFLOW) dfd $< | dot -Tpng > $@ -svg: $(TARGETS) +%.seq.png: %.flow $(DATAFLOW) $(PLANTUML) + @echo "$< -> $@" + @$(DATAFLOW) seq $< | java -Djava.awt.headless=true -jar $(PLANTUML) -tpng -pipe > $@ +png: $(DFD_TARGETS) $(SEQ_TARGETS) + clean: - rm -f $(TARGETS) + rm -f $(DFD_TARGETS) $(SEQ_TARGETS) -all: svg +all: png diff --git a/examples/legend.dfd.png b/examples/legend.dfd.png new file mode 100644 Binary files /dev/null and b/examples/legend.dfd.png differ diff --git a/examples/legend.flow b/examples/legend.flow --- a/examples/legend.flow +++ b/examples/legend.flow @@ -5,7 +5,7 @@ io i 'io' } - f -> d 'Data' 'Description' - i -> f '' 'Description' - f -> i 'Data' '' + f -> d 'Operation' 'Data' + i -> f '' 'Data' + f -> i 'Operation' '' } diff --git a/examples/legend.seq.png b/examples/legend.seq.png new file mode 100644 Binary files /dev/null and b/examples/legend.seq.png differ diff --git a/examples/legend.svg b/examples/legend.svg deleted file mode 100644 --- a/examples/legend.svg +++ /dev/null @@ -1,54 +0,0 @@ - - - - - - - -cluster_boundary - -boundary - - -f - -function - - -i - -io - - -f->i - - -(2) -Description - - -f->i - - -(3) -Data - - -d -database - - - - -d->f - - -(1) -Data -Description - - - diff --git a/examples/webapp.dfd.png b/examples/webapp.dfd.png new file mode 100644 Binary files /dev/null and b/examples/webapp.dfd.png differ diff --git a/examples/webapp.flow b/examples/webapp.flow --- a/examples/webapp.flow +++ b/examples/webapp.flow @@ -11,5 +11,5 @@ client -> server 'Request /' '' server -> logs 'Log' 'User IP' server -> client 'Response' 'User Profile' - analytics <- client 'Log' 'Page Navigation' + analytics <- client 'Log' 'Page
Navigation' } diff --git a/examples/webapp.seq.png b/examples/webapp.seq.png new file mode 100644 Binary files /dev/null and b/examples/webapp.seq.png differ diff --git a/examples/webapp.svg b/examples/webapp.svg deleted file mode 100644 --- a/examples/webapp.svg +++ /dev/null @@ -1,75 +0,0 @@ - - - - - - -Webapp - -Webapp -cluster_browser - -Browser - -cluster_amazonaws - -Amazon AWS - - -client - -Client - - -server - -Web Server - - -server->client - - -(1) -Request / - - -server->client - - -(3) -Response -User Profile - - -logs -Logs - - - - -logs->server - - -(2) -Log -User IP - - -analytics - -Google -Analytics - - -analytics->client - - -(4) -Log -Page Navigation - - - diff --git a/src/DataFlow/DFD.hs b/src/DataFlow/DFD.hs --- a/src/DataFlow/DFD.hs +++ b/src/DataFlow/DFD.hs @@ -26,8 +26,8 @@ inAngleBrackets s = "<" ++ s ++ ">" label :: String -> Attr -label "" = Attr (ID "label") (ID "") -label s = Attr (ID "label") (ID $ inAngleBrackets s) +label "" = Attr "label" "" +label s = Attr "label" $ inAngleBrackets s bold :: String -> String bold "" = "" @@ -48,36 +48,36 @@ convertObject :: C.Object -> DFD StmtList convertObject (C.InputOutput id' name) = return [ - NodeStmt (ID id') [ - Attr (ID "shape") (ID "square"), - Attr (ID "style") (ID "bold"), + NodeStmt id' [ + Attr "shape" "square", + Attr "style" "bold", label $ printf "
%s
" (bold name) ] ] convertObject (C.TrustBoundary id' name objects) = do objectStmts <- convertObjects objects - let sgId = ID $ "cluster_" ++ id' + let sgId = "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"), + Attr "fontsize" "10", + Attr "fontcolor" "grey35", + Attr "style" "dashed", + Attr "color" "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"), + NodeStmt id' [ + Attr "shape" "circle", label $ bold name ] ] convertObject (C.Database id' name) = return [ - NodeStmt (ID id') [ - Attr (ID "shape") (ID "none"), + NodeStmt id' [ + Attr "shape" "none", label $ printf "
%s
" (bold name) ] ] @@ -86,9 +86,9 @@ step <- nextStep let stepStr = color "#3184e4" $ bold $ printf "(%d) " step return [ - EdgeStmt (EdgeExpr (IDOperand (NodeID (ID i1) Nothing)) + EdgeStmt (EdgeExpr (IDOperand (NodeID i1 Nothing)) Arrow - (IDOperand (NodeID (ID i2) Nothing))) [ + (IDOperand (NodeID i2 Nothing))) [ label $ stepStr ++ bold op ++ "
" ++ small desc ] ] @@ -99,35 +99,35 @@ defaultGraphStmts :: StmtList defaultGraphStmts = [ AttrStmt Graph [ - Attr (ID "fontname") (ID "Arial"), - Attr (ID "fontsize") (ID "14") + Attr "fontname" "Arial", + Attr "fontsize" "14" ], AttrStmt Node [ - Attr (ID "fontname") (ID "Arial"), - Attr (ID "fontsize") (ID "14") + Attr "fontname" "Arial", + Attr "fontsize" "14" ], AttrStmt Edge [ - Attr (ID "shape") (ID "none"), - Attr (ID "fontname") (ID "Arial"), - Attr (ID "fontsize") (ID "12") + Attr "shape" "none", + Attr "fontname" "Arial", + Attr "fontsize" "12" ], - EqualsStmt (ID "labelloc") (ID $ inQuotes "t"), - EqualsStmt (ID "fontsize") (ID "20"), - EqualsStmt (ID "nodesep") (ID "1"), - EqualsStmt (ID "rankdir") (ID "t") + EqualsStmt "labelloc" (inQuotes "t"), + EqualsStmt "fontsize" "20", + EqualsStmt "nodesep" "1", + EqualsStmt "rankdir" "t" ] convertDiagram :: C.Diagram -> DFD Graph convertDiagram (C.Diagram (Just name) objects) = do - let lbl = EqualsStmt (ID "label") (ID $ inAngleBrackets $ bold name) + let lbl = EqualsStmt "label" (inAngleBrackets $ bold name) objs <- convertObjects objects let stmts = lbl : defaultGraphStmts ++ objs - return $ normalize $ Digraph (ID $ inQuotes name) stmts + return $ normalize $ Digraph (inQuotes name) stmts convertDiagram (C.Diagram Nothing objects) = do objs <- convertObjects objects - return $ normalize $ Digraph (ID "Untitled") $ defaultGraphStmts ++ objs + return $ normalize $ Digraph "Untitled" $ defaultGraphStmts ++ objs asDFD :: C.Diagram -> Graph asDFD d = evalState (convertDiagram d) 0 diff --git a/src/DataFlow/Graphviz.hs b/src/DataFlow/Graphviz.hs --- a/src/DataFlow/Graphviz.hs +++ b/src/DataFlow/Graphviz.hs @@ -3,10 +3,7 @@ -- 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 +type ID = String data Attr = Attr ID ID deriving (Show, Eq) type AttrList = [Attr] diff --git a/src/DataFlow/Graphviz/EdgeNormalization.hs b/src/DataFlow/Graphviz/EdgeNormalization.hs --- a/src/DataFlow/Graphviz/EdgeNormalization.hs +++ b/src/DataFlow/Graphviz/EdgeNormalization.hs @@ -33,7 +33,7 @@ normalizeStmt e@(EdgeStmt (EdgeExpr (IDOperand i1) op (IDOperand i2)) attrs) = do i <- shouldInvert (i1, i2) return $ if i then EdgeStmt (EdgeExpr (IDOperand i2) op (IDOperand i1)) - (Attr (ID "dir") (ID "back") : attrs) + (Attr "dir" "back" : attrs) else e normalizeStmt (SubgraphStmt (Subgraph id' stmts)) = do diff --git a/src/DataFlow/Graphviz/Renderer.hs b/src/DataFlow/Graphviz/Renderer.hs --- a/src/DataFlow/Graphviz/Renderer.hs +++ b/src/DataFlow/Graphviz/Renderer.hs @@ -1,62 +1,20 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} module DataFlow.Graphviz.Renderer ( renderGraphviz ) where -import Control.Monad.State -import Control.Monad.Writer import Data.Char import Text.Printf +import DataFlow.PrettyRenderer 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) + render (Attr i1 i2) = writeln $ printf "%s = %s;" i1 i2 instance Renderable AttrList where render = mapM_ render @@ -69,16 +27,16 @@ instance Renderable NodeID where render (NodeID id' (Just port)) = do - render id' + write id' write ":" render port - render (NodeID id' Nothing) = render id' + render (NodeID id' Nothing) = write id' instance Renderable Subgraph where render (Subgraph id' []) = - writeln $ printf "subgraph %s {}" (show id') + writeln $ printf "subgraph %s {}" id' render (Subgraph id' stmts) = do - writeln $ printf "subgraph %s {" (show id') + writeln $ printf "subgraph %s {" id' withIndent $ render stmts writeln "}" @@ -107,10 +65,10 @@ instance Renderable Stmt where render (NodeStmt id' []) = do - render id' + write id' writeln "" render (NodeStmt id' attrs) = do - render id' + write id' inBrackets $ render attrs render (EdgeStmt expr []) = do render expr @@ -125,9 +83,9 @@ render t inBrackets $ render attrs render (EqualsStmt i1 i2) = do - render i1 + write i1 write " = " - render i2 + write i2 writeln ";" render (SubgraphStmt sg) = render sg @@ -136,13 +94,9 @@ instance Renderable Graph where render (Digraph id' stmts) = do - writeln $ printf "digraph %s {" (show id') + writeln $ printf "digraph %s {" id' withIndent $ render stmts writeln "}" -renderString :: Renderer () -> String -renderString r = - concat $ evalState (execWriterT r) (RendererState 0 False 0) - renderGraphviz :: Graph -> String -renderGraphviz = renderString . render +renderGraphviz = renderWithIndent . render diff --git a/src/DataFlow/PlantUML.hs b/src/DataFlow/PlantUML.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/PlantUML.hs @@ -0,0 +1,15 @@ +module DataFlow.PlantUML where + +type ID = String +type Name = String + +data Stmt = SkinParam String String + | Box Name StmtList + | Participant ID Name + | Database ID Name + | Entity ID Name + | Edge ID ID String deriving (Show, Eq) + +type StmtList = [Stmt] + +data Diagram = SequenceDiagram StmtList deriving (Show, Eq) diff --git a/src/DataFlow/PlantUML/Renderer.hs b/src/DataFlow/PlantUML/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/PlantUML/Renderer.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module DataFlow.PlantUML.Renderer ( + renderPlantUML + ) where + +import Text.Printf +import DataFlow.PrettyRenderer +import DataFlow.PlantUML + +class Renderable t where + render :: t -> Renderer () + +instance Renderable Stmt where + render (SkinParam name value) = do + write "skinparam " + write name + write " " + writeln value + render (Box name stmts) = do + writeln $ printf "box \"%s\"" name + withIndent $ render stmts + writeln "end box" + render (Participant id' name) = + writeln $ printf "participant \"%s\" as %s" name id' + render (Database id' name) = + writeln $ printf "database \"%s\" as %s" name id' + render (Entity id' name) = + writeln $ printf "entity \"%s\" as %s" name id' + render (Edge i1 i2 description) = + writeln $ printf "%s -> %s : %s" i1 i2 description + + +instance Renderable StmtList where + render = mapM_ render + +instance Renderable Diagram where + render (SequenceDiagram stmts) = do + writeln "@startuml" + render stmts + writeln "@enduml" + +renderPlantUML :: Diagram -> String +renderPlantUML = renderWithIndent . render diff --git a/src/DataFlow/PrettyRenderer.hs b/src/DataFlow/PrettyRenderer.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/PrettyRenderer.hs @@ -0,0 +1,46 @@ +module DataFlow.PrettyRenderer where + +import Control.Monad.State +import Control.Monad.Writer + +type Indent = Int +type IndentNext = Bool +data RendererState = RendererState Indent IndentNext + +-- | The Renderer represents some output generator that runs on a 'Diagram'. +type Renderer t = WriterT [String] (State RendererState) t + +-- | Write a string to the output (no linefeed). +write :: String -> Renderer () +write s = do + (RendererState n indentNext) <- lift get + if indentNext + then tell [replicate n ' ' ++ s] + else tell [s] + put $ RendererState n False + +-- | Write a string to the output (with linefeed). +writeln :: String -> Renderer () +writeln s = do + write s + write "\n" + modify $ \(RendererState n _) -> RendererState n True + +-- | Increase indent with 2 spaces. +indent :: Renderer () +indent = modify $ \(RendererState n indentNext) -> RendererState (n + 2) indentNext + +-- | Decrease indent with 2 spaces. +dedent :: Renderer () +dedent = modify $ \(RendererState n indentNext) -> RendererState (n - 2) indentNext + +-- | Indent the output of gen with 2 spaces. +withIndent :: Renderer () -> Renderer () +withIndent gen = do + indent + gen + dedent + +renderWithIndent :: Renderer () -> String +renderWithIndent r = + concat $ evalState (execWriterT r) (RendererState 0 False) diff --git a/src/DataFlow/SequenceDiagram.hs b/src/DataFlow/SequenceDiagram.hs new file mode 100644 --- /dev/null +++ b/src/DataFlow/SequenceDiagram.hs @@ -0,0 +1,83 @@ +module DataFlow.SequenceDiagram where + +import Text.Printf +import qualified DataFlow.Core as C +import DataFlow.PlantUML +import Data.List.Utils + +convertNewline :: String -> String +convertNewline = replace "
" "\\n" + +bold :: String -> String +bold "" = "" +bold s = printf "%s" s + +italic :: String -> String +italic "" = "" +italic s = + -- each line (separated by \n) needs to be wrapped in its own + join "\\n" $ map italic' $ split "\\n" s + where italic' = printf "%s" + +convertObject :: C.Object -> Stmt +convertObject (C.InputOutput id' name) = + Entity id' $ convertNewline name +convertObject (C.TrustBoundary _ name objects) = + Box (convertNewline name) $ map convertObject objects +convertObject (C.Function id' name) = + Participant id' $ convertNewline name +convertObject (C.Database id' name) = + Database id' $ convertNewline name +convertObject (C.Flow i1 i2 op desc) = + let p = (convertNewline (bold op), italic $ convertNewline desc) + s = case p of + ("", "") -> "" + ("", d) -> d + (o, "") -> o + (o, d) -> o ++ "\\n" ++ d + in Edge i1 i2 s + +defaultSkinParams :: [Stmt] +defaultSkinParams = [ + SkinParam "BackgroundColor" "#white", + SkinParam "Shadowing" "false", + SkinParam "SequenceMessageAlign" "center", + SkinParam "DefaultFontName" "Arial", + SkinParam "DefaultFontStyle" "bold", + SkinParam "DefaultFontColor" "#333333", + + SkinParam "NoteBackgroundColor" "#fbfb77", + SkinParam "NoteBorderColor" "#cbcb47", + + SkinParam "NoteBackgroundColor" "#ffffcd", + SkinParam "NoteBorderColor" "#a9a980", + SkinParam "NoteFontColor" "#676735", + SkinParam "NoteFontStyle" "italic", + + SkinParam "SequenceArrowColor" "#555555", + SkinParam "SequenceArrowFontColor" "#555555", + SkinParam "SequenceArrowFontStyle" "none", + + SkinParam "SequenceBoxBackgroundColor" "#fafafa", + SkinParam "SequenceBoxBorderColor" "#eeeeee", + SkinParam "SequenceBoxFontColor" "#666666", + SkinParam "SequenceBoxFontSize" "12", + SkinParam "SequenceBoxFontStyle" "italic", + + SkinParam "ParticipantBackgroundColor" "#dde5ff", + SkinParam "ParticipantBorderColor" "#cccccc", + SkinParam "ParticipantFontColor" "#333333", + SkinParam "ParticipantFontStyle" "bold", + + SkinParam "DatabaseBackgroundColor" "#df4646", + SkinParam "DatabaseFontColor" "#red", + SkinParam "DatabaseFontStyle" "bold", + + SkinParam "EntityBackgroundColor" "#999999", + + SkinParam "SequenceLifeLineBorderColor" "#bbbbbb" + ] + +asSequenceDiagram :: C.Diagram -> Diagram +asSequenceDiagram (C.Diagram _ objects) = + SequenceDiagram $ defaultSkinParams ++ map convertObject objects