haphviz 0.1.0.2 → 0.1.1.1

raw patch · 11 files changed

+508/−115 lines, 11 filesdep +QuickCheckdep +checkersdep +haphvizdep ~basedep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, checkers, haphviz, hspec, quickcheck-text

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• haphviz.cabal +23/−3
• src/Text/Dot.hs +26/−0
• src/Text/Dot/Attributes.hs +46/−0
• src/Text/Dot/Attributes/Arrows.hs +72/−0
• src/Text/Dot/Attributes/Styles.hs +45/−0
• src/Text/Dot/FSA.hs +81/−0
• src/Text/Dot/Gen.hs +139/−55
• src/Text/Dot/Gen/FSA.hs +0/−55
• src/Text/Dot/Render.hs +7/−0
• src/Text/Dot/Types/Internal.hs +43/−2
• test/Spec.hs +26/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                haphviz-version:             0.1.0.2+version:             0.1.1.1 synopsis:            Graphviz code generation with Haskell description:   There are multiple ways to describe this package:@@ -11,6 +11,8 @@   - "A graph visualization code generation EDSL"   - "An easy way to draw graphs" +  If any combinators are still missing, feel free to shoot the maintainer an email!+ author:              Tom Sydney Kerckhove maintainer:          syd.kerckhove@gmail.com copyright:           Tom Sydney Kerckhove 2015@@ -26,9 +28,12 @@  library   exposed-modules:     Text.Dot-                       Text.Dot.Gen.FSA-  other-modules:       Text.Dot.Gen+                       Text.Dot.Gen+                       Text.Dot.FSA                        Text.Dot.Render+                       Text.Dot.Attributes+                       Text.Dot.Attributes.Arrows+                       Text.Dot.Attributes.Styles                        Text.Dot.Types.Internal   -- other-extensions:       build-depends:       base         >= 4.6   && <  4.10@@ -36,3 +41,18 @@                      , mtl          >= 2.2   && <  2.3   hs-source-dirs:      src   default-language:    Haskell2010++test-suite haphviz-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , haphviz+                     , hspec+                     , QuickCheck+                     , checkers+                     , quickcheck-text+                     , text+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+

