diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +## 0.4.2 +* Fixed build with GHC 7.10 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# dotgen [![Hackage version](https://img.shields.io/hackage/v/dotgen.svg?style=flat)](http://hackage.haskell.org/package/dotgen) [![Build Status](https://img.shields.io/travis/ku-fpg/dotgen.svg?style=flat)](https://travis-ci.org/ku-fpg/dotgen) + +A simple interface for building .dot graph files. + +This package provides a simple interface for building .dot graph files, for input into the `dot` and `graphviz` tools. It includes a monadic interface for building graphs. diff --git a/Text/Dot.hs b/Text/Dot.hs --- a/Text/Dot.hs +++ b/Text/Dot.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | -- Module: Text.Dot -- Copyright: Andy Gill @@ -11,64 +13,76 @@ -- It includes a monadic interface for building graphs. module Text.Dot - ( - -- * Dot - Dot -- abstract - -- * Nodes - , node - , NodeId -- abstract - , userNodeId - , userNode - -- * Edges - , edge + ( + -- * Dot + Dot -- abstract + -- * Nodes + , node + , NodeId -- abstract + , userNodeId + , userNode + -- * Edges + , edge , edge' - , (.->.) - -- * Showing a graph - , showDot - -- * Other combinators - , scope - , attribute - , share - , same - , cluster - -- * Simple netlist generation - , netlistGraph - ) where + , (.->.) + -- * Showing a graph + , showDot + -- * Other combinators + , scope + , attribute + , share + , same + , cluster + -- * Simple netlist generation + , netlistGraph + ) where +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +#endif +import Control.Monad import Data.Char import qualified Data.Map as M import qualified Data.Set as S -data DotGraph = DotGraph [GraphElement] +-- data DotGraph = DotGraph [GraphElement] data NodeId = NodeId String - | UserNodeId Int + | UserNodeId Int instance Show NodeId where show (NodeId str) = str show (UserNodeId i) - | i < 0 = "u_" ++ show (negate i) - | otherwise = "u" ++ show i + | i < 0 = "u_" ++ show (negate i) + | otherwise = "u" ++ show i data GraphElement = GraphAttribute String String - | GraphNode NodeId [(String,String)] - | GraphEdge NodeId NodeId [(String,String)] - | GraphEdge' NodeId (Maybe String) NodeId (Maybe String) [(String,String)] - | Scope [GraphElement] - | SubGraph NodeId [GraphElement] + | GraphNode NodeId [(String,String)] + | GraphEdge NodeId NodeId [(String,String)] + | GraphEdge' NodeId (Maybe String) NodeId (Maybe String) [(String,String)] + | Scope [GraphElement] + | SubGraph NodeId [GraphElement] data Dot a = Dot { unDot :: Int -> ([GraphElement],Int,a) } +-- Support 7.10 +instance Functor Dot where + fmap = liftM + +instance Applicative Dot where + pure = return + (<*>) = ap + instance Monad Dot where return a = Dot $ \ uq -> ([],uq,a) m >>= k = Dot $ \ uq -> case unDot m uq of - (g1,uq',r) -> case unDot (k r) uq' of - (g2,uq2,r2) -> (g1 ++ g2,uq2,r2) + (g1,uq',r) -> case unDot (k r) uq' of + (g2,uq2,r2) -> (g1 ++ g2,uq2,r2) -- | 'node' takes a list of attributes, generates a new node, and gives a 'NodeId'. node :: [(String,String)] -> Dot NodeId node attrs = Dot $ \ uq -> let nid = NodeId $ "n" ++ show uq - in ( [ GraphNode nid attrs ],succ uq,nid) + in ( [ GraphNode nid attrs ],succ uq,nid) -- | 'userNodeId' allows a user to use their own (Int-based) node id's, without needing to remap them. @@ -88,19 +102,20 @@ edge' from optF to optT attrs = Dot (\ uq -> ( [ GraphEdge' from optF to optT attrs ],uq,())) -- | '.->.' generates an edge between two 'NodeId's. +(.->.) :: NodeId -> NodeId -> Dot () (.->.) from to = edge from to [] -- | 'scope' groups a subgraph together; in dot these are the subgraphs inside "{" and "}". scope :: Dot a -> Dot a scope (Dot fn) = Dot (\ uq -> case fn uq of - ( elems,uq',a) -> ([Scope elems],uq',a)) + ( elems,uq',a) -> ([Scope elems],uq',a)) -- | 'share' is when a set of nodes share specific attributes. Usually used for layout tweaking. share :: [(String,String)] -> [NodeId] -> Dot () share attrs nodeids = Dot $ \ uq -> ( [ Scope ( [ GraphAttribute name val | (name,val) <- attrs] - ++ [ GraphNode nodeid [] | nodeid <- nodeids ] - ) + ++ [ GraphNode nodeid [] | nodeid <- nodeids ] + ) ], uq, ()) -- | 'same' provides a combinator for a common pattern; a set of 'NodeId's with the same rank. @@ -111,9 +126,9 @@ -- | 'cluster' builds an explicit, internally named subgraph (called cluster). cluster :: Dot a -> Dot (NodeId,a) cluster (Dot fn) = Dot (\ uq -> - let cid = NodeId $ "cluster_" ++ show uq - in case fn (succ uq) of - (elems,uq',a) -> ([SubGraph cid elems],uq',(cid,a))) + let cid = NodeId $ "cluster_" ++ show uq + in case fn (succ uq) of + (elems,uq',a) -> ([SubGraph cid elems],uq',(cid,a))) -- | 'attribute' gives a attribute to the current scope. attribute :: (String,String) -> Dot () @@ -122,8 +137,9 @@ -- 'showDot' renders a dot graph as a 'String'. showDot :: Dot a -> String showDot (Dot dm) = case dm 0 of - (elems,_,_) -> "digraph G {\n" ++ unlines (map showGraphElement elems) ++ "\n}\n" + (elems,_,_) -> "digraph G {\n" ++ unlines (map showGraphElement elems) ++ "\n}\n" +showGraphElement :: GraphElement -> String showGraphElement (GraphAttribute name val) = showAttr (name,val) ++ ";" showGraphElement (GraphNode nid attrs) = show nid ++ showAttrs attrs ++ ";" showGraphElement (GraphEdge from to attrs) = show from ++ " -> " ++ show to ++ showAttrs attrs ++ ";" @@ -133,15 +149,18 @@ showGraphElement (Scope elems) = "{\n" ++ unlines (map showGraphElement elems) ++ "\n}" showGraphElement (SubGraph nid elems) = "subgraph " ++ show nid ++ " {\n" ++ unlines (map showGraphElement elems) ++ "\n}" +showAttrs :: [(String, String)] -> String showAttrs [] = "" showAttrs xs = "[" ++ showAttrs' xs ++ "]" where - -- never empty list - showAttrs' [a] = showAttr a - showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as + -- never empty list + showAttrs' [a] = showAttr a + showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as +showAttr :: (String, String) -> String showAttr (name,val) = name ++ "=\"" ++ foldr showsDotChar "" val ++ "\"" +showsDotChar :: Char -> ShowS showsDotChar '"' = ("\\\"" ++) showsDotChar '\\' = ("\\\\" ++) showsDotChar x = showLitChar x @@ -151,13 +170,13 @@ netlistGraph :: (Ord a) => (b -> [(String,String)]) -- ^ Attributes for each node -> (b -> [a]) -- ^ Out edges leaving each node - -> [(a,b)] -- ^ The netlist - -> Dot () + -> [(a,b)] -- ^ The netlist + -> Dot () netlistGraph attrFn outFn assocs = do let nodes = S.fromList $ [ a | (a,_) <- assocs ] let outs = S.fromList $ [ o | (_,b) <- assocs - , o <- outFn b - ] + , o <- outFn b + ] nodeTab <- sequence [ do nd <- node (attrFn b) return (a,nd) | (a,b) <- assocs ] @@ -172,4 +191,3 @@ , src <- outFn b ] return () - diff --git a/dotgen.cabal b/dotgen.cabal --- a/dotgen.cabal +++ b/dotgen.cabal @@ -1,33 +1,43 @@ Name: dotgen -Version: 0.4.1 +Version: 0.4.2 Synopsis: A simple interface for building .dot graph files. Description: This package provides a simple interface for building .dot graph files, - for input into the dot and graphviz tools. - It includes a monadic interface for building graphs. + for input into the dot and graphviz tools. + It includes a monadic interface for building graphs. +homepage: https://github.com/ku-fpg/dotgen +bug-reports: https://github.com/ku-fpg/dotgen/issues Category: Text License: BSD3 License-file: LICENSE Author: Andy Gill Maintainer: Andy Gill -Stability: alpha -build-type: Simple -Cabal-Version: >= 1.6 +Stability: alpha +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +Cabal-Version: >= 1.8 +source-repository head + type: git + location: git://github.com/ku-fpg/dotgen + Flag devel - Description: Enable full development tree - Default: False + Description: Enable full development tree + Default: False Library - Build-Depends: base >=3 && <5, containers - Exposed-Modules: Text.Dot + Build-Depends: base >= 3 && < 5, + containers + Exposed-Modules: Text.Dot + ghc-options: -Wall -- Trivial (build) test framework Executable dotgen-test - if flag(devel) - buildable: True - else - buildable: False - hs-source-dirs: test, . - Main-is: DotTest.hs - - + if flag(devel) + buildable: True + else + buildable: False + build-depends: base >= 3 && < 5, + dotgen == 0.4.2 + hs-source-dirs: test + Main-is: DotTest.hs + ghc-options: -Wall diff --git a/test/DotTest.hs b/test/DotTest.hs --- a/test/DotTest.hs +++ b/test/DotTest.hs @@ -1,99 +1,98 @@ -module Main where +module Main (main) where import Text.Dot -data Animation = Start - -src label = node $ [ ("shape","none"),("label",label) ] -box label = node $ [ ("shape","box"),("style","rounded"),("label",label) ] +-- data Animation = Start +src, box, diamond :: String -> Dot NodeId +src label = node $ [ ("shape","none"),("label",label) ] +box label = node $ [ ("shape","box"),("style","rounded"),("label",label) ] diamond label = node $ [("shape","diamond"),("label",label),("fontsize","10")] - +main :: IO () main = putStrLn $ showDot $ do - attribute ("size","40,15") - attribute ("rankdir","LR") - refSpec <- src "S" - tarSpec <- src "T" - same [refSpec,tarSpec] + attribute ("size","40,15") + attribute ("rankdir","LR") + refSpec <- src "S" + tarSpec <- src "T" + same [refSpec,tarSpec] - c1 <- box "S" - c2 <- box "C" - c3 <- box "F" - same [c1,c2,c3] + c1 <- box "S" + c2 <- box "C" + c3 <- box "F" + same [c1,c2,c3] - refSpec .->. c1 - tarSpec .->. c2 - tarSpec .->. c3 + refSpec .->. c1 + tarSpec .->. c2 + tarSpec .->. c3 - m1 <- box "x" - m2 <- box "y" - ntm <- box "z" + m1 <- box "x" + m2 <- box "y" + ntm <- box "z" - same [m1,m2,ntm] - c1 .->. m1 - c2 .->. m2 + same [m1,m2,ntm] + c1 .->. m1 + c2 .->. m2 - xilinxSynthesis <- box "x" - c3 .->. xilinxSynthesis + xilinxSynthesis <- box "x" + c3 .->. xilinxSynthesis - gns <- box "G" - xilinxSynthesis .->. gns + gns <- box "G" + xilinxSynthesis .->. gns - gns .->. ntm + gns .->. ntm - ecs <- sequence - [ diamond "E" - , diamond "E" - , diamond "Eq" - ] - same ecs + ecs <- sequence + [ diamond "E" + , diamond "E" + , diamond "Eq" + ] + same ecs - m1 .->. (ecs !! 0) - m1 .->. (ecs !! 1) - m2 .->. (ecs !! 0) - m2 .->. (ecs !! 2) - ntm .->. (ecs !! 1) - ntm .->. (ecs !! 2) + m1 .->. (ecs !! 0) + m1 .->. (ecs !! 1) + m2 .->. (ecs !! 0) + m2 .->. (ecs !! 2) + ntm .->. (ecs !! 1) + ntm .->. (ecs !! 2) - sequence [ do evidence <- src "EE" - n .->. evidence - | n <- ecs - ] + _ <- sequence [ do evidence <- src "EE" + n .->. evidence + | n <- ecs + ] - edge refSpec tarSpec [("label","Engineering\nEffort"),("style","dotted")] - - () <- scope $ do v1 <- box "Hello" - v2 <- box "World" - v1 .->. v2 + edge refSpec tarSpec [("label","Engineering\nEffort"),("style","dotted")] - (x,()) <- cluster $ - do v1 <- box "Hello" - v2 <- box "World" - v1 .->. v2 - --- x .->. m2 - -- for hpc - () <- same [x,x] - v <- box "XYZ" - v .->. v - () <- attribute ("rankdir","LR") + () <- scope $ do v1 <- box "Hello" + v2 <- box "World" + v1 .->. v2 - let n1 = userNodeId 1 - let n2 = userNodeId (-1) + (x,()) <- cluster $ + do v1 <- box "Hello" + v2 <- box "World" + v1 .->. v2 + +-- x .->. m2 + -- for hpc + () <- same [x,x] + v <- box "XYZ" + v .->. v + () <- attribute ("rankdir","LR") - () <- n1 `userNode` [ ("shape","box")] - n1 .->. n2 - - v'' <- box "XYZ" + let n1 = userNodeId 1 + let n2 = userNodeId (-1) - box "(\n\\n)\"(/\\)" + () <- n1 `userNode` [ ("shape","box")] + n1 .->. n2 + + _ <- box "XYZ" - netlistGraph (\ a -> [("label","X" ++ show a)]) - (\ a -> [succ a `mod` 10,pred a `mod` 10]) - [ (n,n) | n <- [0..9]] - - - return () + _ <- box "(\n\\n)\"(/\\)" + netlistGraph (\ a -> [("label","X" ++ show a)]) + (\ a -> [succ a `mod` 10,pred a `mod` 10]) + [ (n,n) | n <- [0..9] :: [Int] ] + + + return ()