{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Export.Dot
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- License    : MIT (see the file LICENSE)
-- Maintainer : [email protected]
-- 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 Algebra.Graph.Export.Dot (
    -- * Graph attributes and style
    Attribute (..), Quoting (..), Style (..), defaultStyle, defaultStyleViaShow,

    -- * Export functions
    export, exportAsIs, exportViaShow
    ) where

import Data.List (map, null, intersperse)
import Data.Monoid
import Data.String hiding (unlines)
import Prelude hiding (unlines)

import Algebra.Graph.ToGraph (ToGraph (..))
import Algebra.Graph.Export hiding (export)
import qualified Algebra.Graph.Export 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
    { forall a s. Style a s -> s
graphName :: s
    -- ^ Name of the graph.
    , forall a s. Style a s -> [s]
preamble :: [s]
    -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body.
    , forall a s. Style a s -> [Attribute s]
graphAttributes :: [Attribute s]
    -- ^ Graph style, e.g. @["bgcolor" := "azure"]@.
    , forall a s. Style a s -> [Attribute s]
defaultVertexAttributes :: [Attribute s]
    -- ^ Default vertex style, e.g. @["shape" := "diamond"]@.
    , forall a s. Style a s -> [Attribute s]
defaultEdgeAttributes :: [Attribute s]
    -- ^ Default edge style, e.g. @["style" := "dashed"]@.
    , forall a s. Style a s -> a -> s
vertexName :: a -> s
    -- ^ Compute a vertex name.
    , forall a s. Style a s -> a -> [Attribute s]
vertexAttributes :: a -> [Attribute s]
    -- ^ Attributes of a specific vertex.
    , forall a s. Style a s -> a -> a -> [Attribute s]
edgeAttributes   :: a -> a -> [Attribute s]
    -- ^ Attributes of a specific edge.
    , forall a s. Style a s -> Quoting
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 :: forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle a -> s
v = forall a s.
s
-> [s]
-> [Attribute s]
-> [Attribute s]
-> [Attribute s]
-> (a -> s)
-> (a -> [Attribute s])
-> (a -> a -> [Attribute s])
-> Quoting
-> Style a s
Style forall a. Monoid a => a
mempty [] [] [] [] a -> s
v (forall a b. a -> b -> a
const []) (\a
_ a
_ -> []) Quoting
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 :: forall a s. (Show a, IsString s, Monoid s) => Style a s
defaultStyleViaShow = forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
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, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s
export :: forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export Style {s
[s]
[Attribute s]
Quoting
a -> s
a -> [Attribute s]
a -> a -> [Attribute s]
attributeQuoting :: Quoting
edgeAttributes :: a -> a -> [Attribute s]
vertexAttributes :: a -> [Attribute s]
vertexName :: a -> s
defaultEdgeAttributes :: [Attribute s]
defaultVertexAttributes :: [Attribute s]
graphAttributes :: [Attribute s]
preamble :: [s]
graphName :: s
attributeQuoting :: forall a s. Style a s -> Quoting
edgeAttributes :: forall a s. Style a s -> a -> a -> [Attribute s]
vertexAttributes :: forall a s. Style a s -> a -> [Attribute s]
vertexName :: forall a s. Style a s -> a -> s
defaultEdgeAttributes :: forall a s. Style a s -> [Attribute s]
defaultVertexAttributes :: forall a s. Style a s -> [Attribute s]
graphAttributes :: forall a s. Style a s -> [Attribute s]
preamble :: forall a s. Style a s -> [s]
graphName :: forall a s. Style a s -> s
..} g
g = forall s. Monoid s => Doc s -> s
render forall a b. (a -> b) -> a -> b
$ Doc s
header forall a. Semigroup a => a -> a -> a
<> Doc s
body forall a. Semigroup a => a -> a -> a
<> Doc s
"}\n"
  where
    header :: Doc s
header    = Doc s
"digraph" forall s. IsString s => Doc s -> Doc s -> Doc s
<+> forall s. s -> Doc s
literal s
graphName forall a. Semigroup a => a -> a -> a
<> Doc s
"\n{\n"
    with :: Doc s -> [Attribute s] -> Doc s
with Doc s
x [Attribute s]
as = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attribute s]
as then forall a. Monoid a => a
mempty else forall {s}. IsString s => Doc s -> Doc s
line (Doc s
x forall s. IsString s => Doc s -> Doc s -> Doc s
<+> forall s. IsString s => Quoting -> [Attribute s] -> Doc s
attributes Quoting
attributeQuoting [Attribute s]
as)
    line :: Doc s -> Doc s
line Doc s
s    = forall s. IsString s => Int -> Doc s -> Doc s
indent Int
2 Doc s
s forall a. Semigroup a => a -> a -> a
<> Doc s
"\n"
    body :: Doc s
body      = forall s. IsString s => [Doc s] -> Doc s
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall s. s -> Doc s
literal [s]
preamble)
             forall a. Semigroup a => a -> a -> a
