diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/example/Test01.hs b/example/Test01.hs new file mode 100644 --- /dev/null +++ b/example/Test01.hs @@ -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 diff --git a/example/Test02.hs b/example/Test02.hs new file mode 100644 --- /dev/null +++ b/example/Test02.hs @@ -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 diff --git a/example/test.sh b/example/test.sh new file mode 100644 --- /dev/null +++ b/example/test.sh @@ -0,0 +1,3 @@ +#!/bin/bash +runhaskell ../src/GraphType.hs "$@" Organization ../example/*.hs +dot -T png -o output.png output.dot diff --git a/graphtype.cabal b/graphtype.cabal new file mode 100644 --- /dev/null +++ b/graphtype.cabal @@ -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 +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 diff --git a/src/GraphType.hs b/src/GraphType.hs new file mode 100644 --- /dev/null +++ b/src/GraphType.hs @@ -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 " 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 diff --git a/src/OptionParser.hs b/src/OptionParser.hs new file mode 100644 --- /dev/null +++ b/src/OptionParser.hs @@ -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 diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -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 + diff --git a/src/Text/Dot.hs b/src/Text/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot.hs @@ -0,0 +1,175 @@ +-- | +-- Module: Text.Dot +-- Copyright: Andy Gill +-- License: BSD3 +-- +-- Maintainer: Andy Gill +-- 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 () +