graphviz-2999.8.0.0: Data/GraphViz.hs

{-# LANGUAGE FlexibleContexts #-}

{- |
   Module      : Data.GraphViz
   Description : Graphviz bindings for Haskell.
   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This is the top-level module for the graphviz library.  It provides
   functions to convert 'Data.Graph.Inductive.Graph.Graph's into the
   /Dot/ language used by the /Graphviz/ suite of programs (as well as
   a limited ability to perform the reverse operation).

   Information about Graphviz and the Dot language can be found at:
   <http://graphviz.org/>

 -}
module Data.GraphViz
    ( -- * Conversion from graphs to /Dot/ format.
      -- $conversion
      graphToDot
    , graphToDot'
      -- ** Conversion with support for clusters.
    , NodeCluster(..)
    , clusterGraphToDot
    , clusterGraphToDot'
      -- ** Pseudo-inverse conversion.
    , dotToGraph
      -- * Graph augmentation.
      -- $augment
      -- ** Type aliases for @Node@ and @Edge@ labels.
    , AttributeNode
    , AttributeEdge
      -- ** Customisable augmentation.
    , graphToGraph
    , graphToGraph'
    , clusterGraphToGraph
    , clusterGraphToGraph'
      -- ** Quick augmentation.
      -- $quickAugment
    , dotizeGraph
    , dotizeGraph'
    , dotizeClusterGraph
    , dotizeClusterGraph'
      -- ** Manual augmentation.
      -- $manualAugment
    , EdgeID
    , addEdgeIDs
    , setEdgeComment
    , dotAttributes
    , augmentGraph
      -- * Utility functions
    , prettyPrint
    , prettyPrint'
    , preview
      -- * Re-exporting other modules.
    , module Data.GraphViz.Types
    , module Data.GraphViz.Attributes
    , module Data.GraphViz.Commands
    ) where

import Data.GraphViz.Types
import Data.GraphViz.Types.Clustering
import Data.GraphViz.Util(uniq, uniqBy)
import Data.GraphViz.Attributes
import Data.GraphViz.Commands

import Data.Graph.Inductive.Graph
import qualified Data.Set as Set
import Control.Arrow((&&&))
import Data.Maybe(mapMaybe, isNothing)
import qualified Data.Map as Map
import Control.Monad(liftM)
import System.IO.Unsafe(unsafePerformIO)
import Control.Concurrent(forkIO)

-- -----------------------------------------------------------------------------

-- | Determine if the given graph is undirected.
isUndirected   :: (Ord b, Graph g) => g a b -> Bool
isUndirected g = all hasFlip es
    where
      es = labEdges g
      eSet = Set.fromList es
      hasFlip e = Set.member (flippedEdge e) eSet
      flippedEdge (f,t,l) = (t,f,l)

-- | Determine if the given graph is directed.
isDirected :: (Ord b, Graph g) => g a b -> Bool
isDirected = not . isUndirected

-- -----------------------------------------------------------------------------

{- $conversion
   There are various functions available for converting 'Graph's to
   Graphviz's /Dot/ format (represented using the 'DotGraph' type).
   There are two main types: converting plain graphs and converting
   /clustered/ graphs (where the graph cluster that a particular 'Node'
   belongs to is determined by its label).

   These functions have two versions: one in which the user specifies
   whether the graph is directed or undirected (with a 'Bool' value of
   'True' indicating that the graph is directed), and a primed version
   which attempts to automatically infer if the graph is directed or not.
   Note that these conversion functions assume that undirected graphs
   have every edge being duplicated (or at least that if there exists an
   edge from /n1/ to /n2/, then /n1 <= n2/; if /n1 > n2/ then it is
   removed for an undirected graph).
-}

-- | Convert a graph to Graphviz's /Dot/ format.
graphToDot :: (Graph gr) => Bool -> gr a b -> [GlobalAttributes]
              -> (LNode a -> Attributes) -> (LEdge b -> Attributes)
              -> DotGraph Node
graphToDot isDir graph gAttributes
    = clusterGraphToDot isDir graph gAttributes clustBy cID fmtClust
      where
        clustBy :: LNode a -> NodeCluster () a
        clustBy = N
        cID = const Nothing
        fmtClust = const []

-- | Convert a graph to Graphviz's /Dot/ format with automatic
--   direction detection.
graphToDot'       :: (Ord b, Graph gr) => gr a b -> [GlobalAttributes]
                     -> (LNode a -> Attributes) -> (LEdge b -> Attributes)
                     -> DotGraph Node
graphToDot' graph = graphToDot (isDirected graph) graph

-- | A pseudo-inverse to 'graphToDot' and 'graphToDot''; \"pseudo\" in
--   the sense that the original node and edge labels aren't able to
--   be reconstructed.
dotToGraph    :: (DotRepr dg Node, Graph gr) => dg Node
                 -> gr Attributes Attributes
dotToGraph dg = mkGraph ns' es
  where
    -- Applying uniqBy just in case...
    ns = uniqBy fst . map toLN $ graphNodes dg
    es = concatMap toLE $ graphEdges dg
    -- Need to ensure that for some reason there are node IDs in an
    -- edge but not on their own.
    nSet = Set.fromList $ map fst ns
    nEs = map (flip (,) [])
          . uniq
          . filter (flip Set.notMember nSet)
          $ concatMap (\(n1,n2,_) -> [n1,n2]) es
    ns' = ns ++ nEs
    -- Conversion functions
    toLN (DotNode n as) = (n,as)
    toLE (DotEdge f t d as) = (if d then id else (:) (t,f,as)) [(f,t,as)]


-- | Convert a graph to /Dot/ format, using the specified clustering function
--   to group nodes into clusters.
--   Clusters can be nested to arbitrary depth.
clusterGraphToDot :: (Ord c, Graph gr) => Bool -> gr a b
                     -> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
                     -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
                     -> (LNode l -> Attributes) -> (LEdge b -> Attributes)
                     -> DotGraph Node
clusterGraphToDot dirGraph graph gAttrs clusterBy cID fmtCluster fmtNode fmtEdge
    = DotGraph { strictGraph     = False
               , directedGraph   = dirGraph
               , graphID         = Nothing
               , graphStatements = stmts
               }
      where
        stmts = DotStmts { attrStmts = gAttrs
                         , subGraphs = cs
                         , nodeStmts = ns
                         , edgeStmts = es
                         }
        (cs, ns) = clustersToNodes clusterBy cID fmtCluster fmtNode graph
        es = mapMaybe mkDotEdge . labEdges $ graph
        mkDotEdge e@(f,t,_) = if dirGraph || f <= t
                              then Just DotEdge { edgeFromNodeID = f
                                                , edgeToNodeID   = t
                                                , edgeAttributes = fmtEdge e
                                                , directedEdge   = dirGraph
                                                }
                              else Nothing

-- | Convert a graph to /Dot/ format, using the specified clustering function
--   to group nodes into clusters.
--   Clusters can be nested to arbitrary depth.
--   Graph direction is automatically inferred.
clusterGraphToDot'    :: (Ord c, Ord b, Graph gr) => gr a b
                         -> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
                         -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
                         -> (LNode l -> Attributes) -> (LEdge b -> Attributes)
                         -> DotGraph Node
clusterGraphToDot' gr = clusterGraphToDot (isDirected gr) gr

-- -----------------------------------------------------------------------------

{- $augment
   The following functions provide support for passing a 'Graph'
   through the appropriate 'GraphvizCommand' to augment the 'Graph' by
   adding positional information, etc.

   Please note that there are some restrictions on this: to enable
   support for multiple edges between two nodes, the 'Comment'
   'Attribute' is used to provide a unique identifier for each edge.  As
   such, you should /not/ set this 'Attribute' for any 'LEdge'.

   For unprimed functions, the 'Bool' argument is 'True' for directed
   graphs, 'False' otherwise; for the primed versions of functions the
   directionality of the graph is automatically inferred.  Directed
   graphs are passed through 'Dot', and undirected graphs through
   'Neato'.
   Note that the reason these functions do not have 'unsafePerformIO'
   applied to them is because if you set a global 'Attribute' of:

   @
    'Start' ('StartStyle' 'RandomStyle')
   @

   then it will not necessarily be referentially transparent (ideally,
   no matter what the seed is, it will still eventually be drawn to the
   same optimum, but this can't be guaranteed).  As such, if you are sure
   that you're not using such an 'Attribute', then you should be able to
   use 'unsafePerformIO' directly in your own code.
-}

type AttributeNode a = (Attributes, a)
type AttributeEdge b = (Attributes, b)

-- | Run the appropriate Graphviz command on the graph to get
--   positional information and then combine that information back
--   into the original graph.
graphToGraph :: (Graph gr) => Bool -> gr a b -> [GlobalAttributes]
                -> (LNode a -> Attributes) -> (LEdge b -> Attributes)
                -> IO (gr (AttributeNode a) (AttributeEdge b))
graphToGraph isDir gr gAttributes fmtNode fmtEdge
    = dotAttributes isDir gr' dot
    where
      dot = graphToDot isDir gr' gAttributes fmtNode (setEdgeComment fmtEdge)
      gr' = addEdgeIDs gr

-- | Run the appropriate Graphviz command on the graph to get
--   positional information and then combine that information back
--   into the original graph.
--   Graph direction is automatically inferred.
graphToGraph'    :: (Ord b, Graph gr) => gr a b -> [GlobalAttributes]
                    -> (LNode a -> Attributes) -> (LEdge b -> Attributes)
                    -> IO (gr (AttributeNode a) (AttributeEdge b))
graphToGraph' gr = graphToGraph (isDirected gr) gr

-- | Run the appropriate Graphviz command on the clustered graph to
--   get positional information and then combine that information back
--   into the original graph.
clusterGraphToGraph :: (Ord c, Graph gr) => Bool -> gr a b
                       -> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
                       -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
                       -> (LNode l -> Attributes) -> (LEdge b -> Attributes)
                       -> IO (gr (AttributeNode a) (AttributeEdge b))
clusterGraphToGraph isDir gr gAtts clBy cID fmtClust fmtNode fmtEdge
    = dotAttributes isDir gr' dot
    where
      dot = clusterGraphToDot isDir gr' gAtts clBy cID fmtClust fmtNode fmtEdge'
      gr' = addEdgeIDs gr
      fmtEdge' = setEdgeComment fmtEdge

-- | Run the appropriate Graphviz command on the clustered graph to
--   get positional information and then combine that information back
--   into the original graph.
--   Graph direction is automatically inferred.
clusterGraphToGraph'    :: (Ord b, Ord c, Graph gr) => gr a b
                           -> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
                           -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
                           -> (LNode l -> Attributes) -> (LEdge b -> Attributes)
                           -> IO (gr (AttributeNode a) (AttributeEdge b))
clusterGraphToGraph' gr = clusterGraphToGraph (isDirected gr) gr

-- -----------------------------------------------------------------------------

{- $quickAugment
   This section contains convenience functions for quick-and-dirty
   augmentation of graphs.  No 'Attribute's are applied, and
   'unsafePerformIO' is used to make these normal functions.  Note that
   this should be safe since these should be referentially transparent.
-}

-- | Pass the graph through 'graphToGraph' with no 'Attribute's.
dotizeGraph         :: (Graph gr) => Bool -> gr a b
                       -> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph isDir g = unsafePerformIO
                      $ graphToGraph isDir g gAttrs noAttrs noAttrs
    where
      gAttrs = []
      noAttrs = const []

-- | Pass the graph through 'graphToGraph' with no 'Attribute's.
--   The graph direction is automatically inferred.
dotizeGraph'   :: (Graph gr, Ord b) => gr a b
                  -> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph' g = dotizeGraph (isDirected g) g

-- | Pass the clustered graph through 'clusterGraphToGraph' with no
--   'Attribute's.
dotizeClusterGraph                 :: (Ord c, Graph gr) => Bool -> gr a b
                                      -> (LNode a -> NodeCluster c l)
                                      -> gr (AttributeNode a) (AttributeEdge b)
dotizeClusterGraph isDir g clustBy = unsafePerformIO
                                     $ clusterGraphToGraph isDir   g
                                                           gAttrs  clustBy
                                                           cID     cAttrs
                                                           noAttrs noAttrs
    where
      gAttrs = []
      cID = const Nothing
      cAttrs = const gAttrs
      noAttrs = const []

-- | Pass the clustered graph through 'clusterGraphToGraph' with no
--   'Attribute's.
--   The graph direction is automatically inferred.
dotizeClusterGraph'   :: (Ord b, Ord c, Graph gr) => gr a b
                         -> (LNode a -> NodeCluster c l)
                         -> gr (AttributeNode a) (AttributeEdge b)
dotizeClusterGraph' g = dotizeClusterGraph (isDirected g) g

-- -----------------------------------------------------------------------------

{- $manualAugment

   This section allows you to manually augment graphs by providing
   fine-grained control over the augmentation process (the standard
   augmentation functions compose these together).  Possible reasons for
   manual augmentation are:

   * Gain access to the intermediary 'DotRepr' used.

   * Convert the default 'DotGraph' to a @GDotGraph@ (found in
     "Data.GraphViz.Types.Generalised") so as to have greater control over
     the generated Dot code.

   * Use a specific 'GraphvizCommand' rather than the default.

   Note that whilst these functions provide you with more control, you
   must be careful how you use them: if you use the wrong 'DotRepr' for
   a 'Graph', then the behaviour of 'augmentGraph' (and all functions
   that use it) is undefined.  The main point is to make sure that the
   defined 'DotNode' and 'DotEdge' values aren't removed (or their ID
   values - or the 'Comment' 'Attribute' for the 'DotEdge's - altered) to
   ensure that it is possible to match up the nodes and edges in the
   'Graph' with those in the 'DotRepr'.

-}

-- | Used to augment an edge label with a unique identifier.
data EdgeID b = EID { eID  :: String
                    , eLbl :: b
                    }
              deriving (Eq, Ord, Show)
-- Show is only provided for printing/debugging purposes when using a
-- normal Tree-based graph.  Since it doesn't support Read, neither
-- does EdgeID.

-- | Add unique edge identifiers to each label.  This is useful for
--   when multiple edges between two nodes need to be distinguished.
addEdgeIDs   :: (Graph gr) => gr a b -> gr a (EdgeID b)
addEdgeIDs g = mkGraph ns es'
  where
    ns = labNodes g
    es = labEdges g
    es' = zipWith addID es ([1..] :: [Int])
    addID (f,t,l) i = (f,t,EID (show i) l)

-- | Add the 'Comment' to the list of attributes containing the value
--   of the unique edge identifier.
setEdgeComment     :: (LEdge b -> Attributes)
                      -> (LEdge (EdgeID b) -> Attributes)
setEdgeComment f = \ e@(_,_,eid) -> Comment (eID eid) : (f . stripID) e

-- | Remove the unique identifier from the 'LEdge'.
stripID           :: LEdge (EdgeID b) -> LEdge b
stripID (f,t,eid) = (f,t, eLbl eid)

-- | Pass the 'DotGraph' through the relevant command and then augment
--   the 'Graph' that it came from.
dotAttributes :: (Graph gr, DotRepr dg Node) => Bool -> gr a (EdgeID b)
                 -> dg Node -> IO (gr (AttributeNode a) (AttributeEdge b))
dotAttributes isDir gr dot
  = liftM (augmentGraph gr . parseDG . fromDotResult)
    $ graphvizWithHandle command dot DotOutput hGetContents'
    where
      parseDG = asTypeOf dot . parseDotGraph
      command = if isDir then dirCommand else undirCommand

-- | Use the 'Attributes' in the provided 'DotGraph' to augment the
--   node and edge labels in the provided 'Graph'.  The unique
--   identifiers on the edges are also stripped off.
--
--   Please note that the behaviour for this function is undefined if
--   the 'DotGraph' does not come from the original 'Graph' (either
--   by using a conversion function or by passing the result of a
--   conversion function through a 'GraphvizCommand' via the
--   'DotOutput' or similar).
augmentGraph      :: (Graph gr, DotRepr dg Node) => gr a (EdgeID b)
                     -> dg Node -> gr (AttributeNode a) (AttributeEdge b)
augmentGraph g dg = mkGraph lns les
  where
    lns = map (\(n, l) -> (n, (nodeMap Map.! n, l)))
          $ labNodes g
    les = map augmentEdge $ labEdges g
    augmentEdge (f,t,(EID eid l)) = (f,t, (edgeMap Map.! eid, l))
    ns = graphNodes dg
    es = graphEdges dg
    nodeMap = Map.fromList $ map (nodeID &&& nodeAttributes) ns
    edgeMap = Map.fromList $ map (findID &&& edgeAttributes') es
    findID = head . mapMaybe commentID . edgeAttributes
    commentID (Comment s) = Just s
    commentID _           = Nothing
    -- Strip out the comment
    edgeAttributes' = filter (isNothing . commentID) . edgeAttributes


-- -----------------------------------------------------------------------------
-- Utility Functions

-- | Pretty-print the 'DotGraph' by passing it through the 'Canon'
--   output type (which produces \"canonical\" output).  This is
--   required because the 'printDotGraph' function (and all printing
--   functions in "Data.GraphViz.Types.Printing") no longer uses
--   indentation (this is to ensure the Dot code is printed correctly
--   due to the limitations of the Pretty Printer used).
prettyPrint    :: (DotRepr dg n) => dg n -> IO String
prettyPrint dg = liftM fromDotResult
                 -- Note that the choice of command here should be
                 -- arbitrary.
                 $ graphvizWithHandle (commandFor dg)
                                      dg
                                      Canon
                                      hGetContents'

-- | The 'unsafePerformIO'd version of 'prettyPrint'.  Graphviz should
--   always produce the same pretty-printed output, so this should be
--   safe.
prettyPrint' :: (DotRepr dg n) => dg n -> String
prettyPrint' = unsafePerformIO . prettyPrint

-- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'.
preview   :: (Ord b, Graph gr) => gr a b -> IO ()
preview g = ign $ forkIO (ign $ runGraphvizCanvas' dg Xlib)
  where
    dg = graphToDot' g [] (const []) (const [])
    ign = (>> return ())

-- | Used for obtaining results from 'graphvizWithHandle', etc. when
--   errors should only occur when Graphviz isn't installed.  If the
--   value is @'Left' _@, then 'error' is used.
fromDotResult           :: Either l r -> r
fromDotResult (Right r) = r
fromDotResult Left{}    = error "Could not run the relevant Graphviz command; \
                                 \is the Graphviz suite of tools installed?"