@@ -1,4 +1,30 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Graphviz code-generation in Haskell+--+-- This can be used to generate graphviz code for large graph visualisations.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Text.Dot+-- >+-- > main :: IO ()+-- > main = renderToStdOut $ graph directed "example" $ do+-- >     a <- node "a"+-- >     b <- node "b"+-- >     a --> b+-- >     b --> a+-- >     b --> b+--+-- >>> runhaskell example.hs+-- > digraph example {+-- >   0 [label=<a>];+-- >   1 [label=<b>];+-- >   0 -> 1;+-- >   1 -> 0;+-- >   1 -> 1;+-- > }+--+-- module Text.Dot (       module Text.Dot.Gen     -- * Graph rendering

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Dot.Attributes (+      module Text.Dot.Attributes+    -- * Arrows+    , module Text.Dot.Attributes.Arrows+    -- * Styles+    , module Text.Dot.Attributes.Styles+    ) where++import           Text.Dot.Attributes.Arrows+import           Text.Dot.Attributes.Styles+import           Text.Dot.Types.Internal++-- * Attribute Names++label :: AttributeName+label = "label"++compound :: AttributeName+compound = "compound"++shape :: AttributeName+shape = "shape"++color :: AttributeName+color = "color"++dir :: AttributeName+dir = "dir"++width :: AttributeName+width = "width"++height :: AttributeName+height = "height"++-- * Attribute values++true :: AttributeValue+true = "true"++false :: AttributeValue+false = "false"++none :: AttributeValue+none = "none"

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Dot.Attributes.Arrows where++import           Text.Dot.Types.Internal++-- * Arrow attributes++arrowhead :: AttributeName+arrowhead = "arrowhead"++arrowtail :: AttributeName+arrowtail = "arrowtail"++-- * Arrow attribute values++box :: AttributeValue+box = "box"++circle :: AttributeValue+circle = "circle"++crow :: AttributeValue+crow = "crow"++diamond :: AttributeValue+diamond = "diamond"++dot :: AttributeValue+dot = "dot"++ediamond :: AttributeValue+ediamond = "ediamond"++empty :: AttributeValue+empty = "empty"++halfopen :: AttributeValue+halfopen = "halfopen"++inv :: AttributeValue+inv = "inv"++invdot :: AttributeValue+invdot = "invdot"++invempty :: AttributeValue+invempty = "invempty"++invodot :: AttributeValue+invodot = "invodot"++normal :: AttributeValue+normal = "normal"++obox :: AttributeValue+obox = "obox"++odiamond :: AttributeValue+odiamond = "odiamond"++odot :: AttributeValue+odot = "odot"++open :: AttributeValue+open = "open"++tee :: AttributeValue+tee = "tee"++vee :: AttributeValue+vee = "vee"+

@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Style attributes.+--+-- See http://www.graphviz.org/doc/info/attrs.html#k:style for more info on graphviz styles+module Text.Dot.Attributes.Styles where++import           Text.Dot.Types.Internal++-- * Style attributes++style :: AttributeName+style = "style"++-- * Style attribute values++bold :: AttributeValue+bold = "bold"++striped :: AttributeValue+striped = "striped"++filled :: AttributeValue+filled = "filled"++solid :: AttributeValue+solid = "solid"++dashed :: AttributeValue+dashed = "dashed"++dotted :: AttributeValue+dotted = "dotted"++rounded :: AttributeValue+rounded = "rounded"++-- ** Styles only for nodes++diagonals :: AttributeValue+diagonals = "diagonals"++wedged :: AttributeValue+wedged = "wedged"+

@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Easy FSA visualisation+module Text.Dot.FSA where++import           Text.Dot++import           Control.Monad (forM, forM_, when)+import           Data.Maybe    (fromMaybe, isNothing)++import           Data.Text+import qualified Data.Text     as T+import qualified Data.Text.IO  as T++-- | An easy way to generate an FSA visualization+--+-- You only need to specify the FSA definition and Haphviz takes care of the rest.+--+-- > main :: IO ()+-- > main = renderToStdOut $ fsaGraph+-- >             ["a", "b", "c"]+-- >             "a"+-- >             ["b"]+-- >             [("a", "b", "p"), ("b", "b", "q"), ("b", "c", "p")]+--+-- >>> runhaskell fsa.hs+-- > digraph haphviz {+-- >     node [width=<0>, height=<0>];+-- >     rankdir = LR;+-- >     0 [label=<a>];+-- >     1 [label=<b>, shape=<doublecircle>];+-- >     2 [label=<c>];+-- >     3 [style=<invis>];+-- >     3 -> 0;+-- >     0 -> 1 [label=<p>];+-- >     1 -> 1 [label=<q>];+-- >     1 -> 2 [label=<p>];+-- > }+--+--+fsaGraph :: [Text] -- ^ Set of states+          -> Text -- ^ Initial state+          -> [Text] -- ^ Accepting states+          -> [(Text, Text, Text)] -- ^ Edges: From, To, Symbol+          -> DotGraph+fsaGraph states initial accepting edges = graph_ directed $ do+    nodeDec [width =: "0", height =: "0"] -- Nodes as small as possible+    rankdir leftRight++    stateNodes <- forM states $ \s -> do+        n <- newNode+        genNode n $+            if s `elem` accepting+                then [label =: s, shape =: "doublecircle"]+                else [label =: s]+        return (s, n)++    -- Check that accepting states are actually states+    forM_ accepting $ \s -> do+        when+            (isNothing $ lookup s stateNodes)+            (error $ "Accepting state is not in the set of states: " ++ T.unpack s)++    -- Draw an edge from an invisible state to the initial state+    case lookup initial stateNodes of+        Nothing -> error "Initial state is not in the set of states"+        Just initialNode -> do+            n <- newNode+            genNode n ["style" =: "invis"]+            n --> initialNode++    -- Draw the edges+    forM_ edges $ \(from, to, symbol) -> do+        let fromNode = fromMaybe+                    (error $ "From node not found: " ++ T.unpack from)+                    (lookup from stateNodes)+        let toNode = fromMaybe+                    (error $ "To node not found: " ++ T.unpack to)+                    (lookup to stateNodes)+        genEdge fromNode toNode [label =: symbol]++

@@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-}+-- | Generating graph contents module Text.Dot.Gen (       module Text.Dot.Gen-    -- * Graph Types+    , module Text.Dot.Attributes+     , Dot     , DotGraph     , NodeId     , Attribute+    , AttributeName+    , AttributeValue     , DecType     , RankdirType     ) where@@ -13,6 +17,7 @@ import           Control.Monad.State     (StateT, execStateT, get, modify) import           Control.Monad.Writer    (WriterT, execWriterT, tell) +import           Text.Dot.Attributes import           Text.Dot.Types.Internal  import           Control.Monad           (void)@@ -21,45 +26,80 @@ import           Data.Text               (Text) import qualified Data.Text               as T -type DotGen = StateT State (WriterT Dot Identity) -type State = Int -- Next nameless node number---- | Generate graph+-- | Generate a haphviz graph with a given name and content+--+-- >>> graph directed "mygraph" $ do+--         a <- node "a"+--         b <- node "b"+--         a --> b+-- > graph mygraph {+-- >   0 [label="a"];+-- >   1 [label="b"];+-- >   0 -- 1;+-- > } graph :: GraphType-      -> GraphName -- ^ Graph name+      -> GraphName -- ^ Internal graph name       -> DotGen a  -- ^ Content       -> DotGraph graph gt gn func = Graph gt gn $ genDot func +-- | Like 'graph' but without an internal graph name+--+-- > graph_ gt func = graph gt "haphviz" func graph_ :: GraphType        -> DotGen a -- ^ Content        -> DotGraph graph_ gt func = graph gt "haphviz" func --- | Generate Internal dot AST+-- | Generate Internal dot content AST genDot :: DotGen a -> Dot genDot = genSubDot 0 +-- | Utility function to generate a graph with nameless nodes starting from a given starting number. genSubDot :: Int -> DotGen a -> Dot genSubDot n func = runIdentity $ execWriterT $ execStateT func n  -- * Graph types --- | Undirected graph+-- | Directed graph+--+-- >>> directed+-- > digraph directed :: GraphType directed = DirectedGraph --- | Directed graph+-- | Undirected graph+--+-- >>> undirected+-- > graph undirected :: GraphType undirected = UndirectedGraph  -- * Nodes+ -- | Most general node declaration+--+-- This allows you to specify a node identifier for the node.+--+-- In general it is more efficient to use nameless nodes and have the identifiers generated for you.+--+-- It also allows you to specify attributes.+-- In general it is better to use 'namelessNode'.+--+-- >>> n <- newNode+-- >>> genNode n [color =: green]+-- > 0 [color="green"]; genNode :: NodeId -> [Attribute] -> DotGen () genNode ni ats = tell $ Node ni ats --- | Node with given name and attributes+-- | Node with given (internal) name and attributes+--+-- Aside from human-readable output, there is no reason to use named nodes.+-- Use 'node' instead.+--+-- >>> void $ namedNode "woohoo" [color =: red]+-- > wohoo [color="red"]; namedNode :: Text -- ^ Name           -> [Attribute] -> DotGen NodeId namedNode t ats = do@@ -68,6 +108,12 @@     return ni  -- | Nameless node with attributes+--+-- This generates a nameless node for you but still allows you to specify its individual attributes.+-- In general it is better to use 'nodeDec' and then 'node'.+--+-- >>> void $ namelessNode [color =: blue]+-- > 0 [color="blue"]; namelessNode :: [Attribute] -> DotGen NodeId namelessNode ats = do     ni <- newNode@@ -75,17 +121,27 @@     return ni  -- | Node with a label but no other attributes+--+-- A node with a given label and no other attributes.+-- Usually used in conjunction with 'nodeDec'.+--+-- >>> void $ node "server"+-- > 0 [label="server"]; node :: Text -- ^ Label      -> DotGen NodeId node l = namelessNode [label =: l]  -- | Node with given node Id and label+--+-- > node_ ni l = genNode ni [label =: l] node_ :: NodeId -- ^ given Node ID       -> Text -- ^ Label       -> DotGen () node_ ni l = genNode ni [label =: l] --- Generate a new nameless node ID+-- | Generate a new internally nameless node ID+--+-- It is not generally a good idea to use this directly but it can be used to define node identifiers before a subgraph to reference them both in- and outside of it. newNode :: DotGen NodeId newNode = do     i <- get@@ -96,58 +152,46 @@ -- * Edges  -- | Most general edge declaration+--+-- This allows you to specify attributes for a single edge.+--+-- Usually it is better to use 'edgeDec' and then '-->'.+--+-- >>> genEdge a b [label =: "MyEdge"]+-- > a -> b [label="MyEdge"]; genEdge :: NodeId -> NodeId -> [Attribute] -> DotGen () genEdge n1 n2 ats = tell $ Edge n1 n2 ats   -- | Infix edge constructor. (No attributes)+--+-- This takes care of using the right edge declaration for the given graph.+--+-- For undirected graphs, the output would be @--@ ...+--+-- >>> a --> b+-- > a -- b;+--+-- ... and for directed graphs it would be @->@.+--+-- >>> a --> b+-- > a -> b; (-->) :: NodeId -> NodeId -> DotGen () n1 --> n2 = genEdge n1 n2 []  -- * Attributes  -- | Infix operator for an attribute pair+--+-- >>> [label =: "MyNode"]+-- > [label="MyNode"] (=:) :: AttributeName -> AttributeValue -> Attribute (=:) = (,) --- ** Attribute Names -label :: AttributeName-label = "label"--compound :: AttributeName-compound = "compound"--shape :: AttributeName-shape = "shape"--color :: AttributeName-color = "color"--dir :: AttributeName-dir = "dir"--width :: AttributeName-width = "width"--height :: AttributeName-height = "height"---- ** Attribute values--true :: AttributeValue-true = "true"--false :: AttributeValue-false = "false"--none :: AttributeValue-none = "none"-- -- * Declarations --- | General declaration of attributes+-- | General declaration of common attributes genDec :: DecType -> [Attribute] -> DotGen () genDec t ats = tell $ Declaration t ats @@ -175,41 +219,81 @@  -- * Subgraphs --- | Subgraph-subgraph :: Text -> DotGen () -> DotGen GraphName-subgraph name content = do-    n <- get-    let c = genSubDot n content-    tell $ Subgraph name c-    return name --- | Cluster+-- | Cluster with a given name+--+-- The @cluster_@ prefix is taken care of. cluster :: Text -> DotGen () -> DotGen GraphName cluster name = subgraph $ "cluster_" <> name --- | Cluster, discarding the graph name+-- | Like 'cluster', discarding the graph name. cluster_ :: Text -> DotGen () -> DotGen () cluster_ name subgraph = void $ cluster name subgraph +-- | Subgraph declaration+--+-- This is rarely useful. Just use 'cluster'.+subgraph :: Text -> DotGen () -> DotGen GraphName+subgraph name content = do+    n <- get+    let c = genSubDot n content+    tell $ Subgraph name c+    return name+ -- * Miscelaneous -- ** Rankdir++-- | The rankdir declaration+--+--  This changes the default layout of nodes+--+-- >>> rankdir leftRight+-- > rankdir = LR; rankdir :: RankdirType -> DotGen () rankdir = tell . Rankdir +-- |+-- >>> leftRight+-- > LR leftRight :: RankdirType leftRight = LR +-- |+-- >>> rightLeft+-- > RL+rightLeft :: RankdirType+rightLeft = RL++-- |+-- >>> topBottom+-- > TB topBottom :: RankdirType topBottom = TB +-- |+-- >>> bottomTop+-- > BT+bottomTop :: RankdirType+bottomTop = BT+ -- ** Labels -- | Label declaration for graphs or subgraphs labelDec :: Text -> DotGen () labelDec = tell . Label  -- ** Ports++-- | Use a certain port on a given node's label as an endpoint for an edge (.:) :: NodeId      -> Text -- ^ Port      -> NodeId (UserId t) .: p = UserId $ t <> ":" <> p (Nameless i) .: p = UserId $ T.pack (show i) <> ":" <> p++-- * Internals+-- | Generation monad+type DotGen = StateT State (WriterT Dot Identity)++-- | The next id for a nameless node+type State = Int+