<> (Doc s
"graph" Doc s -> [Attribute s] -> Doc s
`with` [Attribute s]
graphAttributes)
             forall a. Semigroup a => a -> a -> a
<> (Doc s
"node"  Doc s -> [Attribute s] -> Doc s
`with` [Attribute s]
defaultVertexAttributes)
             forall a. Semigroup a => a -> a -> a
<> (Doc s
"edge"  Doc s -> [Attribute s] -> Doc s
`with` [Attribute s]
defaultEdgeAttributes)
             forall a. Semigroup a => a -> a -> a
<> forall a g s.
(Ord a, ToGraph g, ToVertex g ~ a) =>
(a -> Doc s) -> (a -> a -> Doc s) -> g -> Doc s
E.export a -> Doc s
vDoc a -> a -> Doc s
eDoc g
g
    label :: a -> Doc s
label     = forall {s}. IsString s => Doc s -> Doc s
doubleQuotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. s -> Doc s
literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> s
vertexName
    vDoc :: a -> Doc s
vDoc a
x    = forall {s}. IsString s => Doc s -> Doc s
line forall a b. (a -> b) -> a -> b
$ a -> Doc s
label a
x forall s. IsString s => Doc s -> Doc s -> Doc s
<+>                      forall s. IsString s => Quoting -> [Attribute s] -> Doc s
attributes Quoting
attributeQuoting (a -> [Attribute s]
vertexAttributes a
x)
    eDoc :: a -> a -> Doc s
eDoc a
x a
y  = forall {s}. IsString s => Doc s -> Doc s
line forall a b. (a -> b) -> a -> b
$ a -> Doc s
label a
x forall a. Semigroup a => a -> a -> a
<> Doc s
" -> " forall a. Semigroup a => a -> a -> a
<> a -> Doc s
label a
y forall s. IsString s => Doc s -> Doc s -> Doc s
<+> forall s. IsString s => Quoting -> [Attribute s] -> Doc s
attributes Quoting
attributeQuoting (a -> a -> [Attribute s]
edgeAttributes a
x a
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 :: forall s. IsString s => Quoting -> [Attribute s] -> Doc s
attributes Quoting
_ [] = forall a. Monoid a => a
mempty
attributes Quoting
q [Attribute s]
as = forall {s}. IsString s => Doc s -> Doc s
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse Doc s
" " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Attribute s -> Doc s
dot [Attribute s]
as
  where
    dot :: Attribute s -> Doc s
dot (s
k := s
v) = forall s. s -> Doc s
literal s
k forall a. Semigroup a => a -> a -> a
<> Doc s
"=" forall a. Semigroup a => a -> a -> a
<> Doc s -> Doc s
quote (forall s. s -> Doc s
literal s
v)
    quote :: Doc s -> Doc s
quote = case Quoting
q of
        Quoting
DoubleQuotes -> forall {s}. IsString s => Doc s -> Doc s
doubleQuotes
        Quoting
NoQuotes     -> forall a. a -> a
id

-- | Export a graph whose vertices are represented simply by their names.
--
-- For example:
--
-- @
-- > Text.putStrLn $ exportAsIs ('Algebra.Graph.AdjacencyMap.circuit' ["a", "b", "c"] :: 'Algebra.Graph.AdjacencyMap.AdjacencyMap' Text)
--
-- digraph
-- {
--   "a"
--   "b"
--   "c"
--   "a" -> "b"
--   "b" -> "c"
--   "c" -> "a"
-- }
-- @
exportAsIs :: (IsString s, Monoid s, Ord (ToVertex g), ToGraph g, ToVertex g ~ s) => g -> s
exportAsIs :: forall s g.
(IsString s, Monoid s, Ord (ToVertex g), ToGraph g,
 ToVertex g ~ s) =>
g -> s
exportAsIs = forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export (forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle forall a. a -> a
id)

-- | Export a graph using the 'defaultStyleViaShow'.
--
-- For example:
--
-- @
-- > putStrLn $ exportViaShow (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int)
--
-- digraph
-- {
--   "1"
--   "2"
--   "3"
--   "4"
--   "2" -> "3"
--   "2" -> "4"
-- }
-- @
exportViaShow :: (IsString s, Monoid s, Ord (ToVertex g), Show (ToVertex g), ToGraph g) => g -> s
exportViaShow :: forall s g.
(IsString s, Monoid s, Ord (ToVertex g), Show (ToVertex g),
 ToGraph g) =>
g -> s
exportViaShow = forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export forall a s. (Show a, IsString s, Monoid s) => Style a s
defaultStyleViaShow