{-# LANGUAGE OverloadedStrings #-}

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

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

-- |
-- Module     : Algebra.Graph.Export
-- 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 basic functionality for exporting graphs in textual and
-- binary formats. "Algebra.Graph.Export.Dot" provides DOT-specific functions.
module Cauldron.Graph.Export
  ( -- * Constructing and exporting documents
    Doc,
    isEmpty,
    literal,
    render,

    -- * Common combinators for text documents
    (<+>),
    brackets,
    doubleQuotes,
    indent,
    unlines,

    -- * Generic graph export
    export,
  )
where

import Cauldron.Graph (AdjacencyMap, edgeList, vertexList)
import Data.Foldable (fold)
import Data.String hiding (unlines)
import Prelude hiding (unlines)

-- | An abstract document data type with /O(1)/ time concatenation (the current
-- implementation uses difference lists). Here @s@ is the type of abstract
-- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore
-- 'mempty' corresponds to the /empty document/ and two documents can be
-- concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Documents
-- comprising a single symbol or string can be constructed using the function
-- 'literal'. Alternatively, you can construct documents as string literals,
-- e.g. simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To
-- extract the document contents use the function 'render'.
--
-- Note that the document comprising a single empty string is considered to be
-- different from the empty document. This design choice is motivated by the
-- desire to support string types @s@ that have no 'Eq' instance, such as
-- "Data.ByteString.Builder", for which there is no way to check whether a
-- string is empty or not. As a consequence, the 'Eq' and 'Ord' instances are
-- defined as follows:
--
-- @
-- 'mempty' /= 'literal' ""
-- 'mempty' <  'literal' ""
-- @
newtype Doc s = Doc [s] deriving (Semigroup (Doc s)
Doc s
Semigroup (Doc s) =>
Doc s
-> (Doc s -> Doc s -> Doc s)
-> ([Doc s] -> Doc s)
-> Monoid (Doc s)
[Doc s] -> Doc s
Doc s -> Doc s -> Doc s
forall s. Semigroup (Doc s)
forall s. Doc s
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall s. [Doc s] -> Doc s
forall s. Doc s -> Doc s -> Doc s
$cmempty :: forall s. Doc s
mempty :: Doc s
$cmappend :: forall s. Doc s -> Doc s -> Doc s
mappend :: Doc s -> Doc s -> Doc s
$cmconcat :: forall s. [Doc s] -> Doc s
mconcat :: [Doc s] -> Doc s
Monoid, NonEmpty (Doc s) -> Doc s
Doc s -> Doc s -> Doc s
(Doc s -> Doc s -> Doc s)
-> (NonEmpty (Doc s) -> Doc s)
-> (forall b. Integral b => b -> Doc s -> Doc s)
-> Semigroup (Doc s)
forall b. Integral b => b -> Doc s -> Doc s
forall s. NonEmpty (Doc s) -> Doc s
forall s. Doc s -> Doc s -> Doc s
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall s b. Integral b => b -> Doc s -> Doc s
$c<> :: forall s. Doc s -> Doc s -> Doc s
<> :: Doc s -> Doc s -> Doc s
$csconcat :: forall s. NonEmpty (Doc s) -> Doc s
sconcat :: NonEmpty (Doc s) -> Doc s
$cstimes :: forall s b. Integral b => b -> Doc s -> Doc s
stimes :: forall b. Integral b => b -> Doc s -> Doc s
Semigroup)

instance (Monoid s, Show s) => Show (Doc s) where
  show :: Doc s -> String
show = s -> String
forall a. Show a => a -> String
show (s -> String) -> (Doc s -> s) -> Doc s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc s -> s
forall s. Monoid s => Doc s -> s
render

instance (Monoid s, Eq s) => Eq (Doc s) where
  Doc s
x == :: Doc s -> Doc s -> Bool
== Doc s
y
    | Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
x = Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
y
    | Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
y = Bool
False
    | Bool
otherwise = Doc s -> s
forall s. Monoid s => Doc s -> s
render Doc s
x s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== Doc s -> s
forall s. Monoid s => Doc s -> s
render Doc s
y

-- | The empty document is smallest.
instance (Monoid s, Ord s) => Ord (Doc s) where
  compare :: Doc s -> Doc s -> Ordering
compare Doc s
x Doc s
y
    | Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
x = if Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
y then Ordering
EQ else Ordering
LT
    | Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
y = Ordering
GT
    | Bool
otherwise = s -> s -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Doc s -> s
forall s. Monoid s => Doc s -> s
render Doc s
x) (Doc s -> s
forall s. Monoid s => Doc s -> s
render Doc s
y)

instance (IsString s) => IsString (Doc s) where
  fromString :: String -> Doc s
fromString = s -> Doc s
forall s. s -> Doc s
literal (s -> Doc s) -> (String -> s) -> String -> Doc s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> s
forall a. IsString a => String -> a
fromString

