graphtype (empty) → 0.1
raw patch · 11 files changed
+694/−0 lines, 11 filesdep +basedep +containersdep +haskell-src-extssetup-changed
Dependencies added: base, containers, haskell-src-exts, haskell98, uniplate
Files
- LICENSE +25/−0
- README +13/−0
- Setup.hs +3/−0
- example/Test01.hs +77/−0
- example/Test02.hs +26/−0
- example/test.sh +3/−0
- graphtype.cabal +28/−0
- src/GraphType.hs +269/−0
- src/OptionParser.hs +47/−0
- src/Parse.hs +28/−0
- src/Text/Dot.hs +175/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2009 Dmitry Astapov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. 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.+3. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 THE AUTHORS 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.+
+ README view
@@ -0,0 +1,13 @@+Tool to produce dependency diagram from the set of *.hs files. Diagram+will include specified top-level declaration and all user-defined+types referencd from there (recursively).++To see dependency diagram for type MegaData and all other types+referenced from there, use:++ graphtype MegaData *.hs++User can choose to omit types and newtypes that do not contain+anything other than library types - this could be useful to unclutter+really large diagrams. Try running "graphtype --trim ..." and see+whether it helps you or otherwise.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ example/Test01.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Test01 where++import Data.ByteString+import Data.Map+import Data.Word+import Data.Typeable+import Test02++data Organization = Organization+ { orgName_ :: ByteString+ , physAddress_ :: ByteString+ , legalAddress_ :: ByteString+ , details_ :: ByteString+ , phone_ :: ByteString+ , contactPerson_ :: ByteString+ , bank_ :: ByteString+ , isVendor_ :: Bool+ , importMode_ :: ImportMode+ , stores_ :: Map StoreId Store+ , costs_ :: Costs+ , edrpou_ :: Word64+ , taxNum_ :: Word64+ , certNum_ :: Word64+ , transAccount_ :: Word64+ , mfo_ :: Word64+ } | SomeOtherShit String deriving Typeable+++data Store = Store+ { storeName_ :: ByteString+ , syncCode_ :: ByteString+ , minOrderVal_ :: Float+ , delivAddress_ :: ByteString+ , remainders_ :: Remainders+ } deriving (Typeable, Show)++data Remainders = Remainders+ { prodData :: ProdData+ , quantityData :: QuantityData+ } deriving (Typeable, Show)++data ProdInfo = ProdInfo+ { bufferInfo :: BufferInfo+ , greenRevision :: Revision+ , redRevision :: Revision+ , packing :: Packing+ , factor :: Factor+ , localProdName :: ByteString+ , localArticle :: Article+ , reason :: Reason+ , updPeriod :: Revision+ , display :: Quantity+ , reliability :: Float+ } deriving (Typeable, Show)++type Sessions = Map SessionKey SessionData+type QuantityArr = Map Day QuantityCell+type Quantity = Word32+type Mass = Word32+type Volume = Float+type Revision = Word8+type Column = Word8+type Article = Word16+type SessionKey = Word64+type UserName = ByteString+type Users = Map UserName UserInfo+type ProdData = Map Article ProdInfo+type QuantityData = Map Article QuantityArr+type ProdId = Article+type ProdName = ByteString+type Date = Day+type UpdTrig = Bool+type PrimeCost = Float+type ImportMode = Either TableImport XMLImport+type XMLImport = ()+type Cost = Float
+ example/Test02.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Test02 where++import Data.ByteString+import Data.Typeable+import Data.Map+import Data.Word++data Buffer = Buffer+ { buffer :: Quantity+ , greenPart :: Double+ , redPart :: Double+ } deriving (Typeable, Show)++data QuantityCell = QuantityCell+ { increase :: Increase+ , decrease :: Decrease+ , remainder :: Remainder+ , updateT :: UpdTrig+ } deriving (Typeable, Show)++type Costs = Map Article (Cost, PrimeCost)+type BufferInfo = Map Day Buffer+type Reason = ByteString+type ProdGroup = Word16+type Barcode = Word64
+ example/test.sh view
@@ -0,0 +1,3 @@+#!/bin/bash+runhaskell ../src/GraphType.hs "$@" Organization ../example/*.hs+dot -T png -o output.png output.dot
+ graphtype.cabal view
@@ -0,0 +1,28 @@+Name: graphtype+Version: 0.1+Synopsis: A simple tool to illustrate dependencies between Haskell types+Description: This tools produces diagrams of Haskell type interdependencies in the given source.+ Actual drawing is done by graphviz tools (dot).+Category: Text+License: BSD3+License-file: LICENSE+Author: Dmitry Astapov+Maintainer: Dmity Astapov <dastapov@gmail.com>+Build-Depends: base >=3 && <5 , haskell-src-exts, uniplate, containers, haskell98+Stability: alpha+build-type: Simple++extra-source-files:+ README+ LICENSE+ example/Test01.hs+ example/Test02.hs+ example/test.sh++Executable: graphtype+hs-source-dirs: src+Main-is: GraphType.hs+other-modules:+ Parse+ OptionParser+ Text.Dot
+ src/GraphType.hs view
@@ -0,0 +1,269 @@+-- | Produce dependency diagram from the set of *.hs files+--+-- Diagram will include specified top-level declaration and all user-defined types referencd from there (recursively).+--+-- User can choose to omit types and newtypes that do not contain anything other than library types - this could be+-- useful to unclutter really large diagrams+module Main where++import Parse (parseFiles)+import OptionParser++import Language.Haskell.Exts+import Data.Generics.PlateData (universeBi)+import Text.Dot+import Data.List+import Data.Maybe+import Control.Monad++main = do+ (Mode output trim, root, files) <- getOpts+ types <- parseFiles files+ let trimmed = if trim + then doTrim types+ else types+ let graph = buildGraph trimmed root+ writeFile output graph++-- | Trim declarations, removing those types and newtypes that do not have references to other user-defined types+doTrim :: [Decl] -> [Decl]+doTrim types = if types' == types then types+ else doTrim types'+ where+ types' = types \\ (filter boring candidates)+ candidates = [ d | d <- types+ , getDeclType d `elem` ["type", "newtype"] ]+ boring d = null $ catMaybes $ [ findDecl (prettyPrint qname) types | TyCon qname <- universeBi d ]++type DeclName = String+type Graph = String++-- | Builds dependency graph starting with datatype declaration `root'.+-- Recursively expands all user-defined `types' referenced from `root', up to `depth'+buildGraph :: [Decl] -- ^ All declarations found in source files+ -> DeclName -- ^ Start from this declaration+ -> Graph -- ^ Graph definition in DOT syntax+buildGraph types root =+ showDot $ do+ -- Allow links that end on cluster boundaries+ attribute("compound", "true")+ -- Try harder to route edges around clusters+ attribute("remincross", "true")+ -- Try harder to route edges around clusters+ attribute("rankdir", "LR")+ -- Add topmost declaration and proceed with links going from it+ (danglingLinks,clusters) <- addDecl root [] types+ addLinks danglingLinks clusters types++-- Each declaration is transformed to the cluster on the output graph.+-- Elements of the cluster are graph nodes, one for each constructor in the declaration.+-- Those nodes have shape "record".+-- Since there are "records" with "fields" in dot syntax, and "records" with "fields" in Haskell syntax,+-- there bound to be some misunderstanding. Unless said otherwise, from now on records and fields+-- are those from dot syntax.++type Links = [DanglingLink]+-- | Information about dangling link that should be added to graph.+-- We would want to create links while in the middle of constructing a complex record node, which is not possible.+-- Thus, all outgoing links are scheduled in the list of dangling links and resolved in the breadth-first manner.+-- Initially, each dangling link is specified via target declaration name. When this declaration is added to graph,+-- it is possible to find out cluster id and (some) node id corresponding to that declaration and actually build a link.+--+-- We have to have some target node id because dot does not allow links to clusters themselves. We choose first node+-- within a cluster as our target.+data DanglingLink =+ DL { linkTarget::DeclName -- ^ destination declaration to link to+ , createLink::(ClusterId -> NodeId -> Dot ()) -- ^ function used to create link once proper destination cluster is determined+ }+type ClusterId = NodeId+++type Port = String++-- | Helper constructor for dangling links.+-- Notice the "lhead" attribute - without it the edge would not stop at the cluster boundary+mkDL :: DeclName -> Port -> NodeId -> DanglingLink+mkDL target sourcePort sourceNode =+ DL target (\cluster targetNode -> edge' sourceNode (Just sourcePort) targetNode Nothing [("lhead",show cluster)])++-- | Information about clusters already added to the graph:+-- (Declaration name, (cluster id for this declaration, Id of the first node in this cluster))+type Clusters = [(DeclName, (NodeId, NodeId))]++-- | Add dangling `links' to the graph, adding new clusters as needed+addLinks :: Links -- ^ Links to be added to the graph+ -> Clusters -- ^ Clusters already present in graph+ -> [Decl] -- ^ All declarations parsed from source files+ -> Dot ()+addLinks [] clusters types = return ()+addLinks links@((DL target mkLink):rest) clusters types =+ case lookup target clusters of+ Just (destCluster, destNode) -> do+ -- Target cluster is already in the graph. Just add link to it and proceed+ mkLink destCluster destNode+ addLinks rest clusters types+ Nothing -> do+ -- Target cluster is absent. Add it and re-try linking.+ (danglingLinks, clusters') <- addDecl target clusters types+ addLinks (links++danglingLinks) clusters' types+++-- | Each "record" node in the dot file could be decomposed into several fields.+-- Each field represents a Haskell record field, Haskell datatype component or Haskell type declaration+data Field = F { fieldName::Maybe Name -- ^ name of the Haskell record field, empty otherwise+ , fieldPort::Maybe Port -- ^ dot-specific ID of the field, for anchoring originating links. Empty when field has some unknown type+ , typeName::DeclName -- ^ user-friendly name of the Haskell type+ , fieldLink::[Maybe (NodeId -> DanglingLink)] -- ^ As soon as DOT record is finished, its node id is substituted here to+ -- obtain a dangling link to target declaration. Empty when field has some unknown type+ }++-- | Add a single declaration to graph. As it was already said, each declaration is mapped to a DOT cluster+addDecl :: DeclName -- ^ Name of the declaration we are adding+ -> Clusters -- ^ Declarations already added to graph+ -> [Decl] -- ^ All known declarations+ -> Dot (Links,Clusters) -- ^ ( Links dangling from this declaration, Updated list of clusters )+addDecl declName clusters decls = do+ ( clusterId, (firstNodeId, danglingLinks) ) <- mkCluster+ let clusters' = (declName, (clusterId, firstNodeId)):clusters+ return ( danglingLinks, clusters' )+ where+ -- Find declaration by name+ d = case findDecl declName decls of+ Just x -> x+ Nothing -> error $ "Could not find type " ++ declName ++ " in source files"++ -- Type, newtype or data+ declType = getDeclType d++ mkCluster = cluster $ do+ attribute ( "label", unwords [ declType, getName d ] )+ if declType == "type"+ then do+ -- For simple type declaration, convert all type components to DOT record fields+ let (TypeDecl _ _ _ t) = d+ let fs = type2fields 0 t+ -- Then, convert DOT fields to DOT record.+ -- Type components will be separated into different "cells" of the record, so that+ -- it would be possible to create outgoing links from any type component.+ mkRecord ( mkLabel fs ) fs+ else do+ -- For data/newtype declaration, create a single record for each constructor.+ (constructorNodes, links) <- liftM unzip $ sequence $ [ addConstructor x | x <- universeBi d ]+ -- Collect all outgoing links.+ return (head constructorNodes, concat links)++ mkRecord :: String -> [Field] -> Dot (NodeId, Links)+ mkRecord label fs = do+ -- Create DOT record node+ rId <- record label+ -- Instantiate all outgoing links+ let links = [ mkLink rId | (F _ _ _ links) <- fs, Just mkLink <- links ]+ return (rId, links)++ -- Produce label for record.+ -- Since label has both human-readable components and special markup that defines record shape,+ -- special care should be taken while combining information from separate fields:+ mkLabel :: [Field] -> String+ mkLabel fs = wrap $ toLabel $ map mkComponent fs+ where+ mkComponent field + -- If field is not named (body of type or component of data), then label is just "<port> type_name":+ | fieldName field == Nothing = mkPort field ++ typeName field+ -- If field is named, that we should take care to:+ -- 1)Preserve position of the topmost port+ -- 2)Enclose all complex declarations in {}+ | otherwise = let fn = fromName $ fromJust $ fieldName field -- Haskell field name+ t = typeName field -- Haskell type+ text = case head t of+ -- If the type is complex (Map Foo Bar), include complex description as DOT subfield+ '{' -> block $ fn ++ " :: | " ++ block t+ -- If the type is simple, just prepend field name+ _ -> fn ++ " :: " ++ t+ -- Dont forget the port (if present)+ in mkPort field ++ text++ mkPort f = fromMaybe "" $ fieldPort f++ toLabel [] = ""+ toLabel fields = foldr1 (<||>) fields++ -- When combining more that one field into label, enclose it in {}+ wrap = case fs of+ [_] -> id+ _ -> block++ -- TODO: add InfixConDecl+ addConstructor (ConDecl nm types) = do+ let fs = concat $ zipWith type2fields [0..] types+ fields2record ("constructor " ++ fromName nm) fs+ addConstructor (RecDecl nm types) = do+ let fs = zipWith rectype2field [0..] types+ fields2record ("record " ++ fromName nm) fs++ -- DOT records for Haskell data and Haskell record have "header" with the name of the constructor+ fields2record header fs = mkRecord ( header <//> mkLabel fs ) fs++ -- Collect all type constructors mentioned in type and convert them into DOT fields.+ -- `x' would be explained below+ type2fields x t = map (tyCon2field x) cons+ where cons = [ prettyPrint qname | TyCon qname <- universeBi t ] -- TODO: process TyInfix as well++ -- Convert type `typeName' into DOT field+ tyCon2field x typeName =+ case findDecl typeName decls of+ -- If this is a known (user-defined) type, allocate a port for link and add a dangling link to expanded type description+ Just d -> F {fieldName=Nothing, fieldPort=Just port, typeName=typeName, fieldLink=[Just (mkDL typeName port)]}+ -- If this is a library type, just record its name+ Nothing -> F {fieldName=Nothing, fieldPort=Nothing, typeName=typeName, fieldLink=[Nothing]}+ where+ -- Allocate port. Port name is similar to type name, with sequential number X appended to distinguish between several+ -- components of the same type within a single declaration+ port = concat [ "<", typeName, show x, "> " ]++ -- Convert Haskell record field into DOT record field+ rectype2field x (nms,t) =+ let fs = type2fields x t -- first, conver all type components into fields+ fName = concat $ intersperse ", " $ map prettyPrint nms -- there might be more that one Haskell field name ("a,b::Int")+ fLabel = mkLabel fs -- produce proper DOT description of the type+ in case fs of+ -- If it is a simple one-component type, just add a record name and be done with it+ [f] -> f { fieldName=(Just $ name fName) }+ -- If it is multi-component type, ...+ _ -> F { fieldName=(Just $ name fName) -- add record name, ...+ , fieldPort=Nothing+ , typeName=fLabel -- save type description+ , fieldLink = (concatMap fieldLink fs) -- collect all links from all type components+ }+++-----------------------------------+-- DOT record construnction helpers+-----------------------------------+record label = node $ [ ("shape","record"),("label",label) ]++infix <||>, <//>+-- | Append next subfield on the same level+a <||> b = concat [a, " | ", b]+-- | Start new sub-level+a <//> b = concat [ a, " | { ", b, " }"]+-- | Turn field into a block+block x = "{ " ++ x ++ " }"++-----------------------------------+-- Haskell AST manipulation helpers+-----------------------------------+-- | Find declaration by name+findDecl nm decls = find ((==nm).getName) decls++-- | Get declaration name+getName (DataDecl _ _ _ nm _ _ _) = fromName nm+getName (TypeDecl _ nm _ _) = fromName nm++-- | Get declaration .. ummm .. type. Pretty self-explanatory+getDeclType (DataDecl _ DataType _ _ _ _ _) = "data"+getDeclType (DataDecl _ NewType _ _ _ _ _) = "newtype"+getDeclType (TypeDecl _ _ _ _) = "type"++-- | Get name out of the Name datatype+fromName (Ident x) = x+fromName (Symbol x) = x
+ src/OptionParser.hs view
@@ -0,0 +1,47 @@+module OptionParser+ (+ Mode(..),+ getOpts,+ )+where++import System.Environment (getArgs) +import System.Exit+import System.Console.GetOpt+import Data.Maybe ( fromMaybe )+import Control.Monad (when)++-- | Mode of operation+data Mode = Mode { output :: String -- ^ Name of the output file+ , trim :: Bool -- ^ Trim trivial types/newtypes or not+ }++-- | Default mode: output to "output.dot", dont trim trivial types+defaultMode = Mode "output.dot" False+++data Flag + = Output FilePath | Trim | Help+ deriving (Eq,Show)++options :: [OptDescr Flag]+options =+ [ Option ['o'] ["output"] (OptArg getOutput "file") "Name of the output file (default: output.dot)",+ Option ['t'] ["trim"] (NoArg Trim) "Trim types/newtype that do not have references to other user-defined types",+ Option [] ["help"] (NoArg Help) "Show this help" ]++getOutput Nothing = Output "output.dot"+getOutput (Just s) = Output s++update (Output f) m = m { output = f }+update Trim m = m { trim = True }++getOpts :: IO (Mode, String, [FilePath])+getOpts = getArgs >>= \argv ->+ case getOpt Permute options argv of+ (o, (root:files), [] ) -> do when (Help `elem` o) (do putStrLn usage + exitWith ExitSuccess)+ return (foldr update defaultMode o, root, files)+ (_, _, errs) -> ioError (userError (concat errs ++ usage))+ where header = "Usage: graphtype [OPTION...] type_name file1.hs file2.hs ..."+ usage = usageInfo header options
+ src/Parse.hs view
@@ -0,0 +1,28 @@+-- | Parses specified *.hs files and returns a list of all data declarations from them+module Parse (parseFiles) where++import Language.Haskell.Exts+import Data.Generics.PlateData (universeBi)+import Control.Monad (liftM)+import System.Exit (exitFailure)++parseFiles :: [FilePath] -> IO [Decl]+parseFiles = liftM concat . mapM parseFile'+ where+ parseFile' fname = do+ res <- parseFile fname+ case res of+ ParseOk m -> return $ collectDeclarations m+ ParseFailed srcLoc message -> do+ putStrLn $ unlines [ prettyPrint srcLoc+ , message+ ]+ exitFailure++collectDeclarations moduleDesc =+ [ x | x <- universeBi moduleDesc, isDeclaration x]+ where+ isDeclaration (DataDecl _ _ _ _ _ _ _) = True+ isDeclaration (TypeDecl _ _ _ _) = True+ isDeclaration _ = False+
+ src/Text/Dot.hs view
@@ -0,0 +1,175 @@+-- |+-- Module: Text.Dot+-- Copyright: Andy Gill+-- License: BSD3+--+-- Maintainer: Andy Gill <andygill@ku.edu>+-- Stability: unstable+-- Portability: portable+--+-- This module 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.++module Text.Dot + ( + -- * 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++import Data.Char+import qualified Data.Map as M+import qualified Data.Set as S++data DotGraph = DotGraph [GraphElement]++data NodeId = NodeId String+ | UserNodeId Int++instance Show NodeId where+ show (NodeId str) = str+ show (UserNodeId 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]++data Dot a = Dot { unDot :: Int -> ([GraphElement],Int,a) }++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)++-- | '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)+++-- | 'userNodeId' allows a user to use their own (Int-based) node id's, without needing to remap them.+userNodeId :: Int -> NodeId+userNodeId i = UserNodeId i++-- | 'userNode' takes a NodeId, and adds some attributes to that node. +userNode :: NodeId -> [(String,String)] -> Dot ()+userNode nId attrs = Dot $ \ uq -> ( [GraphNode nId attrs ],uq,())++-- | 'edge' generates an edge between two 'NodeId's, with attributes.+edge :: NodeId -> NodeId -> [(String,String)] -> Dot ()+edge from to attrs = Dot (\ uq -> ( [ GraphEdge from to attrs ],uq,()))++-- | 'edge' generates an edge between two 'NodeId's, with optional node sub-labels, and attributes.+edge' :: NodeId -> Maybe String -> NodeId -> Maybe String -> [(String,String)] -> Dot ()+edge' from optF to optT attrs = Dot (\ uq -> ( [ GraphEdge' from optF to optT attrs ],uq,()))++-- | '.->.' generates an edge between two 'NodeId's.+(.->.) 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))++-- | '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 ]+ ) + ], uq, ())++-- | 'same' provides a combinator for a common pattern; a set of 'NodeId's with the same rank.+same :: [NodeId] -> Dot ()+same = share [("rank","same")]+++-- | '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)))++-- | 'attribute' gives a attribute to the current scope.+attribute :: (String,String) -> Dot ()+attribute (name,val) = Dot (\ uq -> ( [ GraphAttribute name val ],uq,()))++-- '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"++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 ++ ";"+showGraphElement (GraphEdge' from optF to optT attrs) = showName from optF ++ " -> " ++ showName to optT ++ showAttrs attrs ++ ";"+ where showName n Nothing = show n+ showName n (Just t) = show n ++ ":" ++ t+showGraphElement (Scope elems) = "{\n" ++ unlines (map showGraphElement elems) ++ "\n}"+showGraphElement (SubGraph nid elems) = "subgraph " ++ show nid ++ " {\n" ++ unlines (map showGraphElement elems) ++ "\n}"++showAttrs [] = ""+showAttrs xs = "[" ++ showAttrs' xs ++ "]"+ where+ -- never empty list+ showAttrs' [a] = showAttr a+ showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as++showAttr (name,val) = name ++ "=\"" ++ foldr showsDotChar "" val ++ "\""++showsDotChar '"' = ("\\\"" ++)+showsDotChar '\\' = ("\\\\" ++)+showsDotChar x = showLitChar x+++-- | 'netlistGraph' generates a simple graph from a netlist.+netlistGraph :: (Ord a) + => (b -> [(String,String)]) -- ^ Attributes for each node+ -> (b -> [a]) -- ^ Out edges leaving each node+ -> [(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 + ]+ nodeTab <- sequence [ do nd <- node (attrFn b)+ return (a,nd)+ | (a,b) <- assocs ]+ otherTab <- sequence [ do nd <- node []+ return (o,nd)+ | o <- S.toList outs+ , o `S.notMember` nodes+ ]+ let fm = M.fromList (nodeTab ++ otherTab)+ sequence_ [ (fm M.! src) .->. (fm M.! dst)+ | (dst,b) <- assocs+ , src <- outFn b+ ]+ return ()+