@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text.Dot.Gen.FSA where--import           Text.Dot--import           Control.Monad (forM, forM_, when)-import           Data.Maybe    (fromMaybe, isNothing)--import           Data.Text-import qualified Data.Text     as T-import qualified Data.Text.IO  as T---- | An easy way to generate an FSA visualization-fsaGraph :: [Text] -- ^ Set of states-          -> Text -- Initial state-          -> [Text] -- Accepting states-          -> [(Text, Text, Text)] -- ^ Edges: From, To, Symbol-          -> DotGraph-fsaGraph states initial accepting edges = graph_ directed $ do-    nodeDec [width =: "0", height =: "0"] -- Nodes as small as possible-    rankdir leftRight--    stateNodes <- forM states $ \s -> do-        n <- newNode-        genNode n $-            if s `elem` accepting-                then [label =: s, shape =: "doublecircle"]-                else [label =: s]-        return (s, n)--    -- Check that accepting states are actually states-    forM_ accepting $ \s -> do-        when-            (isNothing $ lookup s stateNodes)-            (error $ "Accepting state is not in the set of states: " ++ T.unpack s)--    -- Draw an edge from an invisible state to the initial state-    case lookup initial stateNodes of-        Nothing -> error "Initial state is not in the set of states"-        Just initialNode -> do-            n <- newNode-            genNode n ["style" =: "invis"]-            n --> initialNode--    -- Draw the edges-    forM_ edges $ \(from, to, symbol) -> do-        let fromNode = fromMaybe-                    (error $ "From node not found: " ++ T.unpack from)-                    (lookup from stateNodes)-        let toNode = fromMaybe-                    (error $ "To node not found: " ++ T.unpack to)-                    (lookup to stateNodes)-        genEdge fromNode toNode [label =: symbol]--

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Rendering Graphviz code from Haphviz graphs module Text.Dot.Render (       renderGraph     , renderToFile@@ -20,12 +22,15 @@  type Render = ReaderT GraphType (StateT Int (WriterT Text Identity)) +-- | Render a given graph and write the result to the given file renderToFile :: FilePath -> DotGraph -> IO () renderToFile file g = T.writeFile file $ renderGraph g +-- | Render a given graph and print it to std out renderToStdOut :: DotGraph -> IO () renderToStdOut = T.putStrLn . renderGraph +-- | Render a graph to graphviz code renderGraph :: DotGraph -> Text renderGraph (Graph gtype name content) = mconcat     [ "digraph"@@ -139,6 +144,8 @@  renderRankDirType :: RankdirType -> Render () renderRankDirType TB = tell "TB"+renderRankDirType BT = tell "BT"+renderRankDirType RL = tell "RL" renderRankDirType LR = tell "LR"  indent :: Render ()

@@ -1,5 +1,10 @@+-- | Internal types.+--+-- You may want to keep off these. module Text.Dot.Types.Internal (       module Text.Dot.Types.Internal+    -- * Re-exports+     , Identity(..)     , Monoid(..)     ) where@@ -14,31 +19,54 @@ import           Control.Monad.Writer   (WriterT, execWriterT, tell)  +-- | Internal name of a graph, used to reference graphs and subgraphs type GraphName = Text++-- | Type of a graph, directed or undirected.+--+-- This also specifies what edge declarations look like. data GraphType = UndirectedGraph                | DirectedGraph     deriving (Show, Eq) +-- | Attribute name: just text type AttributeName = Text++-- | Attribute value: just text type AttributeValue = Text-type Attribute = (Text, Text) +-- | Attribute: a tuple of name and value.+type Attribute = (AttributeName, AttributeValue)++-- | A node identifier.+--+-- This is either a user supplied name or a generated numerical identifier. data NodeId = UserId Text             | Nameless Int     deriving (Show, Eq) +-- | Declaration type+--+-- Used to declare common attributes for nodes or edges. data DecType = DecGraph              | DecNode              | DecEdge     deriving (Show, Eq) +-- | A Haphviz Graph data DotGraph = Graph GraphType GraphName Dot     deriving (Show, Eq) +-- | Rankdir Type+--+-- Used to specify the default node layout direction data RankdirType = LR+                 | RL                  | TB+                 | BT     deriving (Show, Eq) +-- | Haphviz internal graph content AST data Dot = Node NodeId [Attribute]          | Edge NodeId NodeId [Attribute]          | Declaration DecType [Attribute]@@ -50,6 +78,19 @@          | DotEmpty     deriving (Show, Eq) +-- | Dot is a monoid, duh, that's the point. instance Monoid Dot where-    mappend d1 d2 = DotSeq d1 d2     mempty = DotEmpty++    -- Left identity+    mappend DotEmpty d = d++    -- Right identity+    mappend d DotEmpty = d++    -- Associativity+    mappend d (DotSeq d1 d2) = DotSeq (mappend d d1) d2++    mappend d1 d2 = DotSeq d1 d2++

@@ -0,0 +1,26 @@+import           Text.Dot.Types.Arbitrary+import           Text.Dot.Types.Internal++import           Control.Exception        (evaluate)+import           Control.Monad            (forM_)+import           Test.Hspec+import           Test.QuickCheck+import           Test.QuickCheck.Checkers+import           Test.QuickCheck.Classes  (monoid)+++main :: IO ()+main = hspec $ do+    describe "Dot" $ do+        batch "is a Monoid" $ monoid (undefined :: Dot)++-- Recall:+-- type TestBatch = (String, [Test])+-- type Test = (String, Property)+batch :: String -> TestBatch -> Spec+batch str (name, ts) =+    describe str $+        forM_ ts $ \(tname, p) ->+            it tname $ property p++