-- | Check if a document is empty. The result is the same as when comparing the
-- given document to 'mempty', but this function does not require the 'Eq' @s@
-- constraint. Note that the document comprising a single empty string is
-- considered to be different from the empty document.
--
-- @
-- isEmpty 'mempty'       == True
-- isEmpty ('literal' \"\") == False
-- isEmpty x            == (x == 'mempty')
-- @
isEmpty :: Doc s -> Bool
isEmpty :: forall s. Doc s -> Bool
isEmpty (Doc [s]
xs) = [s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
xs

-- | Construct a document comprising a single symbol or string. If @s@ is an
-- instance of class 'IsString', then documents of type 'Doc' @s@ can be
-- constructed directly from string literals (see the second example below).
--
-- @
-- literal "Hello, " 'Data.Semigroup.<>' literal "World!" == literal "Hello, World!"
-- literal "I am just a string literal"  == "I am just a string literal"
-- 'render' . literal                      == 'id'
-- @
literal :: s -> Doc s
literal :: forall s. s -> Doc s
literal = [s] -> Doc s
forall s. [s] -> Doc s
Doc ([s] -> Doc s) -> (s -> [s]) -> s -> Doc s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> [s]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Render the document as a single string. An inverse of the function 'literal'.
--
-- @
-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s
-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") == "alga"
-- render 'mempty'                         == 'mempty'
-- render . 'literal'                      == 'id'
-- @
render :: (Monoid s) => Doc s -> s
render :: forall s. Monoid s => Doc s -> s
render (Doc [s]
x) = [s] -> s
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [s]
x

-- | Concatenate two documents, separated by a single space, unless one of the
-- documents is empty. The operator \<+\> is associative with identity 'mempty'.
--
-- @
-- x \<+\> 'mempty'         == x
-- 'mempty' \<+\> x         == x
-- x \<+\> (y \<+\> z)      == (x \<+\> y) \<+\> z
-- "name" \<+\> "surname" == "name surname"
-- @
(<+>) :: (IsString s) => Doc s -> Doc s -> Doc s
Doc s
x <+> :: forall s. IsString s => Doc s -> Doc s -> Doc s
<+> Doc s
y
  | Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
x = Doc s
y
  | Doc s -> Bool
forall s. Doc s -> Bool
isEmpty Doc s
y = Doc s
x
  | Bool
otherwise = Doc s
x Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
" " Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
y

infixl 7 <+>

-- | Wrap a document in square brackets.
--
-- @
-- brackets "i"    == "[i]"
-- brackets 'mempty' == "[]"
-- @
brackets :: (IsString s) => Doc s -> Doc s
brackets :: forall s. IsString s => Doc s -> Doc s
brackets Doc s
x = Doc s
"[" Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
x Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
"]"

-- | Wrap a document into double quotes.
--
-- @
-- doubleQuotes "\/path\/with spaces"   == "\\"\/path\/with spaces\\""
-- doubleQuotes (doubleQuotes 'mempty') == "\\"\\"\\"\\""
-- @
doubleQuotes :: (IsString s) => Doc s -> Doc s
doubleQuotes :: forall s. IsString s => Doc s -> Doc s
doubleQuotes Doc s
x = Doc s
"\"" Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
x Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
"\""

-- | Prepend a given number of spaces to a document.
--
-- @
-- indent 0        == 'id'
-- indent 1 'mempty' == " "
-- @
indent :: (IsString s) => Int -> Doc s -> Doc s
indent :: forall s. IsString s => Int -> Doc s -> Doc s
indent Int
spaces Doc s
x = String -> Doc s
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
spaces Char
' ') Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
x

-- | Concatenate documents after appending a terminating newline symbol to each.
--
-- @
-- unlines []                    == 'mempty'
-- unlines ['mempty']              == "\\n"
-- unlines ["title", "subtitle"] == "title\\nsubtitle\\n"
-- @
unlines :: (IsString s) => [Doc s] -> Doc s
unlines :: forall s. IsString s => [Doc s] -> Doc s
unlines [] = Doc s
forall a. Monoid a => a
mempty
unlines (Doc s
x : [Doc s]
xs) = Doc s
x Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
"\n" Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> [Doc s] -> Doc s
forall s. IsString s => [Doc s] -> Doc s
unlines [Doc s]
xs

-- TODO: Avoid round-trip graph conversion if g :: AdjacencyMap a.

-- | Export a graph into a document given two functions that construct documents
-- for individual vertices and edges. The order of export is: vertices, sorted
-- by 'Ord' @a@, and then edges, sorted by 'Ord' @(a, a)@.
--
-- For example:
--
-- @
-- vDoc x   = 'literal' ('show' x) <> "\\n"
-- eDoc x y = 'literal' ('show' x) <> " -> " <> 'literal' ('show' y) <> "\\n"
-- > putStrLn $ 'render' $ export vDoc eDoc (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int)
--
-- 1
-- 2
-- 3
-- 4
-- 2 -> 3
-- 2 -> 4
-- @
export :: (Ord a) => (a -> Doc s) -> (a -> a -> Doc s) -> AdjacencyMap a -> Doc s
export :: forall a s.
Ord a =>
(a -> Doc s) -> (a -> a -> Doc s) -> AdjacencyMap a -> Doc s
export a -> Doc s
v a -> a -> Doc s
e AdjacencyMap a
adjMap = Doc s
vDoc Doc s -> Doc s -> Doc s
forall a. Semigroup a => a -> a -> a
<> Doc s
eDoc
  where
    vDoc :: Doc s
vDoc = [Doc s] -> Doc s
forall m. Monoid m => [m] -> m
mconcat ([Doc s] -> Doc s) -> [Doc s] -> Doc s
forall a b. (a -> b) -> a -> b
$ (a -> Doc s) -> [a] -> [Doc s]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc s
v (AdjacencyMap a -> [a]
forall a. AdjacencyMap a -> [a]
vertexList AdjacencyMap a
adjMap)
    eDoc :: Doc s
eDoc = [Doc s] -> Doc s
forall m. Monoid m => [m] -> m
mconcat ([Doc s] -> Doc s) -> [Doc s] -> Doc s
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Doc s) -> [(a, a)] -> [Doc s]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a -> Doc s) -> (a, a) -> Doc s
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Doc s
e) (AdjacencyMap a -> [(a, a)]
forall a. AdjacencyMap a -> [(a, a)]
edgeList AdjacencyMap a
adjMap)