dotgen 0.4.1 → 0.4.2
raw patch · 5 files changed
+175/−141 lines, 5 filesdep +dotgennew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: dotgen
API changes (from Hackage documentation)
+ Text.Dot: instance Applicative Dot
+ Text.Dot: instance Functor Dot
Files
- CHANGELOG.md +2/−0
- README.md +5/−0
- Text/Dot.hs +67/−49
- dotgen.cabal +28/−18
- test/DotTest.hs +73/−74
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+## 0.4.2+* Fixed build with GHC 7.10
+ README.md view
@@ -0,0 +1,5 @@+# dotgen [](http://hackage.haskell.org/package/dotgen) [](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.
Text/Dot.hs view
@@ -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 ()-
dotgen.cabal view
@@ -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 <andygill@ku.edu>-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
test/DotTest.hs view
@@ -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 ()