Dot.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Export.Dot
-- Copyright  : (c) Andrey Mokhov 2016-2024
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- __Alga__ is a library for algebraic construction and manipulation of graphs
-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the
-- motivation behind the library, the underlying theory, and implementation details.
--
-- This module defines functions for exporting graphs in the DOT file format.
-----------------------------------------------------------------------------
module Cauldron.Graph.Export.Dot (
    -- * Graph attributes and style
    Attribute (..), Quoting (..), Style (..), defaultStyle, defaultStyleViaShow,

    -- * Export functions
    export
    ) where

import Data.List (intersperse)
import Data.Monoid
import Data.String hiding (unlines)
import Prelude hiding (unlines)
import Cauldron.Graph
import Cauldron.Graph.Export hiding (export)
import Cauldron.Graph.Export qualified as E

-- | An attribute is just a key-value pair, for example @"shape" := "box"@.
-- Attributes are used to specify the style of graph elements during export.
data Attribute s = (:=) s s

-- TODO: Do we need other quoting styles, for example, 'SingleQuotes'?
-- TODO: Shall we use 'Quoting' for vertex names too?
-- | The style of quoting used when exporting attributes; 'DoubleQuotes' is the
-- default.
data Quoting = DoubleQuotes | NoQuotes

-- | The record 'Style' @a@ @s@ specifies the style to use when exporting a
-- graph in the DOT format. Here @a@ is the type of the graph vertices, and @s@
-- is the type of string to represent the resulting DOT document (e.g. String,
-- Text, etc.). The only field that has no obvious default value is
-- 'vertexName', which holds a function of type @a -> s@ to compute vertex
-- names. See the function 'export' for an example.
data Style a s = Style
    { graphName :: s
    -- ^ Name of the graph.
    , preamble :: [s]
    -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body.
    , graphAttributes :: [Attribute s]
    -- ^ Graph style, e.g. @["bgcolor" := "azure"]@.
    , defaultVertexAttributes :: [Attribute s]
    -- ^ Default vertex style, e.g. @["shape" := "diamond"]@.
    , defaultEdgeAttributes :: [Attribute s]
    -- ^ Default edge style, e.g. @["style" := "dashed"]@.
    , vertexName :: a -> s
    -- ^ Compute a vertex name.
    , vertexAttributes :: a -> [Attribute s]
    -- ^ Attributes of a specific vertex.
    , edgeAttributes   :: a -> a -> [Attribute s]
    -- ^ Attributes of a specific edge.
    , attributeQuoting :: Quoting
    -- ^ The quoting style used for attributes.
    }

-- | Default style for exporting graphs. The 'vertexName' field is provided as
-- the only argument; the other fields are set to trivial defaults.
defaultStyle :: Monoid s => (a -> s) -> Style a s
defaultStyle v = Style mempty [] [] [] [] v (const []) (\_ _ -> []) DoubleQuotes

-- | Default style for exporting graphs with 'Show'-able vertices. The
-- 'vertexName' field is computed using 'show'; the other fields are set to
-- trivial defaults.
--
-- @
-- defaultStyleViaShow = 'defaultStyle' ('fromString' . 'show')
-- @
defaultStyleViaShow :: (Show a, IsString s, Monoid s) => Style a s
defaultStyleViaShow = defaultStyle (fromString . show)

-- | Export a graph with a given style.
--
-- For example:
--
-- @
-- style :: 'Style' Int String
-- style = 'Style'
--     { 'graphName'               = \"Example\"
--     , 'preamble'                = ["  // This is an example", ""]
--     , 'graphAttributes'         = ["label" := \"Example\", "labelloc" := "top"]
--     , 'defaultVertexAttributes' = ["shape" := "circle"]
--     , 'defaultEdgeAttributes'   = 'mempty'
--     , 'vertexName'              = \\x   -> "v" ++ 'show' x
--     , 'vertexAttributes'        = \\x   -> ["color" := "blue"   | 'odd' x      ]
--     , 'edgeAttributes'          = \\x y -> ["style" := "dashed" | 'odd' (x * y)]
--     , 'attributeQuoting'        = 'DoubleQuotes' }
--
-- > putStrLn $ export style (1 * 2 + 3 * 4 * 5 :: 'Graph' Int)
--
-- digraph Example
-- {
--   // This is an example
--
--   graph [label=\"Example\" labelloc="top"]
--   node [shape="circle"]
--   "v1" [color="blue"]
--   "v2"
--   "v3" [color="blue"]
--   "v4"
--   "v5" [color="blue"]
--   "v1" -> "v2"
--   "v3" -> "v4"
--   "v3" -> "v5" [style="dashed"]
--   "v4" -> "v5"
-- }
-- @
export :: (IsString s, Monoid s, Ord a) => Style a s -> AdjacencyMap a -> s
export Style {..} g = E.render $ header <> body <> "}\n"
  where
    header    = "digraph" <+> literal graphName <> "\n{\n"
    with x as = if null as then mempty else line (x <+> attributes attributeQuoting as)
    line s    = indent 2 s <> "\n"
    body      = unlines (map literal preamble)
             <> ("graph" `with` graphAttributes)
             <> ("node"  `with` defaultVertexAttributes)
             <> ("edge"  `with` defaultEdgeAttributes)
             <> E.export vDoc eDoc g
    label     = doubleQuotes . literal . vertexName
    vDoc x    = line $ label x <+>                      attributes attributeQuoting (vertexAttributes x)
    eDoc x y  = line $ label x <> " -> " <> label y <+> attributes attributeQuoting (edgeAttributes x y)

-- | Export a list of attributes using a specified quoting style.
-- Example: @attributes DoubleQuotes ["label" := "A label", "shape" := "box"]@
-- corresponds to document: @[label="A label" shape="box"]@.
attributes :: IsString s => Quoting -> [Attribute s] -> Doc s
attributes _ [] = mempty
attributes q as = brackets . mconcat . intersperse " " $ map dot as
  where
    dot (k := v) = literal k <> "=" <> quote (literal v)
    quote = case q of
        DoubleQuotes -> doubleQuotes
        NoQuotes     -> id