{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Abstract Grammar for the dot language.
-- http://www.graphviz.org/doc/info/lang.html
module DotParse.Types
  ( DotConfig (..),
    defaultDotConfig,
    DotParse (..),
    testDotParser,
    runDotParser,
    Error (..),
    prettyError,
    Graph (..),
    gattL,
    attL,
    defaultGraph,
    processDotWith,
    processDot,
    processGraph,
    processGraphWith,

    -- * components
    Strict (..),
    defStrict,
    Directed (..),
    defDirected,
    ID (..),
    label,
    Compass (..),
    Port (..),
    AttributeType (..),
    AttributeStatement (..),
    NodeStatement (..),
    EdgeID (..),
    EdgeOp (..),
    fromDirected,
    EdgeStatement (..),
    edgeID,
    edgeIDs,
    edgeIDsNamed,
    Statement (..),
    addStatement,
    addStatements,
    SubGraphStatement (..),
    GlobalAttributeStatement (..),

    -- * Graph Extraction
    bbL,
    nodesPortL,
    nodesL,
    edgesL,
    nodesA,
    edgesA,
    nodePos,
    nodeWidth,
    edgeSpline,
    edgeWidth,
    NodeInfo (..),
    nodeInfo,
    EdgeInfo (..),
    edgeInfo,
    splinePath,

    -- * Conversion
    graphToChartWith,
    graphToChart,
    ChartConfig (..),
    defaultChartConfig,
    toStatements,
    toDotGraph,
    toDotGraphWith,
  )
where

import Algebra.Graph qualified as G
import Chart
import Control.Monad
import Data.Bool
import Data.ByteString hiding (any, empty, filter, head, length, map, zip, zipWith)
import Data.ByteString.Char8 qualified as B
import Data.List.NonEmpty hiding (filter, head, length, map, zip, zipWith, (!!))
import Data.Map.Merge.Strict
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as Text
import Data.These
import DotParse.FlatParse
import FlatParse.Basic hiding (cut)
import GHC.Generics
import Optics.Core
import System.Exit
import System.Process.ByteString
import Prelude hiding (replicate)

-- $setup
-- >>> import DotParse
-- >>> import qualified Data.Map as Map
-- >>> import qualified FlatParse.Basic as FP
-- >>> import qualified Data.ByteString as BS
-- >>> import FlatParse.Basic (runParser, Result)
-- >>> :set -XOverloadedStrings

-- | printing options, for separators.
data DotConfig = DotConfig
  { DotConfig -> ByteString
topLevelSep :: ByteString,
    DotConfig -> ByteString
statementSep :: ByteString,
    DotConfig -> ByteString
attSep :: ByteString,
    DotConfig -> ByteString
subGraphSep :: ByteString
  }
  deriving (DotConfig -> DotConfig -> Bool
(DotConfig -> DotConfig -> Bool)
-> (DotConfig -> DotConfig -> Bool) -> Eq DotConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DotConfig -> DotConfig -> Bool
== :: DotConfig -> DotConfig -> Bool
$c/= :: DotConfig -> DotConfig -> Bool
/= :: DotConfig -> DotConfig -> Bool
Eq, Int -> DotConfig -> ShowS
[DotConfig] -> ShowS
DotConfig -> String
(Int -> DotConfig -> ShowS)
-> (DotConfig -> String)
-> ([DotConfig] -> ShowS)
-> Show DotConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DotConfig -> ShowS
showsPrec :: Int -> DotConfig -> ShowS
$cshow :: DotConfig -> String
show :: DotConfig -> String
$cshowList :: [DotConfig] -> ShowS
showList :: [DotConfig] -> ShowS
Show, (forall x. DotConfig -> Rep DotConfig x)
-> (forall x. Rep DotConfig x -> DotConfig) -> Generic DotConfig
forall x. Rep DotConfig x -> DotConfig
forall x. DotConfig -> Rep DotConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DotConfig -> Rep DotConfig x
from :: forall x. DotConfig -> Rep DotConfig x
$cto :: forall x. Rep DotConfig x -> DotConfig
to :: forall x. Rep DotConfig x -> DotConfig
Generic)

-- | default separators
defaultDotConfig :: DotConfig
defaultDotConfig :: DotConfig
defaultDotConfig = ByteString -> ByteString -> ByteString -> ByteString -> DotConfig
DotConfig ByteString
" " ByteString
"\n    " ByteString
";" ByteString
";"

-- | A parser & printer class for a graphviz graph and components of its dot language
class DotParse a where
  dotPrint :: DotConfig -> a -> ByteString
  dotParse :: Parser Error a

-- | dotParse and then dotPrint:
--
-- - pretty printing error on failure.
--
-- - This is not an exact parser/printer, so the test re-parses the dotPrint, which should be idempotent
testDotParser :: forall a. (DotParse a) => Proxy a -> DotConfig -> ByteString -> IO ()
testDotParser :: forall a. DotParse a => Proxy a -> DotConfig -> ByteString -> IO ()
testDotParser Proxy a
_ DotConfig
cfg ByteString
b =
  case Parser Error a -> ByteString -> Result Error a
forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
forall a. DotParse a => Parser Error a
dotParse ByteString
b :: Result Error a of
    Err Error
e -> ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> ByteString
prettyError ByteString
b Error
e
    OK a
a ByteString
left -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
left ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"parsed with leftovers: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
left)
      case Parser Error a -> ByteString -> Result Error a
forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
forall a. DotParse a => Parser Error a
dotParse (DotConfig -> a -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg a
a) :: Result Error a of
        Err Error
e -> ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"round trip error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Error -> ByteString
prettyError (DotConfig -> a -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg a
a) Error
e
        Result Error a
Fail -> ByteString -> IO ()
B.putStrLn ByteString
"uncaught round trip parse error"
        OK a
_ ByteString
left' -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
left' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"round trip parse with left overs" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
left)
    Result Error a
Fail -> ByteString -> IO ()
B.putStrLn ByteString
"uncaught parse error"

-- | run a dotParse erroring on leftovers, Fail or Err
runDotParser :: (DotParse a) => ByteString -> a
runDotParser :: forall a. DotParse a => ByteString -> a
runDotParser = Parser Error a -> ByteString -> a
forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error a
forall a. DotParse a => Parser Error a
dotParse

-- | Representation of a full graphviz graph, as per the dot language specification
data Graph = Graph
  { Graph -> Last Strict
strict :: Last Strict,
    Graph -> Last Directed
directed :: Last Directed,
    Graph -> Last ID
graphid :: Last ID,
    Graph -> Map ID ID
nodeAttributes :: Map.Map ID ID,
    Graph -> Map ID ID
graphAttributes :: Map.Map ID ID,
    Graph -> Map ID ID
edgeAttributes :: Map.Map ID ID,
    Graph -> Map ID ID
globalAttributes :: Map.Map ID ID,
    Graph -> [NodeStatement]
nodes :: [NodeStatement],
    Graph -> [EdgeStatement]
edges :: [EdgeStatement],
    Graph -> [SubGraphStatement]
subgraphs :: [SubGraphStatement]
  }
  deriving (Graph -> Graph -> Bool
(Graph -> Graph -> Bool) -> (Graph -> Graph -> Bool) -> Eq Graph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Graph -> Graph -> Bool
== :: Graph -> Graph -> Bool
$c/= :: Graph -> Graph -> Bool
/= :: Graph -> Graph -> Bool
Eq, Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Int -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Graph -> ShowS
showsPrec :: Int -> Graph -> ShowS
$cshow :: Graph -> String
show :: Graph -> String
$cshowList :: [Graph] -> ShowS
showList :: [Graph] -> ShowS
Show, (forall x. Graph -> Rep Graph x)
-> (forall x. Rep Graph x -> Graph) -> Generic Graph
forall x. Rep Graph x -> Graph
forall x. Graph -> Rep Graph x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Graph -> Rep Graph x
from :: forall x. Graph -> Rep Graph x
$cto :: forall x. Rep Graph x -> Graph
to :: forall x. Rep Graph x -> Graph
Generic)

instance Semigroup Graph where
  (Graph Last Strict
m Last Directed
d Last ID
i Map ID ID
na Map ID ID
ga Map ID ID
ea Map ID ID
gs [NodeStatement]
ns [EdgeStatement]
es [SubGraphStatement]
ss) <> :: Graph -> Graph -> Graph
<> (Graph Last Strict
m' Last Directed
d' Last ID
i' Map ID ID
na' Map ID ID
ga' Map ID ID
ea' Map ID ID
gs' [NodeStatement]
ns' [EdgeStatement]
es' [SubGraphStatement]
ss') =
    Last Strict
-> Last Directed
-> Last ID
-> Map ID ID
-> Map ID ID
-> Map ID ID
-> Map ID ID
-> [NodeStatement]
-> [EdgeStatement]
-> [SubGraphStatement]
-> Graph
Graph (Last Strict
m Last Strict -> Last Strict -> Last Strict
forall a. Semigroup a => a -> a -> a
<> Last Strict
m') (Last Directed
d Last Directed -> Last Directed -> Last Directed
forall a. Semigroup a => a -> a -> a
<> Last Directed
d') (Last ID
i Last ID -> Last ID -> Last ID
forall a. Semigroup a => a -> a -> a
<> Last ID
i') (Map ID ID
na Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
na') (Map ID ID
ga Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
ga') (Map ID ID
ea Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
ea') (Map ID ID
gs Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
gs') ([NodeStatement]
ns [NodeStatement] -> [NodeStatement] -> [NodeStatement]
forall a. Semigroup a => a -> a -> a
<> [NodeStatement]
ns') ([EdgeStatement]
es [EdgeStatement] -> [EdgeStatement] -> [EdgeStatement]
forall a. Semigroup a => a -> a -> a
<> [EdgeStatement]
es') ([SubGraphStatement]
ss [SubGraphStatement] -> [SubGraphStatement] -> [SubGraphStatement]
forall a. Semigroup a => a -> a -> a
<> [SubGraphStatement]
ss')

instance Monoid Graph where
  mempty :: Graph
mempty = Last Strict
-> Last Directed
-> Last ID
-> Map ID ID
-> Map ID ID
-> Map ID ID
-> Map ID ID
-> [NodeStatement]
-> [EdgeStatement]
-> [SubGraphStatement]
-> Graph
Graph Last Strict
forall a. Monoid a => a
mempty Last Directed
forall a. Monoid a => a
mempty Last ID
forall a. Monoid a => a
mempty Map ID ID
forall a. Monoid a => a
mempty Map ID ID
forall a. Monoid a => a
mempty Map ID ID
forall a. Monoid a => a
mempty Map ID ID
forall a. Monoid a => a
mempty [NodeStatement]
forall a. Monoid a => a
mempty [EdgeStatement]
forall a. Monoid a => a
mempty [SubGraphStatement]
forall a. Monoid a => a
mempty

-- | 'Directed' graph of size 1.
--
-- >>> BS.putStr $ dotPrint defaultDotConfig defaultGraph <> "\n"
-- digraph {
--     node [height=0.5;shape=circle]
--     graph [overlap=false;size="1!";splines=spline]
--     edge [arrowsize=0.5]
--     rankdir="TB"
--     }
defaultGraph :: Graph
defaultGraph :: Graph
defaultGraph =
  Graph
forall a. Monoid a => a
mempty
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"height")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ID -> Maybe ID) -> ID -> Maybe ID
forall a b. (a -> b) -> a -> b
$ Double -> ID
IDDouble Double
0.5)
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"shape")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ID -> Maybe ID) -> ID -> Maybe ID
forall a b. (a -> b) -> a -> b
$ ByteString -> ID
ID ByteString
"circle")
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
GraphType (ByteString -> ID
ID ByteString
"overlap")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ID -> Maybe ID) -> ID -> Maybe ID
forall a b. (a -> b) -> a -> b
$ ByteString -> ID
ID ByteString
"false")
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
GraphType (ByteString -> ID
ID ByteString
"size")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ID -> Maybe ID) -> ID -> Maybe ID
forall a b. (a -> b) -> a -> b
$ ByteString -> ID
IDQuoted ByteString
"1!")
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
GraphType (ByteString -> ID
ID ByteString
"splines")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ID -> Maybe ID) -> ID -> Maybe ID
forall a b. (a -> b) -> a -> b
$ ByteString -> ID
ID ByteString
"spline")
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
EdgeType (ByteString -> ID
ID ByteString
"arrowsize")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ID -> Maybe ID) -> ID -> Maybe ID
forall a b. (a -> b) -> a -> b
$ Double -> ID
IDDouble Double
0.5)
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
-> Last Directed -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
#directed (Maybe Directed -> Last Directed
forall a. Maybe a -> Last a
Last (Directed -> Maybe Directed
forall a. a -> Maybe a
Just Directed
Directed))
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
gattL (ByteString -> ID
ID ByteString
"rankdir")) (ID -> Maybe ID
forall a. a -> Maybe a
Just (ByteString -> ID
IDQuoted ByteString
"TB"))

-- | global attributes lens
gattL :: ID -> Lens' Graph (Maybe ID)
gattL :: ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
gattL ID
k = Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#globalAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> Optic A_Lens NoIx (Map ID ID) (Map ID ID) (Maybe ID) (Maybe ID)
-> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map ID ID)
-> Lens' (Map ID ID) (Maybe (IxValue (Map ID ID)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ID ID)
ID
k

-- | attributes lens
attL :: AttributeType -> ID -> Lens' Graph (Maybe ID)
attL :: AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
GraphType ID
k = Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#graphAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> Optic A_Lens NoIx (Map ID ID) (Map ID ID) (Maybe ID) (Maybe ID)
-> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map ID ID)
-> Lens' (Map ID ID) (Maybe (IxValue (Map ID ID)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ID ID)
ID
k
attL AttributeType
NodeType ID
k = Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#nodeAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> Optic A_Lens NoIx (Map ID ID) (Map ID ID) (Maybe ID) (Maybe ID)
-> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map ID ID)
-> Lens' (Map ID ID) (Maybe (IxValue (Map ID ID)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ID ID)
ID
k
attL AttributeType
EdgeType ID
k = Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#edgeAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> Optic A_Lens NoIx (Map ID ID) (Map ID ID) (Maybe ID) (Maybe ID)
-> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map ID ID)
-> Lens' (Map ID ID) (Maybe (IxValue (Map ID ID)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ID ID)
ID
k

outercalate :: ByteString -> [ByteString] -> ByteString
outercalate :: ByteString -> [ByteString] -> ByteString
outercalate ByteString
_ [] = ByteString
forall a. Monoid a => a
mempty
outercalate ByteString
a [ByteString]
xs = ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
intercalate ByteString
a [ByteString]
xs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
a

instance DotParse Graph where
  dotPrint :: DotConfig -> Graph -> ByteString
dotPrint DotConfig
cfg (Graph Last Strict
me Last Directed
d Last ID
i Map ID ID
na Map ID ID
ga Map ID ID
ea Map ID ID
gs [NodeStatement]
ns [EdgeStatement]
es [SubGraphStatement]
ss) =
    ByteString -> [ByteString] -> ByteString
intercalate (DotConfig
cfg DotConfig -> Optic' A_Lens NoIx DotConfig ByteString -> ByteString
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx DotConfig ByteString
#topLevelSep) ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      [ByteString] -> [ByteString] -> Bool -> [ByteString]
forall a. a -> a -> Bool -> a
bool [] [ByteString
"strict"] (Last Strict
me Last Strict -> Last Strict -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Strict -> Last Strict
forall a. Maybe a -> Last a
Last (Strict -> Maybe Strict
forall a. a -> Maybe a
Just Strict
MergeEdges))
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> [ByteString] -> Bool -> [ByteString]
forall a. a -> a -> Bool -> a
bool [ByteString
"digraph"] [ByteString
"graph"] (Last Directed
d Last Directed -> Last Directed -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Directed -> Last Directed
forall a. Maybe a -> Last a
Last (Directed -> Maybe Directed
forall a. a -> Maybe a
Just Directed
UnDirected))
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> (ID -> [ByteString]) -> Maybe ID -> [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: []) (ByteString -> [ByteString])
-> (ID -> ByteString) -> ID -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg) (Last ID -> Maybe ID
forall a. Last a -> Maybe a
getLast Last ID
i)
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ ByteString -> ByteString
wrapCurlyPrint (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
               ByteString -> [ByteString] -> ByteString
outercalate
                 (DotConfig
cfg DotConfig -> Optic' A_Lens NoIx DotConfig ByteString -> ByteString
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx DotConfig ByteString
#statementSep)
                 ( [DotConfig -> AttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (AttributeType -> Map ID ID -> AttributeStatement
AttributeStatement AttributeType
NodeType Map ID ID
na)]
                     [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [DotConfig -> AttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (AttributeType -> Map ID ID -> AttributeStatement
AttributeStatement AttributeType
GraphType Map ID ID
ga)]
                     [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [DotConfig -> AttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (AttributeType -> Map ID ID -> AttributeStatement
AttributeStatement AttributeType
EdgeType Map ID ID
ea)]
                     [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> GlobalAttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (GlobalAttributeStatement -> ByteString)
-> ((ID, ID) -> GlobalAttributeStatement) -> (ID, ID) -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ID, ID) -> GlobalAttributeStatement
GlobalAttributeStatement ((ID, ID) -> ByteString) -> [(ID, ID)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ID ID -> [(ID, ID)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ID ID
gs)
                     [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> NodeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (NodeStatement -> ByteString) -> [NodeStatement] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeStatement]
ns)
                     [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> EdgeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (EdgeStatement -> ByteString) -> [EdgeStatement] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [EdgeStatement]
es)
                     [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> SubGraphStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (SubGraphStatement -> ByteString)
-> [SubGraphStatement] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SubGraphStatement]
ss)
                 )
           ]

  dotParse :: Parser Error Graph
dotParse = Parser Error Graph -> Parser Error Graph
forall e a. Parser e a -> Parser e a
token (Parser Error Graph -> Parser Error Graph)
-> Parser Error Graph -> Parser Error Graph
forall a b. (a -> b) -> a -> b
$ do
    Strict
me <- Parser Error Strict
forall a. DotParse a => Parser Error a
dotParse
    Directed
d <- Parser Error Directed
forall a. DotParse a => Parser Error a
dotParse
    Maybe ID
i <- ParserT PureMode Error ID -> ParserT PureMode Error (Maybe ID)
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse
    [Statement]
ss <- Parser Error [Statement] -> Parser Error [Statement]
forall a. Parser Error a -> Parser Error a
wrapCurlyP (ParserT PureMode Error Statement -> Parser Error [Statement]
forall a. ParserT PureMode Error a -> ParserT PureMode Error [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParserT PureMode Error Statement
forall a. DotParse a => Parser Error a
dotParse)
    let g :: Graph
g =
          (Graph
forall a. Monoid a => a
mempty :: Graph)
            Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Last Strict) (Last Strict)
#strict
            Optic A_Lens NoIx Graph Graph (Last Strict) (Last Strict)
-> Last Strict -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Maybe Strict -> Last Strict
forall a. Maybe a -> Last a
Last (Strict -> Maybe Strict
forall a. a -> Maybe a
Just Strict
me)
            Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
#directed
            Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
-> Last Directed -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Maybe Directed -> Last Directed
forall a. Maybe a -> Last a
Last (Directed -> Maybe Directed
forall a. a -> Maybe a
Just Directed
d)
            Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Last ID) (Last ID)
#graphid
            Optic A_Lens NoIx Graph Graph (Last ID) (Last ID)
-> Last ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Maybe ID -> Last ID
forall a. Maybe a -> Last a
Last Maybe ID
i
    Graph -> Parser Error Graph
forall a. a -> ParserT PureMode Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Graph -> Parser Error Graph) -> Graph -> Parser Error Graph
forall a b. (a -> b) -> a -> b
$ [Statement] -> Graph -> Graph
addStatements [Statement]
ss Graph
g

-- * Dot Grammar

-- | MergeEdges (strict)
data Strict = MergeEdges | NoMergeEdges deriving (Strict -> Strict -> Bool
(Strict -> Strict -> Bool)
-> (Strict -> Strict -> Bool) -> Eq Strict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Strict -> Strict -> Bool
== :: Strict -> Strict -> Bool
$c/= :: Strict -> Strict -> Bool
/= :: Strict -> Strict -> Bool
Eq, Int -> Strict -> ShowS
[Strict] -> ShowS
Strict -> String
(Int -> Strict -> ShowS)
-> (Strict -> String) -> ([Strict] -> ShowS) -> Show Strict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Strict -> ShowS
showsPrec :: Int -> Strict -> ShowS
$cshow :: Strict -> String
show :: Strict -> String
$cshowList :: [Strict] -> ShowS
showList :: [Strict] -> ShowS
Show, (forall x. Strict -> Rep Strict x)
-> (forall x. Rep Strict x -> Strict) -> Generic Strict
forall x. Rep Strict x -> Strict
forall x. Strict -> Rep Strict x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Strict -> Rep Strict x
from :: forall x. Strict -> Rep Strict x
$cto :: forall x. Rep Strict x -> Strict
to :: forall x. Rep Strict x -> Strict
Generic)

instance DotParse Strict where
  dotPrint :: DotConfig -> Strict -> ByteString
dotPrint DotConfig
_ Strict
MergeEdges = ByteString
"strict"
  dotPrint DotConfig
_ Strict
NoMergeEdges = ByteString
""

  dotParse :: Parser Error Strict
dotParse = Parser Error Strict -> Parser Error Strict
forall e a. Parser e a -> Parser e a
token (Parser Error Strict -> Parser Error Strict)
-> Parser Error Strict -> Parser Error Strict
forall a b. (a -> b) -> a -> b
$ ParserT PureMode Error ()
-> (() -> Parser Error Strict)
-> Parser Error Strict
-> Parser Error Strict
forall (st :: ZeroBitType) e a r.
ParserT st e a
-> (a -> ParserT st e r) -> ParserT st e r -> ParserT st e r
withOption ($(keyword "strict")) (Parser Error Strict -> () -> Parser Error Strict
forall a b. a -> b -> a
const (Parser Error Strict -> () -> Parser Error Strict)
-> Parser Error Strict -> () -> Parser Error Strict
forall a b. (a -> b) -> a -> b
$ Strict -> Parser Error Strict
forall a. a -> ParserT PureMode Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Strict
MergeEdges) (Strict -> Parser Error Strict
forall a. a -> ParserT PureMode Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Strict
NoMergeEdges)

-- | Default Strict is NoMergeEdges
defStrict :: Last Strict -> Strict
defStrict :: Last Strict -> Strict
defStrict (Last Maybe Strict
Nothing) = Strict
NoMergeEdges
defStrict (Last (Just Strict
x)) = Strict
x

-- | Directed (digraph | graph)
data Directed = Directed | UnDirected deriving (Directed -> Directed -> Bool
(Directed -> Directed -> Bool)
-> (Directed -> Directed -> Bool) -> Eq Directed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Directed -> Directed -> Bool
== :: Directed -> Directed -> Bool
$c/= :: Directed -> Directed -> Bool
/= :: Directed -> Directed -> Bool
Eq, Int -> Directed -> ShowS
[Directed] -> ShowS
Directed -> String
(Int -> Directed -> ShowS)
-> (Directed -> String) -> ([Directed] -> ShowS) -> Show Directed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Directed -> ShowS
showsPrec :: Int -> Directed -> ShowS
$cshow :: Directed -> String
show :: Directed -> String
$cshowList :: [Directed] -> ShowS
showList :: [Directed] -> ShowS
Show, (forall x. Directed -> Rep Directed x)
-> (forall x. Rep Directed x -> Directed) -> Generic Directed
forall x. Rep Directed x -> Directed
forall x. Directed -> Rep Directed x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Directed -> Rep Directed x
from :: forall x. Directed -> Rep Directed x
$cto :: forall x. Rep Directed x -> Directed
to :: forall x. Rep Directed x -> Directed
Generic)

instance DotParse Directed where
  dotPrint :: DotConfig -> Directed -> ByteString
dotPrint DotConfig
_ Directed
Directed = ByteString
"digraph"
  dotPrint DotConfig
_ Directed
UnDirected = ByteString
"graph"

  dotParse :: Parser Error Directed
dotParse =
    Parser Error Directed -> Parser Error Directed
forall e a. Parser e a -> Parser e a
token (Parser Error Directed -> Parser Error Directed)
-> Parser Error Directed -> Parser Error Directed
forall a b. (a -> b) -> a -> b
$
      (Directed
Directed Directed -> ParserT PureMode Error () -> Parser Error Directed
forall a b.
a -> ParserT PureMode Error b -> ParserT PureMode Error a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "digraph"))
        Parser Error Directed
-> Parser Error Directed -> Parser Error Directed
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Directed
UnDirected Directed -> ParserT PureMode Error () -> Parser Error Directed
forall a b.
a -> ParserT PureMode Error b -> ParserT PureMode Error a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "graph"))

-- | Default Directed is Directed
defDirected :: Last Directed -> Directed
defDirected :: Last Directed -> Directed
defDirected (Last Maybe Directed
Nothing) = Directed
Directed
defDirected (Last (Just Directed
x)) = Directed
x

-- | A dot statement as per the dot language specification.
data Statement = StatementNode NodeStatement | StatementEdge EdgeStatement | StatementGlobalAttribute GlobalAttributeStatement | StatementAttribute AttributeStatement | StatementSubGraph SubGraphStatement deriving (Statement -> Statement -> Bool
(Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool) -> Eq Statement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
/= :: Statement -> Statement -> Bool
Eq, Int -> Statement -> ShowS
[Statement] -> ShowS
Statement -> String
(Int -> Statement -> ShowS)
-> (Statement -> String)
-> ([Statement] -> ShowS)
-> Show Statement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Statement -> ShowS
showsPrec :: Int -> Statement -> ShowS
$cshow :: Statement -> String
show :: Statement -> String
$cshowList :: [Statement] -> ShowS
showList :: [Statement] -> ShowS
Show, (forall x. Statement -> Rep Statement x)
-> (forall x. Rep Statement x -> Statement) -> Generic Statement
forall x. Rep Statement x -> Statement
forall x. Statement -> Rep Statement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Statement -> Rep Statement x
from :: forall x. Statement -> Rep Statement x
$cto :: forall x. Rep Statement x -> Statement
to :: forall x. Rep Statement x -> Statement
Generic)

instance DotParse Statement where
  dotPrint :: DotConfig -> Statement -> ByteString
dotPrint DotConfig
cfg (StatementNode NodeStatement
x) = DotConfig -> NodeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg NodeStatement
x
  dotPrint DotConfig
cfg (StatementEdge EdgeStatement
x) = DotConfig -> EdgeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg EdgeStatement
x
  dotPrint DotConfig
cfg (StatementAttribute AttributeStatement
x) = DotConfig -> AttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg AttributeStatement
x
  dotPrint DotConfig
cfg (StatementGlobalAttribute GlobalAttributeStatement
x) = DotConfig -> GlobalAttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg GlobalAttributeStatement
x
  dotPrint DotConfig
cfg (StatementSubGraph SubGraphStatement
x) = DotConfig -> SubGraphStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg SubGraphStatement
x

  dotParse :: ParserT PureMode Error Statement
dotParse =
    ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall e a. Parser e a -> Parser e a
token (ParserT PureMode Error Statement
 -> ParserT PureMode Error Statement)
-> ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall a b. (a -> b) -> a -> b
$
      -- Order is important
      (EdgeStatement -> Statement
StatementEdge (EdgeStatement -> Statement)
-> ParserT PureMode Error EdgeStatement
-> ParserT PureMode Error Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error EdgeStatement
forall a. DotParse a => Parser Error a
dotParse)
        ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (AttributeStatement -> Statement
StatementAttribute (AttributeStatement -> Statement)
-> ParserT PureMode Error AttributeStatement
-> ParserT PureMode Error Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error AttributeStatement
forall a. DotParse a => Parser Error a
dotParse)
        ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (GlobalAttributeStatement -> Statement
StatementGlobalAttribute (GlobalAttributeStatement -> Statement)
-> ParserT PureMode Error GlobalAttributeStatement
-> ParserT PureMode Error Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error GlobalAttributeStatement
forall a. DotParse a => Parser Error a
dotParse)
        ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (SubGraphStatement -> Statement
StatementSubGraph (SubGraphStatement -> Statement)
-> ParserT PureMode Error SubGraphStatement
-> ParserT PureMode Error Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error SubGraphStatement
forall a. DotParse a => Parser Error a
dotParse)
        ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (NodeStatement -> Statement
StatementNode (NodeStatement -> Statement)
-> ParserT PureMode Error NodeStatement
-> ParserT PureMode Error Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error NodeStatement
forall a. DotParse a => Parser Error a
dotParse)

-- | Identifier as per the dot language specifications.
--
-- >>> runDotParser "0" :: ID
-- IDInt 0
--
-- >>> runDotParser "-.123" :: ID
-- IDDouble (-0.123)
--
-- >>> runParser dotParse "apple_1'" :: Result Error ID
-- OK (ID "apple_1") "'"
--
-- >>> :set -XQuasiQuotes
-- >>> runParser dotParse "\"hello\"" :: Result Error ID
-- OK (IDQuoted "hello") ""
--
-- >>> runDotParser "<The <font color='red'><b>foo</b></font>,<br/> the <font point-size='20'>bar</font> and<br/> the <i>baz</i>>" :: ID
-- IDHtml "<The <font color='red'><b>foo</b></font>,<br/> the <font point-size='20'>bar</font> and<br/> the <i>baz</i>>"
--
-- >>> runDotParser "shape=diamond" :: (ID,ID)
-- (ID "shape",ID "diamond")
--
-- >>> runDotParser "fontname=\"Arial\"" :: (ID,ID)
-- (ID "fontname",IDQuoted "Arial")
--
-- >>> runDotParser "[shape=diamond; color=blue] [label=label]" :: Map.Map ID ID
-- fromList [(ID "color",ID "blue"),(ID "label",ID "label"),(ID "shape",ID "diamond")]
data ID = ID ByteString | IDInt Int | IDDouble Double | IDQuoted ByteString | IDHtml ByteString deriving (ID -> ID -> Bool
(ID -> ID -> Bool) -> (ID -> ID -> Bool) -> Eq ID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ID -> ID -> Bool
== :: ID -> ID -> Bool
$c/= :: ID -> ID -> Bool
/= :: ID -> ID -> Bool
Eq, Int -> ID -> ShowS
[ID] -> ShowS
ID -> String
(Int -> ID -> ShowS)
-> (ID -> String) -> ([ID] -> ShowS) -> Show ID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ID -> ShowS
showsPrec :: Int -> ID -> ShowS
$cshow :: ID -> String
show :: ID -> String
$cshowList :: [ID] -> ShowS
showList :: [ID] -> ShowS
Show, (forall x. ID -> Rep ID x)
-> (forall x. Rep ID x -> ID) -> Generic ID
forall x. Rep ID x -> ID
forall x. ID -> Rep ID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ID -> Rep ID x
from :: forall x. ID -> Rep ID x
$cto :: forall x. Rep ID x -> ID
to :: forall x. Rep ID x -> ID
Generic, Eq ID
Eq ID =>
(ID -> ID -> Ordering)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> ID)
-> (ID -> ID -> ID)
-> Ord ID
ID -> ID -> Bool
ID -> ID -> Ordering
ID -> ID -> ID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ID -> ID -> Ordering
compare :: ID -> ID -> Ordering
$c< :: ID -> ID -> Bool
< :: ID -> ID -> Bool
$c<= :: ID -> ID -> Bool
<= :: ID -> ID -> Bool
$c> :: ID -> ID -> Bool
> :: ID -> ID -> Bool
$c>= :: ID -> ID -> Bool
>= :: ID -> ID -> Bool
$cmax :: ID -> ID -> ID
max :: ID -> ID -> ID
$cmin :: ID -> ID -> ID
min :: ID -> ID -> ID
Ord)

instance DotParse ID where
  dotPrint :: DotConfig -> ID -> ByteString
dotPrint DotConfig
_ (ID ByteString
s) = ByteString
s
  dotPrint DotConfig
_ (IDInt Int
i) = String -> ByteString
strToUtf8 (Int -> String
forall a. Show a => a -> String
show Int
i)
  dotPrint DotConfig
_ (IDDouble Double
x) = String -> ByteString
strToUtf8 (Double -> String
forall a. Show a => a -> String
show Double
x)
  dotPrint DotConfig
_ (IDQuoted ByteString
x) =
    ByteString -> ByteString
wrapQuotePrint ByteString
x
  dotPrint DotConfig
_ (IDHtml ByteString
s) = ByteString
s

  -- order matters
  dotParse :: ParserT PureMode Error ID
dotParse =
    (ByteString -> ID
ID (ByteString -> ID)
-> ParserT PureMode Error ByteString -> ParserT PureMode Error ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error ByteString
forall e. Parser e ByteString
ident)
      ParserT PureMode Error ID
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Int -> ID
IDInt (Int -> ID)
-> ParserT PureMode Error Int -> ParserT PureMode Error ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParserT PureMode Error Int -> ParserT PureMode Error Int
forall b e. Num b => Parser e b -> Parser e b
signed ParserT PureMode Error Int
int ParserT PureMode Error Int
-> ParserT PureMode Error () -> ParserT PureMode Error Int
forall (st :: ZeroBitType) e a b.
ParserT st e a -> ParserT st e b -> ParserT st e a
`notFollowedBy` $(char '.')))
      ParserT PureMode Error ID
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Double -> ID
IDDouble (Double -> ID)
-> ParserT PureMode Error Double -> ParserT PureMode Error ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error Double -> ParserT PureMode Error Double
forall b e. Num b => Parser e b -> Parser e b
signed ParserT PureMode Error Double
double)
      ParserT PureMode Error ID
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (ByteString -> ID
IDQuoted (ByteString -> ID) -> (String -> ByteString) -> String -> ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 (String -> ID)
-> ParserT PureMode Error String -> ParserT PureMode Error ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error String
quoted)
      ParserT PureMode Error ID
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (ByteString -> ID
IDHtml (ByteString -> ID) -> (String -> ByteString) -> String -> ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 (String -> ID)
-> ParserT PureMode Error String -> ParserT PureMode Error ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error String
forall e. Parser e String
htmlLike)

-- | ID as the equivalent plain String
--
-- note that the dot language identifier equivalence law is:
--
-- > x == y if label x == label y
label :: ID -> String
label :: ID -> String
label (ID ByteString
s) = ByteString -> String
utf8ToStr ByteString
s
label (IDInt Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
label (IDDouble Double
d) = Double -> String
forall a. Show a => a -> String
show Double
d
label (IDQuoted ByteString
q) = ByteString -> String
utf8ToStr ByteString
q
label (IDHtml ByteString
h) = ByteString -> String
utf8ToStr ByteString
h

-- | Attribute key-value pair of identifiers
instance DotParse (ID, ID) where
  dotPrint :: DotConfig -> (ID, ID) -> ByteString
dotPrint DotConfig
cfg (ID
x0, ID
x1) = DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
x0 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
x1

  dotParse :: Parser Error (ID, ID)
dotParse = Parser Error (ID, ID) -> Parser Error (ID, ID)
forall e a. Parser e a -> Parser e a
token (Parser Error (ID, ID) -> Parser Error (ID, ID))
-> Parser Error (ID, ID) -> Parser Error (ID, ID)
forall a b. (a -> b) -> a -> b
$
    do
      ID
x0 <- ParserT PureMode Error ID -> ParserT PureMode Error ID
forall e a. Parser e a -> Parser e a
token ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse
      ()
_ <- ParserT PureMode Error () -> ParserT PureMode Error ()
forall e a. Parser e a -> Parser e a
token $(symbol "=")
      ID
x1 <- ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse
      (ID, ID) -> Parser Error (ID, ID)
forall a. a -> ParserT PureMode Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID
x0, ID
x1)

-- | Attribute collections
--
-- A given entity can have multiple attribute lists. For simplicity, these are mconcat'ed on parsing.
instance DotParse (Map.Map ID ID) where
  dotPrint :: DotConfig -> Map ID ID -> ByteString
dotPrint DotConfig
cfg Map ID ID
as =
    ByteString -> ByteString -> Bool -> ByteString
forall a. a -> a -> Bool -> a
bool
      (ByteString -> ByteString
wrapSquarePrint (ByteString -> [ByteString] -> ByteString
intercalate (DotConfig
cfg DotConfig -> Optic' A_Lens NoIx DotConfig ByteString -> ByteString
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx DotConfig ByteString
#attSep) ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ DotConfig -> (ID, ID) -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ((ID, ID) -> ByteString) -> [(ID, ID)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ID ID -> [(ID, ID)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ID ID
as))
      ByteString
forall a. Monoid a => a
mempty
      (Map ID ID
as Map ID ID -> Map ID ID -> Bool
forall a. Eq a => a -> a -> Bool
== Map ID ID
forall k a. Map k a
Map.empty)

  dotParse :: Parser Error (Map ID ID)
dotParse =
    [(ID, ID)] -> Map ID ID
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ID, ID)] -> Map ID ID)
-> ([NonEmpty (ID, ID)] -> [(ID, ID)])
-> [NonEmpty (ID, ID)]
-> Map ID ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(ID, ID)]] -> [(ID, ID)]
forall a. Monoid a => [a] -> a
mconcat ([[(ID, ID)]] -> [(ID, ID)])
-> ([NonEmpty (ID, ID)] -> [[(ID, ID)]])
-> [NonEmpty (ID, ID)]
-> [(ID, ID)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (ID, ID) -> [(ID, ID)])
-> [NonEmpty (ID, ID)] -> [[(ID, ID)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (ID, ID) -> [(ID, ID)]
forall a. NonEmpty a -> [a]
toList
      ([NonEmpty (ID, ID)] -> Map ID ID)
-> ParserT PureMode Error [NonEmpty (ID, ID)]
-> Parser Error (Map ID ID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error [NonEmpty (ID, ID)]
-> ParserT PureMode Error [NonEmpty (ID, ID)]
forall e a. Parser e a -> Parser e a
token (ParserT PureMode Error (NonEmpty (ID, ID))
-> ParserT PureMode Error [NonEmpty (ID, ID)]
forall a. ParserT PureMode Error a -> ParserT PureMode Error [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParserT PureMode Error (NonEmpty (ID, ID))
-> ParserT PureMode Error (NonEmpty (ID, ID))
forall a. Parser Error a -> Parser Error a
wrapSquareP (Parser Error (ID, ID)
-> ParserT PureMode Error ()
-> ParserT PureMode Error (NonEmpty (ID, ID))
forall e a. Parser e a -> Parser e () -> Parser e (NonEmpty a)
nonEmptyP Parser Error (ID, ID)
forall a. DotParse a => Parser Error a
dotParse ParserT PureMode Error ()
forall e. Parser e ()
sepP)) ParserT PureMode Error [NonEmpty (ID, ID)]
-> ParserT PureMode Error [NonEmpty (ID, ID)]
-> ParserT PureMode Error [NonEmpty (ID, ID)]
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> ([] [NonEmpty (ID, ID)]
-> ParserT PureMode Error ()
-> ParserT PureMode Error [NonEmpty (ID, ID)]
forall a b.
a -> ParserT PureMode Error b -> ParserT PureMode Error a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParserT PureMode Error () -> ParserT PureMode Error ()
forall a. Parser Error a -> Parser Error a
wrapSquareP ParserT PureMode Error ()
forall e. Parser e ()
ws))

-- | Compass instructions which are optionally associated with an identifier
data Compass = CompassN | CompassNE | CompassE | CompassSE | CompassS | CompassSW | CompassW | CompassNW | CompassC | Compass_ deriving (Compass -> Compass -> Bool
(Compass -> Compass -> Bool)
-> (Compass -> Compass -> Bool) -> Eq Compass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Compass -> Compass -> Bool
== :: Compass -> Compass -> Bool
$c/= :: Compass -> Compass -> Bool
/= :: Compass -> Compass -> Bool
Eq, Int -> Compass -> ShowS
[Compass] -> ShowS
Compass -> String
(Int -> Compass -> ShowS)
-> (Compass -> String) -> ([Compass] -> ShowS) -> Show Compass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Compass -> ShowS
showsPrec :: Int -> Compass -> ShowS
$cshow :: Compass -> String
show :: Compass -> String
$cshowList :: [Compass] -> ShowS
showList :: [Compass] -> ShowS
Show, (forall x. Compass -> Rep Compass x)
-> (forall x. Rep Compass x -> Compass) -> Generic Compass
forall x. Rep Compass x -> Compass
forall x. Compass -> Rep Compass x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Compass -> Rep Compass x
from :: forall x. Compass -> Rep Compass x
$cto :: forall x. Rep Compass x -> Compass
to :: forall x. Rep Compass x -> Compass
Generic)

instance DotParse Compass where
  dotPrint :: DotConfig -> Compass -> ByteString
dotPrint DotConfig
_ Compass
CompassN = ByteString
"n"
  dotPrint DotConfig
_ Compass
CompassNE = ByteString
"ne"
  dotPrint DotConfig
_ Compass
CompassE = ByteString
"e"
  dotPrint DotConfig
_ Compass
CompassSE = ByteString
"se"
  dotPrint DotConfig
_ Compass
CompassS = ByteString
"s"
  dotPrint DotConfig
_ Compass
CompassSW = ByteString
"sw"
  dotPrint DotConfig
_ Compass
CompassW = ByteString
"w"
  dotPrint DotConfig
_ Compass
CompassNW = ByteString
"nw"
  dotPrint DotConfig
_ Compass
CompassC = ByteString
"c"
  dotPrint DotConfig
_ Compass
Compass_ = ByteString
"_"

  dotParse :: Parser Error Compass
dotParse =
    Parser Error Compass -> Parser Error Compass
forall e a. Parser e a -> Parser e a
token
      $( switch
           [|
             case _ of
               "n" -> pure CompassN
               "ne" -> pure CompassNE
               "e" -> pure CompassE
               "se" -> pure CompassSE
               "s" -> pure CompassS
               "sw" -> pure CompassSW
               "w" -> pure CompassW
               "nw" -> pure CompassNW
               "c" -> pure CompassC
               "_" -> pure Compass_
             |]
       )

-- | Port instructions which are optionally associated with an identifier
newtype Port = Port {Port -> These ID Compass
portID :: These ID Compass} deriving (Port -> Port -> Bool
(Port -> Port -> Bool) -> (Port -> Port -> Bool) -> Eq Port
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
/= :: Port -> Port -> Bool
Eq, Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Port -> ShowS
showsPrec :: Int -> Port -> ShowS
$cshow :: Port -> String
show :: Port -> String
$cshowList :: [Port] -> ShowS
showList :: [Port] -> ShowS
Show, (forall x. Port -> Rep Port x)
-> (forall x. Rep Port x -> Port) -> Generic Port
forall x. Rep Port x -> Port
forall x. Port -> Rep Port x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Port -> Rep Port x
from :: forall x. Port -> Rep Port x
$cto :: forall x. Rep Port x -> Port
to :: forall x. Rep Port x -> Port
Generic)

instance DotParse Port where
  dotPrint :: DotConfig -> Port -> ByteString
dotPrint DotConfig
cfg (Port (This ID
i)) = ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i
  dotPrint DotConfig
cfg (Port (That Compass
c)) = ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> Compass -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Compass
c
  dotPrint DotConfig
cfg (Port (These ID
i Compass
c)) = ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" : " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> Compass -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Compass
c

  dotParse :: Parser Error Port
dotParse =
    Parser Error Port -> Parser Error Port
forall e a. Parser e a -> Parser e a
token (Parser Error Port -> Parser Error Port)
-> Parser Error Port -> Parser Error Port
forall a b. (a -> b) -> a -> b
$
      ((\ID
x0 Compass
x1 -> These ID Compass -> Port
Port (ID -> Compass -> These ID Compass
forall a b. a -> b -> These a b
These ID
x0 Compass
x1)) (ID -> Compass -> Port)
-> ParserT PureMode Error ID
-> ParserT PureMode Error (Compass -> Port)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ($(symbol ":") ParserT PureMode Error ()
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall a b.
ParserT PureMode Error a
-> ParserT PureMode Error b -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse) ParserT PureMode Error (Compass -> Port)
-> Parser Error Compass -> Parser Error Port
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ($(symbol ":") ParserT PureMode Error ()
-> Parser Error Compass -> Parser Error Compass
forall a b.
ParserT PureMode Error a
-> ParserT PureMode Error b -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error Compass
forall a. DotParse a => Parser Error a
dotParse))
        Parser Error Port -> Parser Error Port -> Parser Error Port
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (These ID Compass -> Port
Port (These ID Compass -> Port)
-> (ID -> These ID Compass) -> ID -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> These ID Compass
forall a b. a -> These a b
This (ID -> Port) -> ParserT PureMode Error ID -> Parser Error Port
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ($(symbol ":") ParserT PureMode Error ()
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall a b.
ParserT PureMode Error a
-> ParserT PureMode Error b -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse))
        Parser Error Port -> Parser Error Port -> Parser Error Port
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (These ID Compass -> Port
Port (These ID Compass -> Port)
-> (Compass -> These ID Compass) -> Compass -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compass -> These ID Compass
forall a b. b -> These a b
That (Compass -> Port) -> Parser Error Compass -> Parser Error Port
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ($(symbol ":") ParserT PureMode Error ()
-> Parser Error Compass -> Parser Error Compass
forall a b.
ParserT PureMode Error a
-> ParserT PureMode Error b -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error Compass
forall a. DotParse a => Parser Error a
dotParse))

-- | A top-level attribute
--
-- >>> runDotParser "rankdir=\"BT\"" :: Statement
-- StatementGlobalAttribute (GlobalAttributeStatement {globalAttributeStatement = (ID "rankdir",IDQuoted "BT")})
newtype GlobalAttributeStatement = GlobalAttributeStatement {GlobalAttributeStatement -> (ID, ID)
globalAttributeStatement :: (ID, ID)} deriving (GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
(GlobalAttributeStatement -> GlobalAttributeStatement -> Bool)
-> (GlobalAttributeStatement -> GlobalAttributeStatement -> Bool)
-> Eq GlobalAttributeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
== :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
$c/= :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
/= :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
Eq, Int -> GlobalAttributeStatement -> ShowS
[GlobalAttributeStatement] -> ShowS
GlobalAttributeStatement -> String
(Int -> GlobalAttributeStatement -> ShowS)
-> (GlobalAttributeStatement -> String)
-> ([GlobalAttributeStatement] -> ShowS)
-> Show GlobalAttributeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalAttributeStatement -> ShowS
showsPrec :: Int -> GlobalAttributeStatement -> ShowS
$cshow :: GlobalAttributeStatement -> String
show :: GlobalAttributeStatement -> String
$cshowList :: [GlobalAttributeStatement] -> ShowS
showList :: [GlobalAttributeStatement] -> ShowS
Show, (forall x.
 GlobalAttributeStatement -> Rep GlobalAttributeStatement x)
-> (forall x.
    Rep GlobalAttributeStatement x -> GlobalAttributeStatement)
-> Generic GlobalAttributeStatement
forall x.
Rep GlobalAttributeStatement x -> GlobalAttributeStatement
forall x.
GlobalAttributeStatement -> Rep GlobalAttributeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
GlobalAttributeStatement -> Rep GlobalAttributeStatement x
from :: forall x.
GlobalAttributeStatement -> Rep GlobalAttributeStatement x
$cto :: forall x.
Rep GlobalAttributeStatement x -> GlobalAttributeStatement
to :: forall x.
Rep GlobalAttributeStatement x -> GlobalAttributeStatement
Generic)

instance DotParse GlobalAttributeStatement where
  dotPrint :: DotConfig -> GlobalAttributeStatement -> ByteString
dotPrint DotConfig
cfg (GlobalAttributeStatement (ID, ID)
s) = DotConfig -> (ID, ID) -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (ID, ID)
s
  dotParse :: ParserT PureMode Error GlobalAttributeStatement
dotParse = (ID, ID) -> GlobalAttributeStatement
GlobalAttributeStatement ((ID, ID) -> GlobalAttributeStatement)
-> Parser Error (ID, ID)
-> ParserT PureMode Error GlobalAttributeStatement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error (ID, ID)
forall a. DotParse a => Parser Error a
dotParse

-- | Category of attribute
data AttributeType = GraphType | NodeType | EdgeType deriving (AttributeType -> AttributeType -> Bool
(AttributeType -> AttributeType -> Bool)
-> (AttributeType -> AttributeType -> Bool) -> Eq AttributeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AttributeType -> AttributeType -> Bool
== :: AttributeType -> AttributeType -> Bool
$c/= :: AttributeType -> AttributeType -> Bool
/= :: AttributeType -> AttributeType -> Bool
Eq, Int -> AttributeType -> ShowS
[AttributeType] -> ShowS
AttributeType -> String
(Int -> AttributeType -> ShowS)
-> (AttributeType -> String)
-> ([AttributeType] -> ShowS)
-> Show AttributeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AttributeType -> ShowS
showsPrec :: Int -> AttributeType -> ShowS
$cshow :: AttributeType -> String
show :: AttributeType -> String
$cshowList :: [AttributeType] -> ShowS
showList :: [AttributeType] -> ShowS
Show, (forall x. AttributeType -> Rep AttributeType x)
-> (forall x. Rep AttributeType x -> AttributeType)
-> Generic AttributeType
forall x. Rep AttributeType x -> AttributeType
forall x. AttributeType -> Rep AttributeType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AttributeType -> Rep AttributeType x
from :: forall x. AttributeType -> Rep AttributeType x
$cto :: forall x. Rep AttributeType x -> AttributeType
to :: forall x. Rep AttributeType x -> AttributeType
Generic)

instance DotParse AttributeType where
  dotPrint :: DotConfig -> AttributeType -> ByteString
dotPrint DotConfig
_ AttributeType
GraphType = ByteString
"graph"
  dotPrint DotConfig
_ AttributeType
NodeType = ByteString
"node"
  dotPrint DotConfig
_ AttributeType
EdgeType = ByteString
"edge"

  dotParse :: Parser Error AttributeType
dotParse =
    Parser Error AttributeType -> Parser Error AttributeType
forall e a. Parser e a -> Parser e a
token
      (AttributeType
GraphType AttributeType
-> ParserT PureMode Error () -> Parser Error AttributeType
forall a b.
a -> ParserT PureMode Error b -> ParserT PureMode Error a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "graph"))
      Parser Error AttributeType
-> Parser Error AttributeType -> Parser Error AttributeType
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (AttributeType
NodeType AttributeType
-> ParserT PureMode Error () -> Parser Error AttributeType
forall a b.
a -> ParserT PureMode Error b -> ParserT PureMode Error a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "node"))
      Parser Error AttributeType
-> Parser Error AttributeType -> Parser Error AttributeType
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (AttributeType
EdgeType AttributeType
-> ParserT PureMode Error () -> Parser Error AttributeType
forall a b.
a -> ParserT PureMode Error b -> ParserT PureMode Error a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "edge"))

-- | Top-level attribute statement
--
-- >>> runDotParser "graph [overlap=false, splines=spline, size=\"1!\"];" :: Statement
-- StatementAttribute (AttributeStatement {attributeType = GraphType, attributes = fromList [(ID "overlap",ID "false"),(ID "size",IDQuoted "1!"),(ID "splines",ID "spline")]})
data AttributeStatement = AttributeStatement {AttributeStatement -> AttributeType
attributeType :: AttributeType, AttributeStatement -> Map ID ID
attributes :: Map.Map ID ID} deriving (AttributeStatement -> AttributeStatement -> Bool
(AttributeStatement -> AttributeStatement -> Bool)
-> (AttributeStatement -> AttributeStatement -> Bool)
-> Eq AttributeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AttributeStatement -> AttributeStatement -> Bool
== :: AttributeStatement -> AttributeStatement -> Bool
$c/= :: AttributeStatement -> AttributeStatement -> Bool
/= :: AttributeStatement -> AttributeStatement -> Bool
Eq, Int -> AttributeStatement -> ShowS
[AttributeStatement] -> ShowS
AttributeStatement -> String
(Int -> AttributeStatement -> ShowS)
-> (AttributeStatement -> String)
-> ([AttributeStatement] -> ShowS)
-> Show AttributeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AttributeStatement -> ShowS
showsPrec :: Int -> AttributeStatement -> ShowS
$cshow :: AttributeStatement -> String
show :: AttributeStatement -> String
$cshowList :: [AttributeStatement] -> ShowS
showList :: [AttributeStatement] -> ShowS
Show, (forall x. AttributeStatement -> Rep AttributeStatement x)
-> (forall x. Rep AttributeStatement x -> AttributeStatement)
-> Generic AttributeStatement
forall x. Rep AttributeStatement x -> AttributeStatement
forall x. AttributeStatement -> Rep AttributeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AttributeStatement -> Rep AttributeStatement x
from :: forall x. AttributeStatement -> Rep AttributeStatement x
$cto :: forall x. Rep AttributeStatement x -> AttributeStatement
to :: forall x. Rep AttributeStatement x -> AttributeStatement
Generic)

instance DotParse AttributeStatement where
  dotPrint :: DotConfig -> AttributeStatement -> ByteString
dotPrint DotConfig
cfg (AttributeStatement AttributeType
t Map ID ID
as) =
    ByteString -> ByteString -> Bool -> ByteString
forall a. a -> a -> Bool -> a
bool
      ( ByteString -> [ByteString] -> ByteString
intercalate
          ByteString
" "
          [DotConfig -> AttributeType -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg AttributeType
t, DotConfig -> Map ID ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]
      )
      ByteString
forall a. Monoid a => a
mempty
      (Map ID ID
forall a. Monoid a => a
mempty Map ID ID -> Map ID ID -> Bool
forall a. Eq a => a -> a -> Bool
== Map ID ID
as)

  dotParse :: ParserT PureMode Error AttributeStatement
dotParse = AttributeType -> Map ID ID -> AttributeStatement
AttributeStatement (AttributeType -> Map ID ID -> AttributeStatement)
-> Parser Error AttributeType
-> ParserT PureMode Error (Map ID ID -> AttributeStatement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error AttributeType
forall a. DotParse a => Parser Error a
dotParse ParserT PureMode Error (Map ID ID -> AttributeStatement)
-> Parser Error (Map ID ID)
-> ParserT PureMode Error AttributeStatement
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Map ID ID)
forall a. DotParse a => Parser Error a
dotParse

-- | Node statement
--
-- >>> runDotParser "A [shape=diamond; color=blue]" :: Statement
-- StatementNode (NodeStatement {nodeID = ID "A", port = Nothing, nodeAttrs = fromList [(ID "color",ID "blue"),(ID "shape",ID "diamond")]})
data NodeStatement = NodeStatement {NodeStatement -> ID
nodeID :: ID, NodeStatement -> Maybe Port
port :: Maybe Port, NodeStatement -> Map ID ID
nodeAttrs :: Map.Map ID ID} deriving (NodeStatement -> NodeStatement -> Bool
(NodeStatement -> NodeStatement -> Bool)
-> (NodeStatement -> NodeStatement -> Bool) -> Eq NodeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeStatement -> NodeStatement -> Bool
== :: NodeStatement -> NodeStatement -> Bool
$c/= :: NodeStatement -> NodeStatement -> Bool
/= :: NodeStatement -> NodeStatement -> Bool
Eq, Int -> NodeStatement -> ShowS
[NodeStatement] -> ShowS
NodeStatement -> String
(Int -> NodeStatement -> ShowS)
-> (NodeStatement -> String)
-> ([NodeStatement] -> ShowS)
-> Show NodeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeStatement -> ShowS
showsPrec :: Int -> NodeStatement -> ShowS
$cshow :: NodeStatement -> String
show :: NodeStatement -> String
$cshowList :: [NodeStatement] -> ShowS
showList :: [NodeStatement] -> ShowS
Show, (forall x. NodeStatement -> Rep NodeStatement x)
-> (forall x. Rep NodeStatement x -> NodeStatement)
-> Generic NodeStatement
forall x. Rep NodeStatement x -> NodeStatement
forall x. NodeStatement -> Rep NodeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NodeStatement -> Rep NodeStatement x
from :: forall x. NodeStatement -> Rep NodeStatement x
$cto :: forall x. Rep NodeStatement x -> NodeStatement
to :: forall x. Rep NodeStatement x -> NodeStatement
Generic)

instance DotParse NodeStatement where
  dotPrint :: DotConfig -> NodeStatement -> ByteString
dotPrint DotConfig
cfg (NodeStatement ID
i Maybe Port
p Map ID ID
as) =
    ByteString -> [ByteString] -> ByteString
intercalate ByteString
" " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      [DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i]
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> Port -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (Port -> ByteString) -> [Port] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Port -> [Port]
forall a. Maybe a -> [a]
maybeToList Maybe Port
p)
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [DotConfig -> Map ID ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]

  dotParse :: ParserT PureMode Error NodeStatement
dotParse = ID -> Maybe Port -> Map ID ID -> NodeStatement
NodeStatement (ID -> Maybe Port -> Map ID ID -> NodeStatement)
-> ParserT PureMode Error ID
-> ParserT
     PureMode Error (Maybe Port -> Map ID ID -> NodeStatement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse ParserT PureMode Error (Maybe Port -> Map ID ID -> NodeStatement)
-> ParserT PureMode Error (Maybe Port)
-> ParserT PureMode Error (Map ID ID -> NodeStatement)
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error Port -> ParserT PureMode Error (Maybe Port)
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional Parser Error Port
forall a. DotParse a => Parser Error a
dotParse ParserT PureMode Error (Map ID ID -> NodeStatement)
-> Parser Error (Map ID ID) -> ParserT PureMode Error NodeStatement
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Map ID ID)
forall a. DotParse a => Parser Error a
dotParse

-- | An edge can be specified in as a NodeID or as a SubGraph
data EdgeID
  = EdgeID ID (Maybe Port)
  | EdgeSubGraph SubGraphStatement
  deriving (EdgeID -> EdgeID -> Bool
(EdgeID -> EdgeID -> Bool)
-> (EdgeID -> EdgeID -> Bool) -> Eq EdgeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeID -> EdgeID -> Bool
== :: EdgeID -> EdgeID -> Bool
$c/= :: EdgeID -> EdgeID -> Bool
/= :: EdgeID -> EdgeID -> Bool
Eq, Int -> EdgeID -> ShowS
[EdgeID] -> ShowS
EdgeID -> String
(Int -> EdgeID -> ShowS)
-> (EdgeID -> String) -> ([EdgeID] -> ShowS) -> Show EdgeID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeID -> ShowS
showsPrec :: Int -> EdgeID -> ShowS
$cshow :: EdgeID -> String
show :: EdgeID -> String
$cshowList :: [EdgeID] -> ShowS
showList :: [EdgeID] -> ShowS
Show, (forall x. EdgeID -> Rep EdgeID x)
-> (forall x. Rep EdgeID x -> EdgeID) -> Generic EdgeID
forall x. Rep EdgeID x -> EdgeID
forall x. EdgeID -> Rep EdgeID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EdgeID -> Rep EdgeID x
from :: forall x. EdgeID -> Rep EdgeID x
$cto :: forall x. Rep EdgeID x -> EdgeID
to :: forall x. Rep EdgeID x -> EdgeID
Generic)

instance DotParse EdgeID where
  dotPrint :: DotConfig -> EdgeID -> ByteString
dotPrint DotConfig
cfg (EdgeID ID
e Maybe Port
p) =
    [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
e] [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> Port -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (Port -> ByteString) -> [Port] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Port -> [Port]
forall a. Maybe a -> [a]
maybeToList Maybe Port
p)
  dotPrint DotConfig
cfg (EdgeSubGraph SubGraphStatement
s) = DotConfig -> SubGraphStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg SubGraphStatement
s

  dotParse :: Parser Error EdgeID
dotParse =
    (ID -> Maybe Port -> EdgeID
EdgeID (ID -> Maybe Port -> EdgeID)
-> ParserT PureMode Error ID
-> ParserT PureMode Error (Maybe Port -> EdgeID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse ParserT PureMode Error (Maybe Port -> EdgeID)
-> ParserT PureMode Error (Maybe Port) -> Parser Error EdgeID
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error Port -> ParserT PureMode Error (Maybe Port)
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional Parser Error Port
forall a. DotParse a => Parser Error a
dotParse)
      Parser Error EdgeID -> Parser Error EdgeID -> Parser Error EdgeID
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (SubGraphStatement -> EdgeID
EdgeSubGraph (SubGraphStatement -> EdgeID)
-> ParserT PureMode Error SubGraphStatement -> Parser Error EdgeID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode Error SubGraphStatement
forall a. DotParse a => Parser Error a
dotParse)

-- | An edgeop is -> in directed graphs and -- in undirected graphs.
data EdgeOp = EdgeDirected | EdgeUndirected deriving (EdgeOp -> EdgeOp -> Bool
(EdgeOp -> EdgeOp -> Bool)
-> (EdgeOp -> EdgeOp -> Bool) -> Eq EdgeOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeOp -> EdgeOp -> Bool
== :: EdgeOp -> EdgeOp -> Bool
$c/= :: EdgeOp -> EdgeOp -> Bool
/= :: EdgeOp -> EdgeOp -> Bool
Eq, Int -> EdgeOp -> ShowS
[EdgeOp] -> ShowS
EdgeOp -> String
(Int -> EdgeOp -> ShowS)
-> (EdgeOp -> String) -> ([EdgeOp] -> ShowS) -> Show EdgeOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeOp -> ShowS
showsPrec :: Int -> EdgeOp -> ShowS
$cshow :: EdgeOp -> String
show :: EdgeOp -> String
$cshowList :: [EdgeOp] -> ShowS
showList :: [EdgeOp] -> ShowS
Show, (forall x. EdgeOp -> Rep EdgeOp x)
-> (forall x. Rep EdgeOp x -> EdgeOp) -> Generic EdgeOp
forall x. Rep EdgeOp x -> EdgeOp
forall x. EdgeOp -> Rep EdgeOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EdgeOp -> Rep EdgeOp x
from :: forall x. EdgeOp -> Rep EdgeOp x
$cto :: forall x. Rep EdgeOp x -> EdgeOp
to :: forall x. Rep EdgeOp x -> EdgeOp
Generic)

instance DotParse EdgeOp where
  dotPrint :: DotConfig -> EdgeOp -> ByteString
dotPrint DotConfig
_ EdgeOp
EdgeDirected = ByteString
"->"
  dotPrint DotConfig
_ EdgeOp
EdgeUndirected = ByteString
"--"

  dotParse :: Parser Error EdgeOp
dotParse =
    Parser Error EdgeOp -> Parser Error EdgeOp
forall e a. Parser e a -> Parser e a
token
      $( switch
           [|
             case _ of
               "->" -> pure EdgeDirected
               "--" -> pure EdgeUndirected
             |]
       )

-- | generate an EdgeOp given the type of graph.
fromDirected :: Directed -> EdgeOp
fromDirected :: Directed -> EdgeOp
fromDirected Directed
Directed = EdgeOp
EdgeDirected
fromDirected Directed
UnDirected = EdgeOp
EdgeUndirected

-- | Edge statement
--
-- >>> runDotParser "A -> B [style=dashed, color=grey]" :: Statement
-- StatementEdge (EdgeStatement {edgeOp = EdgeDirected, leftEdge = EdgeID (ID "A") Nothing, rightEdges = EdgeID (ID "B") Nothing :| [], edgeAttrs = fromList [(ID "color",ID "grey"),(ID "style",ID "dashed")]})
data EdgeStatement = EdgeStatement {EdgeStatement -> EdgeOp
edgeOp :: EdgeOp, EdgeStatement -> EdgeID
leftEdge :: EdgeID, EdgeStatement -> NonEmpty EdgeID
rightEdges :: NonEmpty EdgeID, EdgeStatement -> Map ID ID
edgeAttrs :: Map.Map ID ID} deriving (EdgeStatement -> EdgeStatement -> Bool
(EdgeStatement -> EdgeStatement -> Bool)
-> (EdgeStatement -> EdgeStatement -> Bool) -> Eq EdgeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeStatement -> EdgeStatement -> Bool
== :: EdgeStatement -> EdgeStatement -> Bool
$c/= :: EdgeStatement -> EdgeStatement -> Bool
/= :: EdgeStatement -> EdgeStatement -> Bool
Eq, Int -> EdgeStatement -> ShowS
[EdgeStatement] -> ShowS
EdgeStatement -> String
(Int -> EdgeStatement -> ShowS)
-> (EdgeStatement -> String)
-> ([EdgeStatement] -> ShowS)
-> Show EdgeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeStatement -> ShowS
showsPrec :: Int -> EdgeStatement -> ShowS
$cshow :: EdgeStatement -> String
show :: EdgeStatement -> String
$cshowList :: [EdgeStatement] -> ShowS
showList :: [EdgeStatement] -> ShowS
Show, (forall x. EdgeStatement -> Rep EdgeStatement x)
-> (forall x. Rep EdgeStatement x -> EdgeStatement)
-> Generic EdgeStatement
forall x. Rep EdgeStatement x -> EdgeStatement
forall x. EdgeStatement -> Rep EdgeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EdgeStatement -> Rep EdgeStatement x
from :: forall x. EdgeStatement -> Rep EdgeStatement x
$cto :: forall x. Rep EdgeStatement x -> EdgeStatement
to :: forall x. Rep EdgeStatement x -> EdgeStatement
Generic)

instance DotParse EdgeStatement where
  dotPrint :: DotConfig -> EdgeStatement -> ByteString
dotPrint DotConfig
cfg (EdgeStatement EdgeOp
l EdgeID
rs NonEmpty EdgeID
xs Map ID ID
as) =
    ByteString -> [ByteString] -> ByteString
intercalate
      ByteString
" "
      ( [ByteString -> [ByteString] -> ByteString
intercalate (ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> EdgeOp -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg EdgeOp
l ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" ") (DotConfig -> EdgeID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (EdgeID -> ByteString) -> [EdgeID] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EdgeID
rs EdgeID -> [EdgeID] -> [EdgeID]
forall a. a -> [a] -> [a]
: NonEmpty EdgeID -> [EdgeID]
forall a. NonEmpty a -> [a]
toList NonEmpty EdgeID
xs))]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [DotConfig -> Map ID ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]
      )

  dotParse :: ParserT PureMode Error EdgeStatement
dotParse = ParserT PureMode Error EdgeStatement
-> ParserT PureMode Error EdgeStatement
forall e a. Parser e a -> Parser e a
token (ParserT PureMode Error EdgeStatement
 -> ParserT PureMode Error EdgeStatement)
-> ParserT PureMode Error EdgeStatement
-> ParserT PureMode Error EdgeStatement
forall a b. (a -> b) -> a -> b
$ do
    EdgeID
l <- Parser Error EdgeID
forall a. DotParse a => Parser Error a
dotParse
    EdgeOp
o0 <- Parser Error EdgeOp
forall a. DotParse a => Parser Error a
dotParse
    EdgeID
r0 <- Parser Error EdgeID
forall a. DotParse a => Parser Error a
dotParse
    [(EdgeOp, EdgeID)]
ors <- ParserT PureMode Error (EdgeOp, EdgeID)
-> ParserT PureMode Error [(EdgeOp, EdgeID)]
forall a. ParserT PureMode Error a -> ParserT PureMode Error [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((,) (EdgeOp -> EdgeID -> (EdgeOp, EdgeID))
-> Parser Error EdgeOp
-> ParserT PureMode Error (EdgeID -> (EdgeOp, EdgeID))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error EdgeOp
forall a. DotParse a => Parser Error a
dotParse ParserT PureMode Error (EdgeID -> (EdgeOp, EdgeID))
-> Parser Error EdgeID -> ParserT PureMode Error (EdgeOp, EdgeID)
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error EdgeID
forall a. DotParse a => Parser Error a
dotParse)
    Map ID ID
as <- Parser Error (Map ID ID)
forall a. DotParse a => Parser Error a
dotParse
    ParserT PureMode Error EdgeStatement
-> ParserT PureMode Error EdgeStatement
-> Bool
-> ParserT PureMode Error EdgeStatement
forall a. a -> a -> Bool -> a
bool
      (EdgeStatement -> ParserT PureMode Error EdgeStatement
forall a. a -> ParserT PureMode Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EdgeOp -> EdgeID -> NonEmpty EdgeID -> Map ID ID -> EdgeStatement
EdgeStatement EdgeOp
o0 EdgeID
l (EdgeID
r0 EdgeID -> [EdgeID] -> NonEmpty EdgeID
forall a. a -> [a] -> NonEmpty a
:| ((EdgeOp, EdgeID) -> EdgeID
forall a b. (a, b) -> b
snd ((EdgeOp, EdgeID) -> EdgeID) -> [(EdgeOp, EdgeID)] -> [EdgeID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(EdgeOp, EdgeID)]
ors)) Map ID ID
as))
      ParserT PureMode Error EdgeStatement
forall a. ParserT PureMode Error a
forall (f :: * -> *) a. Alternative f => f a
empty
      (((EdgeOp, EdgeID) -> Bool) -> [(EdgeOp, EdgeID)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((EdgeOp -> EdgeOp -> Bool
forall a. Eq a => a -> a -> Bool
/= EdgeOp
o0) (EdgeOp -> Bool)
-> ((EdgeOp, EdgeID) -> EdgeOp) -> (EdgeOp, EdgeID) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EdgeOp, EdgeID) -> EdgeOp
forall a b. (a, b) -> a
fst) [(EdgeOp, EdgeID)]
ors)

-- | The edge ID or subgraph ID (if any)
edgeID :: EdgeID -> Maybe ID
edgeID :: EdgeID -> Maybe ID
edgeID (EdgeID ID
i Maybe Port
_) = ID -> Maybe ID
forall a. a -> Maybe a
Just ID
i
edgeID (EdgeSubGraph (SubGraphStatement Maybe ID
i [Statement]
_)) = Maybe ID
i

-- | edge IDs
edgeIDsNamed :: EdgeStatement -> [(ID, ID)]
edgeIDsNamed :: EdgeStatement -> [(ID, ID)]
edgeIDsNamed EdgeStatement
e = [(ID
x, ID
y) | (Just ID
x, Just ID
y) <- EdgeStatement -> [(Maybe ID, Maybe ID)]
edgeIDs EdgeStatement
e]

-- | list of edges in a given EdgeStatement, including anonymous SugGraphs
edgeIDs :: EdgeStatement -> [(Maybe ID, Maybe ID)]
edgeIDs :: EdgeStatement -> [(Maybe ID, Maybe ID)]
edgeIDs EdgeStatement
e = [Maybe ID] -> [Maybe ID] -> [(Maybe ID, Maybe ID)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Maybe ID
id0 Maybe ID -> [Maybe ID] -> [Maybe ID]
forall a. a -> [a] -> [a]
: [Maybe ID]
id1) [Maybe ID]
id1
  where
    id0 :: Maybe ID
id0 = EdgeID -> Maybe ID
edgeID (Optic' A_Lens NoIx EdgeStatement EdgeID -> EdgeStatement -> EdgeID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx EdgeStatement EdgeID
#leftEdge EdgeStatement
e)
    id1 :: [Maybe ID]
id1 = EdgeID -> Maybe ID
edgeID (EdgeID -> Maybe ID) -> [EdgeID] -> [Maybe ID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EdgeID -> [EdgeID]
forall a. NonEmpty a -> [a]
toList (Optic' A_Lens NoIx EdgeStatement (NonEmpty EdgeID)
-> EdgeStatement -> NonEmpty EdgeID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx EdgeStatement (NonEmpty EdgeID)
#rightEdges EdgeStatement
e)

-- | A subgraph statement.
--
-- Note: each subgraph must have a unique name
--
-- >>> runDotParser "subgraph A {A, B, C}" :: Statement
-- StatementSubGraph (SubGraphStatement {subgraphID = Just (ID "A"), subgraphStatements = [StatementNode (NodeStatement {nodeID = ID "A", port = Nothing, nodeAttrs = fromList []}),StatementNode (NodeStatement {nodeID = ID "B", port = Nothing, nodeAttrs = fromList []}),StatementNode (NodeStatement {nodeID = ID "C", port = Nothing, nodeAttrs = fromList []})]})
data SubGraphStatement = SubGraphStatement {SubGraphStatement -> Maybe ID
subgraphID :: Maybe ID, SubGraphStatement -> [Statement]
subgraphStatements :: [Statement]} deriving (SubGraphStatement -> SubGraphStatement -> Bool
(SubGraphStatement -> SubGraphStatement -> Bool)
-> (SubGraphStatement -> SubGraphStatement -> Bool)
-> Eq SubGraphStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubGraphStatement -> SubGraphStatement -> Bool
== :: SubGraphStatement -> SubGraphStatement -> Bool
$c/= :: SubGraphStatement -> SubGraphStatement -> Bool
/= :: SubGraphStatement -> SubGraphStatement -> Bool
Eq, Int -> SubGraphStatement -> ShowS
[SubGraphStatement] -> ShowS
SubGraphStatement -> String
(Int -> SubGraphStatement -> ShowS)
-> (SubGraphStatement -> String)
-> ([SubGraphStatement] -> ShowS)
-> Show SubGraphStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubGraphStatement -> ShowS
showsPrec :: Int -> SubGraphStatement -> ShowS
$cshow :: SubGraphStatement -> String
show :: SubGraphStatement -> String
$cshowList :: [SubGraphStatement] -> ShowS
showList :: [SubGraphStatement] -> ShowS
Show, (forall x. SubGraphStatement -> Rep SubGraphStatement x)
-> (forall x. Rep SubGraphStatement x -> SubGraphStatement)
-> Generic SubGraphStatement
forall x. Rep SubGraphStatement x -> SubGraphStatement
forall x. SubGraphStatement -> Rep SubGraphStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SubGraphStatement -> Rep SubGraphStatement x
from :: forall x. SubGraphStatement -> Rep SubGraphStatement x
$cto :: forall x. Rep SubGraphStatement x -> SubGraphStatement
to :: forall x. Rep SubGraphStatement x -> SubGraphStatement
Generic)

instance DotParse SubGraphStatement where
  dotPrint :: DotConfig -> SubGraphStatement -> ByteString
dotPrint DotConfig
cfg (SubGraphStatement Maybe ID
x [Statement]
xs) =
    ByteString -> [ByteString] -> ByteString
intercalate ByteString
" " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      [ByteString] -> (ID -> [ByteString]) -> Maybe ID -> [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        []
        (\ID
x' -> [ByteString -> [ByteString] -> ByteString
intercalate ByteString
" " [ByteString
"subgraph", DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
x']])
        Maybe ID
x
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: []) (ByteString -> ByteString
wrapCurlyPrint (ByteString -> [ByteString] -> ByteString
intercalate (DotConfig
cfg DotConfig -> Optic' A_Lens NoIx DotConfig ByteString -> ByteString
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx DotConfig ByteString
#subGraphSep) ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ DotConfig -> Statement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (Statement -> ByteString) -> [Statement] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Statement]
xs))

  dotParse :: ParserT PureMode Error SubGraphStatement
dotParse = ParserT PureMode Error SubGraphStatement
-> ParserT PureMode Error SubGraphStatement
forall e a. Parser e a -> Parser e a
token (ParserT PureMode Error SubGraphStatement
 -> ParserT PureMode Error SubGraphStatement)
-> ParserT PureMode Error SubGraphStatement
-> ParserT PureMode Error SubGraphStatement
forall a b. (a -> b) -> a -> b
$ do
    Maybe ID
x <- ParserT PureMode Error ID -> ParserT PureMode Error (Maybe ID)
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional ($(keyword "subgraph") ParserT PureMode Error ()
-> ParserT PureMode Error ID -> ParserT PureMode Error ID
forall a b.
ParserT PureMode Error a
-> ParserT PureMode Error b -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT PureMode Error ID
forall a. DotParse a => Parser Error a
dotParse)
    ([Statement] -> SubGraphStatement)
-> ParserT PureMode Error ([Statement] -> SubGraphStatement)
forall a. a -> ParserT PureMode Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ID -> [Statement] -> SubGraphStatement
SubGraphStatement Maybe ID
x) ParserT PureMode Error ([Statement] -> SubGraphStatement)
-> Parser Error [Statement]
-> ParserT PureMode Error SubGraphStatement
forall a b.
ParserT PureMode Error (a -> b)
-> ParserT PureMode Error a -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error [Statement] -> Parser Error [Statement]
forall a. Parser Error a -> Parser Error a
wrapCurlyP (ParserT PureMode Error Statement -> Parser Error [Statement]
forall a. ParserT PureMode Error a -> ParserT PureMode Error [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParserT PureMode Error () -> ParserT PureMode Error (Maybe ())
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional ParserT PureMode Error ()
forall e. Parser e ()
sepP ParserT PureMode Error (Maybe ())
-> ParserT PureMode Error Statement
-> ParserT PureMode Error Statement
forall a b.
ParserT PureMode Error a
-> ParserT PureMode Error b -> ParserT PureMode Error b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT PureMode Error Statement
forall a. DotParse a => Parser Error a
dotParse))

-- | add a graphviz statement to a 'Graph'
addStatement :: Statement -> Graph -> Graph
addStatement :: Statement -> Graph -> Graph
addStatement (StatementNode NodeStatement
n) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx Graph [NodeStatement]
#nodes Optic' A_Lens NoIx Graph [NodeStatement]
-> ([NodeStatement] -> [NodeStatement]) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ ([NodeStatement] -> [NodeStatement] -> [NodeStatement]
forall a. Semigroup a => a -> a -> a
<> [NodeStatement
n])
addStatement (StatementEdge EdgeStatement
e) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph [EdgeStatement] [EdgeStatement]
#edges Optic A_Lens NoIx Graph Graph [EdgeStatement] [EdgeStatement]
-> ([EdgeStatement] -> [EdgeStatement]) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ ([EdgeStatement] -> [EdgeStatement] -> [EdgeStatement]
forall a. Semigroup a => a -> a -> a
<> [EdgeStatement
e])
addStatement (StatementSubGraph SubGraphStatement
s) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Graph Graph [SubGraphStatement] [SubGraphStatement]
#subgraphs Optic
  A_Lens NoIx Graph Graph [SubGraphStatement] [SubGraphStatement]
-> ([SubGraphStatement] -> [SubGraphStatement]) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ ([SubGraphStatement] -> [SubGraphStatement] -> [SubGraphStatement]
forall a. Semigroup a => a -> a -> a
<> [SubGraphStatement
s])
addStatement (StatementAttribute (AttributeStatement AttributeType
GraphType Map ID ID
as)) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#graphAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> (Map ID ID -> Map ID ID) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
as)
addStatement (StatementAttribute (AttributeStatement AttributeType
NodeType Map ID ID
as)) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#nodeAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> (Map ID ID -> Map ID ID) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
as)
addStatement (StatementAttribute (AttributeStatement AttributeType
EdgeType Map ID ID
as)) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#edgeAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> (Map ID ID -> Map ID ID) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
as)
addStatement (StatementGlobalAttribute (GlobalAttributeStatement (ID, ID)
s)) Graph
g = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#globalAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> (Map ID ID -> Map ID ID) -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> [(ID, ID)] -> Map ID ID
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ID, ID)
s])

-- | add a list of graphviz statements to a 'Graph'
addStatements :: [Statement] -> Graph -> Graph
addStatements :: [Statement] -> Graph -> Graph
addStatements [Statement]
ss Graph
g = (Statement -> Graph -> Graph) -> Graph -> [Statement] -> Graph
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr Statement -> Graph -> Graph
addStatement Graph
g [Statement]
ss

-- | run a dot string through graphviz, supplying arguments and collecting stdout
processDotWith :: Directed -> [String] -> ByteString -> IO ByteString
processDotWith :: Directed -> [String] -> ByteString -> IO ByteString
processDotWith Directed
d [String]
args ByteString
i = do
  let cmd :: String
cmd = case Directed
d of
        Directed
Directed -> String
"dot"
        Directed
UnDirected -> String
"neato"
  (ExitCode
r, ByteString
input, ByteString
e) <- String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
cmd [String]
args ByteString
i
  IO ByteString -> IO ByteString -> Bool -> IO ByteString
forall a. a -> a -> Bool -> a
bool
    (String -> IO ByteString
forall a. HasCallStack => String -> a
error (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> String
utf8ToStr ByteString
e)
    (ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
input)
    (ExitCode
r ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess)

-- | run a dot string through graphviz, collecting the augmented dot string output
processDot :: Directed -> ByteString -> IO ByteString
processDot :: Directed -> ByteString -> IO ByteString
processDot Directed
d = Directed -> [String] -> ByteString -> IO ByteString
processDotWith Directed
d [String
"-Tdot"]

-- | Augment a Graph via the graphviz process
processGraphWith :: DotConfig -> Graph -> IO Graph
processGraphWith :: DotConfig -> Graph -> IO Graph
processGraphWith DotConfig
cfg Graph
g =
  ByteString -> Graph
forall a. DotParse a => ByteString -> a
runDotParser (ByteString -> Graph) -> IO ByteString -> IO Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Directed -> ByteString -> IO ByteString
processDot (Last Directed -> Directed
defDirected (Last Directed -> Directed) -> Last Directed -> Directed
forall a b. (a -> b) -> a -> b
$ Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
-> Graph -> Last Directed
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
#directed Graph
g) (DotConfig -> Graph -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Graph
g)

-- | Augment a Graph via the graphviz process
processGraph :: Graph -> IO Graph
processGraph :: Graph -> IO Graph
processGraph Graph
g =
  ByteString -> Graph
forall a. DotParse a => ByteString -> a
runDotParser (ByteString -> Graph) -> IO ByteString -> IO Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Directed -> ByteString -> IO ByteString
processDot (Last Directed -> Directed
defDirected (Last Directed -> Directed) -> Last Directed -> Directed
forall a b. (a -> b) -> a -> b
$ Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
-> Graph -> Last Directed
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
#directed Graph
g) (DotConfig -> Graph -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
defaultDotConfig Graph
g)

instance DotParse (Point Double) where
  dotPrint :: DotConfig -> Point Double -> ByteString
dotPrint DotConfig
_ (Point Double
x Double
y) =
    ByteString -> [ByteString] -> ByteString
intercalate ByteString
"," ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      String -> ByteString
strToUtf8 (String -> ByteString)
-> (Double -> String) -> Double -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> ByteString) -> [Double] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double
x, Double
y]

  dotParse :: Parser Error (Point Double)
dotParse = Parser Error (Point Double) -> Parser Error (Point Double)
forall e a. Parser e a -> Parser e a
token Parser Error (Point Double)
pointP

pointI :: Iso' ID (Point Double)
pointI :: Iso' ID (Point Double)
pointI =
  (ID -> Point Double)
-> (Point Double -> ID) -> Iso' ID (Point Double)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (Parser Error (Point Double) -> ByteString -> Point Double
forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error (Point Double)
pointP (ByteString -> Point Double)
-> (ID -> ByteString) -> ID -> Point Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 (String -> ByteString) -> (ID -> String) -> ID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label)
    (ByteString -> ID
IDQuoted (ByteString -> ID)
-> (Point Double -> ByteString) -> Point Double -> ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotConfig -> Point Double -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
defaultDotConfig)

instance DotParse (Rect Double) where
  dotPrint :: DotConfig -> Rect Double -> ByteString
dotPrint DotConfig
_ (Rect Double
x Double
z Double
y Double
w) =
    ByteString -> [ByteString] -> ByteString
intercalate ByteString
"," ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      String -> ByteString
strToUtf8 (String -> ByteString)
-> (Double -> String) -> Double -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> ByteString) -> [Double] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double
x, Double
y, Double
z, Double
w]

  dotParse :: Parser Error (Rect Double)
dotParse = Parser Error (Rect Double) -> Parser Error (Rect Double)
forall e a. Parser e a -> Parser e a
token Parser Error (Rect Double)
rectP

rectI :: Iso' ID (Rect Double)
rectI :: Iso' ID (Rect Double)
rectI =
  (ID -> Rect Double) -> (Rect Double -> ID) -> Iso' ID (Rect Double)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (Parser Error (Rect Double) -> ByteString -> Rect Double
forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error (Rect Double)
rectP (ByteString -> Rect Double)
-> (ID -> ByteString) -> ID -> Rect Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 (String -> ByteString) -> (ID -> String) -> ID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label)
    (ByteString -> ID
IDQuoted (ByteString -> ID)
-> (Rect Double -> ByteString) -> Rect Double -> ID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotConfig -> Rect Double -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
defaultDotConfig)

-- | Bounding box ID lens
bb_ :: Lens' Graph (Maybe ID)
bb_ :: Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
bb_ = Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
#graphAttributes Optic A_Lens NoIx Graph Graph (Map ID ID) (Map ID ID)
-> Optic A_Lens NoIx (Map ID ID) (Map ID ID) (Maybe ID) (Maybe ID)
-> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map ID ID)
-> Lens' (Map ID ID) (Maybe (IxValue (Map ID ID)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (ByteString -> ID
ID ByteString
"bb")

-- | Bounding Box lens as a 'Rect'
bbL :: Lens' Graph (Maybe (Rect Double))
bbL :: Lens' Graph (Maybe (Rect Double))
bbL = (Graph -> Maybe (Rect Double))
-> (Graph -> Maybe (Rect Double) -> Graph)
-> Lens' Graph (Maybe (Rect Double))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (Optic' An_AffineTraversal NoIx Graph (Rect Double)
-> Graph -> Maybe (Rect Double)
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
bb_ Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Optic A_Prism NoIx (Maybe ID) (Maybe ID) ID ID
-> Optic An_AffineTraversal NoIx Graph Graph ID ID
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx (Maybe ID) (Maybe ID) ID ID
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Optic An_AffineTraversal NoIx Graph Graph ID ID
-> Iso' ID (Rect Double)
-> Optic' An_AffineTraversal NoIx Graph (Rect Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Iso' ID (Rect Double)
rectI)) (\Graph
g Maybe (Rect Double)
r -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
bb_ (Iso' ID (Rect Double) -> Rect Double -> ID
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' ID (Rect Double)
rectI (Rect Double -> ID) -> Maybe (Rect Double) -> Maybe ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Rect Double)
r) Graph
g)

-- | nodes lens
nodesPortL :: Lens' Graph (Map.Map ID (Maybe Port, Map.Map ID ID))
nodesPortL :: Lens' Graph (Map ID (Maybe Port, Map ID ID))
nodesPortL =
  (Graph -> Map ID (Maybe Port, Map ID ID))
-> (Graph -> Map ID (Maybe Port, Map ID ID) -> Graph)
-> Lens' Graph (Map ID (Maybe Port, Map ID ID))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    ( \Graph
g ->
        Graph
g
          Graph -> (Graph -> [NodeStatement]) -> [NodeStatement]
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx Graph [NodeStatement]
-> Graph -> [NodeStatement]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Graph [NodeStatement]
#nodes
          [NodeStatement]
-> ([NodeStatement] -> [(ID, (Maybe Port, Map ID ID))])
-> [(ID, (Maybe Port, Map ID ID))]
forall a b. a -> (a -> b) -> b
& (NodeStatement -> (ID, (Maybe Port, Map ID ID)))
-> [NodeStatement] -> [(ID, (Maybe Port, Map ID ID))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NodeStatement
x -> (Optic' A_Lens NoIx NodeStatement ID -> NodeStatement -> ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NodeStatement ID
#nodeID NodeStatement
x, (Optic' A_Lens NoIx NodeStatement (Maybe Port)
-> NodeStatement -> Maybe Port
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NodeStatement (Maybe Port)
#port NodeStatement
x, Optic' A_Lens NoIx NodeStatement (Map ID ID)
-> NodeStatement -> Map ID ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NodeStatement (Map ID ID)
#nodeAttrs NodeStatement
x)))
          [(ID, (Maybe Port, Map ID ID))]
-> ([(ID, (Maybe Port, Map ID ID))]
    -> Map ID (Maybe Port, Map ID ID))
-> Map ID (Maybe Port, Map ID ID)
forall a b. a -> (a -> b) -> b
& [(ID, (Maybe Port, Map ID ID))] -> Map ID (Maybe Port, Map ID ID)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    )
    (\Graph
g Map ID (Maybe Port, Map ID ID)
m -> Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx Graph [NodeStatement]
#nodes Optic' A_Lens NoIx Graph [NodeStatement]
-> [NodeStatement] -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ((\(ID
n, (Maybe Port
p, Map ID ID
a)) -> ID -> Maybe Port -> Map ID ID -> NodeStatement
NodeStatement ID
n Maybe Port
p Map ID ID
a) ((ID, (Maybe Port, Map ID ID)) -> NodeStatement)
-> [(ID, (Maybe Port, Map ID ID))] -> [NodeStatement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ID (Maybe Port, Map ID ID) -> [(ID, (Maybe Port, Map ID ID))]
forall k a. Map k a -> [(k, a)]
Map.toList Map ID (Maybe Port, Map ID ID)
m))

-- | nodes lens ignoring/forgetting port information
nodesL :: Lens' Graph (Map.Map ID (Map.Map ID ID))
nodesL :: Lens' Graph (Map ID (Map ID ID))
nodesL =
  (Graph -> Map ID (Map ID ID))
-> (Graph -> Map ID (Map ID ID) -> Graph)
-> Lens' Graph (Map ID (Map ID ID))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    ( \Graph
g ->
        Graph
g
          Graph -> (Graph -> [NodeStatement]) -> [NodeStatement]
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx Graph [NodeStatement]
-> Graph -> [NodeStatement]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Graph [NodeStatement]
#nodes
          [NodeStatement]
-> ([NodeStatement] -> [(ID, Map ID ID)]) -> [(ID, Map ID ID)]
forall a b. a -> (a -> b) -> b
& (NodeStatement -> (ID, Map ID ID))
-> [NodeStatement] -> [(ID, Map ID ID)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NodeStatement
x -> (Optic' A_Lens NoIx NodeStatement ID -> NodeStatement -> ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NodeStatement ID
#nodeID NodeStatement
x, Optic' A_Lens NoIx NodeStatement (Map ID ID)
-> NodeStatement -> Map ID ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx NodeStatement (Map ID ID)
#nodeAttrs NodeStatement
x))
          [(ID, Map ID ID)]
-> ([(ID, Map ID ID)] -> Map ID (Map ID ID)) -> Map ID (Map ID ID)
forall a b. a -> (a -> b) -> b
& [(ID, Map ID ID)] -> Map ID (Map ID ID)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    )
    (\Graph
g Map ID (Map ID ID)
m -> Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx Graph [NodeStatement]
#nodes Optic' A_Lens NoIx Graph [NodeStatement]
-> [NodeStatement] -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ((\(ID
n, Map ID ID
a) -> ID -> Maybe Port -> Map ID ID -> NodeStatement
NodeStatement ID
n Maybe Port
forall a. Maybe a
Nothing Map ID ID
a) ((ID, Map ID ID) -> NodeStatement)
-> [(ID, Map ID ID)] -> [NodeStatement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ID (Map ID ID) -> [(ID, Map ID ID)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ID (Map ID ID)
m))

-- | edges lens ignoring/forgetting port information
edgesL :: Lens' Graph (Map.Map (ID, ID) (Map.Map ID ID))
edgesL :: Lens' Graph (Map (ID, ID) (Map ID ID))
edgesL =
  (Graph -> Map (ID, ID) (Map ID ID))
-> (Graph -> Map (ID, ID) (Map ID ID) -> Graph)
-> Lens' Graph (Map (ID, ID) (Map ID ID))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Graph -> Map (ID, ID) (Map ID ID)
getEdges_ Graph -> Map (ID, ID) (Map ID ID) -> Graph
setEdges_

-- | edge & attribute map
-- ignores anonymous subgraphs
getEdges_ :: Graph -> Map.Map (ID, ID) (Map.Map ID ID)
getEdges_ :: Graph -> Map (ID, ID) (Map ID ID)
getEdges_ Graph
g =
  [((ID, ID), Map ID ID)] -> Map (ID, ID) (Map ID ID)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((ID, ID), Map ID ID)] -> Map (ID, ID) (Map ID ID))
-> [((ID, ID), Map ID ID)] -> Map (ID, ID) (Map ID ID)
forall a b. (a -> b) -> a -> b
$
    [[((ID, ID), Map ID ID)]] -> [((ID, ID), Map ID ID)]
forall a. Monoid a => [a] -> a
mconcat ([[((ID, ID), Map ID ID)]] -> [((ID, ID), Map ID ID)])
-> [[((ID, ID), Map ID ID)]] -> [((ID, ID), Map ID ID)]
forall a b. (a -> b) -> a -> b
$
      (([(ID, ID)], Map ID ID) -> [((ID, ID), Map ID ID)])
-> [([(ID, ID)], Map ID ID)] -> [[((ID, ID), Map ID ID)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\([(ID, ID)]
xs, Map ID ID
a) -> (,Map ID ID
a) ((ID, ID) -> ((ID, ID), Map ID ID))
-> [(ID, ID)] -> [((ID, ID), Map ID ID)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ID, ID)]
xs)
        [(EdgeStatement -> [(ID, ID)]
edgeIDsNamed EdgeStatement
e, Optic' A_Lens NoIx EdgeStatement (Map ID ID)
-> EdgeStatement -> Map ID ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx EdgeStatement (Map ID ID)
#edgeAttrs EdgeStatement
e) | EdgeStatement
e <- Optic A_Lens NoIx Graph Graph [EdgeStatement] [EdgeStatement]
-> Graph -> [EdgeStatement]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx Graph Graph [EdgeStatement] [EdgeStatement]
#edges Graph
g]

setEdges_ :: Graph -> Map.Map (ID, ID) (Map.Map ID ID) -> Graph
setEdges_ :: Graph -> Map (ID, ID) (Map ID ID) -> Graph
setEdges_ Graph
g Map (ID, ID) (Map ID ID)
m =
  Graph
g
    Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph [EdgeStatement] [EdgeStatement]
#edges
    Optic A_Lens NoIx Graph Graph [EdgeStatement] [EdgeStatement]
-> [EdgeStatement] -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ( ( \((ID
x0, ID
x1), Map ID ID
as) ->
             EdgeOp -> EdgeID -> NonEmpty EdgeID -> Map ID ID -> EdgeStatement
EdgeStatement
               (Directed -> EdgeOp
fromDirected (Last Directed -> Directed
defDirected (Last Directed -> Directed) -> Last Directed -> Directed
forall a b. (a -> b) -> a -> b
$ Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
-> Graph -> Last Directed
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
#directed Graph
g))
               (ID -> Maybe Port -> EdgeID
EdgeID ID
x0 Maybe Port
forall a. Maybe a
Nothing)
               (ID -> Maybe Port -> EdgeID
EdgeID ID
x1 Maybe Port
forall a. Maybe a
Nothing EdgeID -> [EdgeID] -> NonEmpty EdgeID
forall a. a -> [a] -> NonEmpty a
:| [])
               Map ID ID
as
         )
           (((ID, ID), Map ID ID) -> EdgeStatement)
-> [((ID, ID), Map ID ID)] -> [EdgeStatement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (ID, ID) (Map ID ID) -> [((ID, ID), Map ID ID)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (ID, ID) (Map ID ID)
m
       )

-- | A specific attribute for all nodes in a graph
nodesA :: ID -> Graph -> Map.Map ID (Maybe ID)
nodesA :: ID -> Graph -> Map ID (Maybe ID)
nodesA ID
a Graph
g = (Map ID ID -> Maybe ID) -> Map ID (Map ID ID) -> Map ID (Maybe ID)
forall a b. (a -> b) -> Map ID a -> Map ID b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ID -> Map ID ID -> Maybe ID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ID
a) (Lens' Graph (Map ID (Map ID ID)) -> Graph -> Map ID (Map ID ID)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' Graph (Map ID (Map ID ID))
nodesL Graph
g)

-- | node position (as a Point)
nodePos :: Graph -> Map.Map ID (Maybe (Point Double))
nodePos :: Graph -> Map ID (Maybe (Point Double))
nodePos = (Maybe ID -> Maybe (Point Double))
-> Map ID (Maybe ID) -> Map ID (Maybe (Point Double))
forall a b. (a -> b) -> Map ID a -> Map ID b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ID -> Point Double) -> Maybe ID -> Maybe (Point Double)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Iso' ID (Point Double) -> ID -> Point Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' ID (Point Double)
pointI)) (Map ID (Maybe ID) -> Map ID (Maybe (Point Double)))
-> (Graph -> Map ID (Maybe ID))
-> Graph
-> Map ID (Maybe (Point Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> Graph -> Map ID (Maybe ID)
nodesA (ByteString -> ID
ID ByteString
"pos")

--

-- | Specific attribute for all edges
edgesA :: Graph -> ID -> Map.Map (ID, ID) (Maybe ID)
edgesA :: Graph -> ID -> Map (ID, ID) (Maybe ID)
edgesA Graph
g ID
a = (Map ID ID -> Maybe ID)
-> Map (ID, ID) (Map ID ID) -> Map (ID, ID) (Maybe ID)
forall a b. (a -> b) -> Map (ID, ID) a -> Map (ID, ID) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ID -> Map ID ID -> Maybe ID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ID
a) (Lens' Graph (Map (ID, ID) (Map ID ID))
-> Graph -> Map (ID, ID) (Map ID ID)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' Graph (Map (ID, ID) (Map ID ID))
edgesL Graph
g)

-- | node width attributes
nodeWidth :: Graph -> Map.Map ID (Maybe Double)
nodeWidth :: Graph -> Map ID (Maybe Double)
nodeWidth Graph
g =
  (Maybe ID -> Maybe Double)
-> Map ID (Maybe ID) -> Map ID (Maybe Double)
forall a b. (a -> b) -> Map ID a -> Map ID b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        Just (IDDouble Double
x') -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x'
        Maybe ID
_ -> Maybe Double
forall a. Maybe a
Nothing
    )
    (Map ID (Maybe ID) -> Map ID (Maybe Double))
-> Map ID (Maybe ID) -> Map ID (Maybe Double)
forall a b. (a -> b) -> a -> b
$ ID -> Graph -> Map ID (Maybe ID)
nodesA (ByteString -> ID
ID ByteString
"width") Graph
g

-- | edge width attributes
edgeWidth :: Graph -> Map.Map (ID, ID) (Maybe Double)
edgeWidth :: Graph -> Map (ID, ID) (Maybe Double)
edgeWidth Graph
g =
  (Maybe ID -> Maybe Double)
-> Map (ID, ID) (Maybe ID) -> Map (ID, ID) (Maybe Double)
forall a b. (a -> b) -> Map (ID, ID) a -> Map (ID, ID) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        Just (IDDouble Double
x') -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x'
        Maybe ID
_ -> Maybe Double
forall a. Maybe a
Nothing
    )
    (Map (ID, ID) (Maybe ID) -> Map (ID, ID) (Maybe Double))
-> Map (ID, ID) (Maybe ID) -> Map (ID, ID) (Maybe Double)
forall a b. (a -> b) -> a -> b
$ Graph -> ID -> Map (ID, ID) (Maybe ID)
edgesA Graph
g (ByteString -> ID
ID ByteString
"width")

-- | edge path attributes
edgeSpline :: Graph -> Map.Map (ID, ID) (Maybe Spline)
edgeSpline :: Graph -> Map (ID, ID) (Maybe Spline)
edgeSpline Graph
g =
  (Maybe ID -> Maybe Spline)
-> Map (ID, ID) (Maybe ID) -> Map (ID, ID) (Maybe Spline)
forall a b. (a -> b) -> Map (ID, ID) a -> Map (ID, ID) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        Just (IDQuoted ByteString
x') -> Spline -> Maybe Spline
forall a. a -> Maybe a
Just (Parser Error Spline -> ByteString -> Spline
forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error Spline
splineP ByteString
x')
        Maybe ID
_ -> Maybe Spline
forall a. Maybe a
Nothing
    )
    (Map (ID, ID) (Maybe ID) -> Map (ID, ID) (Maybe Spline))
-> Map (ID, ID) (Maybe ID) -> Map (ID, ID) (Maybe Spline)
forall a b. (a -> b) -> a -> b
$ Graph -> ID -> Map (ID, ID) (Maybe ID)
edgesA Graph
g (ByteString -> ID
ID ByteString
"pos")

-- | typical node information after processing a dot bytestring.
data NodeInfo = NodeInfo {NodeInfo -> ID
nlabel :: ID, NodeInfo -> Double
nwidth :: Double, NodeInfo -> Point Double
pos :: Point Double} deriving (NodeInfo -> NodeInfo -> Bool
(NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool) -> Eq NodeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeInfo -> NodeInfo -> Bool
== :: NodeInfo -> NodeInfo -> Bool
$c/= :: NodeInfo -> NodeInfo -> Bool
/= :: NodeInfo -> NodeInfo -> Bool
Eq, Int -> NodeInfo -> ShowS
[NodeInfo] -> ShowS
NodeInfo -> String
(Int -> NodeInfo -> ShowS)
-> (NodeInfo -> String) -> ([NodeInfo] -> ShowS) -> Show NodeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeInfo -> ShowS
showsPrec :: Int -> NodeInfo -> ShowS
$cshow :: NodeInfo -> String
show :: NodeInfo -> String
$cshowList :: [NodeInfo] -> ShowS
showList :: [NodeInfo] -> ShowS
Show, (forall x. NodeInfo -> Rep NodeInfo x)
-> (forall x. Rep NodeInfo x -> NodeInfo) -> Generic NodeInfo
forall x. Rep NodeInfo x -> NodeInfo
forall x. NodeInfo -> Rep NodeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NodeInfo -> Rep NodeInfo x
from :: forall x. NodeInfo -> Rep NodeInfo x
$cto :: forall x. Rep NodeInfo x -> NodeInfo
to :: forall x. Rep NodeInfo x -> NodeInfo
Generic)

-- | Create a list of NodeInfo from a graph.
nodeInfo :: Graph -> Double -> [NodeInfo]
nodeInfo :: Graph -> Double -> [NodeInfo]
nodeInfo Graph
g Double
w = [ID -> Double -> Point Double -> NodeInfo
NodeInfo ID
x (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
w (Maybe (Maybe Double) -> Maybe Double
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Double)
w')) Point Double
p | (ID
x, (Just Point Double
p, Maybe (Maybe Double)
w')) <- [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
xs]
  where
    xs :: [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
xs =
      Map ID (Maybe (Point Double), Maybe (Maybe Double))
-> [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ID (Maybe (Point Double), Maybe (Maybe Double))
 -> [(ID, (Maybe (Point Double), Maybe (Maybe Double)))])
-> Map ID (Maybe (Point Double), Maybe (Maybe Double))
-> [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
forall a b. (a -> b) -> a -> b
$
        SimpleWhenMissing
  ID
  (Maybe (Point Double))
  (Maybe (Point Double), Maybe (Maybe Double))
-> SimpleWhenMissing
     ID (Maybe Double) (Maybe (Point Double), Maybe (Maybe Double))
-> SimpleWhenMatched
     ID
     (Maybe (Point Double))
     (Maybe Double)
     (Maybe (Point Double), Maybe (Maybe Double))
-> Map ID (Maybe (Point Double))
-> Map ID (Maybe Double)
-> Map ID (Maybe (Point Double), Maybe (Maybe Double))
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge
          ((ID
 -> Maybe (Point Double)
 -> (Maybe (Point Double), Maybe (Maybe Double)))
-> SimpleWhenMissing
     ID
     (Maybe (Point Double))
     (Maybe (Point Double), Maybe (Maybe Double))
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\ID
_ Maybe (Point Double)
v -> (Maybe (Point Double)
v, Maybe (Maybe Double)
forall a. Maybe a
Nothing)))
          SimpleWhenMissing
  ID (Maybe Double) (Maybe (Point Double), Maybe (Maybe Double))
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
dropMissing
          ((ID
 -> Maybe (Point Double)
 -> Maybe Double
 -> (Maybe (Point Double), Maybe (Maybe Double)))
-> SimpleWhenMatched
     ID
     (Maybe (Point Double))
     (Maybe Double)
     (Maybe (Point Double), Maybe (Maybe Double))
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
zipWithMatched (\ID
_ Maybe (Point Double)
x Maybe Double
y -> (Maybe (Point Double)
x, Maybe Double -> Maybe (Maybe Double)
forall a. a -> Maybe a
Just Maybe Double
y)))
          (Graph -> Map ID (Maybe (Point Double))
nodePos Graph
g)
          (Graph -> Map ID (Maybe Double)
nodeWidth Graph
g)

-- | typical edge information after processing a dot bytestring.
data EdgeInfo = EdgeInfo {EdgeInfo -> (ID, ID)
elabel :: (ID, ID), EdgeInfo -> Double
ewidth :: Double, EdgeInfo -> [PathData Double]
curve :: [PathData Double]} deriving (EdgeInfo -> EdgeInfo -> Bool
(EdgeInfo -> EdgeInfo -> Bool)
-> (EdgeInfo -> EdgeInfo -> Bool) -> Eq EdgeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeInfo -> EdgeInfo -> Bool
== :: EdgeInfo -> EdgeInfo -> Bool
$c/= :: EdgeInfo -> EdgeInfo -> Bool
/= :: EdgeInfo -> EdgeInfo -> Bool
Eq, Int -> EdgeInfo -> ShowS
[EdgeInfo] -> ShowS
EdgeInfo -> String
(Int -> EdgeInfo -> ShowS)
-> (EdgeInfo -> String) -> ([EdgeInfo] -> ShowS) -> Show EdgeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeInfo -> ShowS
showsPrec :: Int -> EdgeInfo -> ShowS
$cshow :: EdgeInfo -> String
show :: EdgeInfo -> String
$cshowList :: [EdgeInfo] -> ShowS
showList :: [EdgeInfo] -> ShowS
Show, (forall x. EdgeInfo -> Rep EdgeInfo x)
-> (forall x. Rep EdgeInfo x -> EdgeInfo) -> Generic EdgeInfo
forall x. Rep EdgeInfo x -> EdgeInfo
forall x. EdgeInfo -> Rep EdgeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EdgeInfo -> Rep EdgeInfo x
from :: forall x. EdgeInfo -> Rep EdgeInfo x
$cto :: forall x. Rep EdgeInfo x -> EdgeInfo
to :: forall x. Rep EdgeInfo x -> EdgeInfo
Generic)

-- | Create a list of EdgeInfo from a graph
edgeInfo :: Graph -> Double -> [EdgeInfo]
edgeInfo :: Graph -> Double -> [EdgeInfo]
edgeInfo Graph
g Double
w = [(ID, ID) -> Double -> [PathData Double] -> EdgeInfo
EdgeInfo (ID
x, ID
y) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
w (Maybe (Maybe Double) -> Maybe Double
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Double)
w')) (Spline -> [PathData Double]
splinePath Spline
p) | ((ID
x, ID
y), (Just Spline
p, Maybe (Maybe Double)
w')) <- [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
xs]
  where
    xs :: [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
xs =
      Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
-> [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
 -> [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))])
-> Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
-> [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
forall a b. (a -> b) -> a -> b
$
        SimpleWhenMissing
  (ID, ID) (Maybe Spline) (Maybe Spline, Maybe (Maybe Double))
-> SimpleWhenMissing
     (ID, ID) (Maybe Double) (Maybe Spline, Maybe (Maybe Double))
-> SimpleWhenMatched
     (ID, ID)
     (Maybe Spline)
     (Maybe Double)
     (Maybe Spline, Maybe (Maybe Double))
-> Map (ID, ID) (Maybe Spline)
-> Map (ID, ID) (Maybe Double)
-> Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge
          (((ID, ID) -> Maybe Spline -> (Maybe Spline, Maybe (Maybe Double)))
-> SimpleWhenMissing
     (ID, ID) (Maybe Spline) (Maybe Spline, Maybe (Maybe Double))
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\(ID, ID)
_ Maybe Spline
v -> (Maybe Spline
v, Maybe (Maybe Double)
forall a. Maybe a
Nothing)))
          SimpleWhenMissing
  (ID, ID) (Maybe Double) (Maybe Spline, Maybe (Maybe Double))
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
dropMissing
          (((ID, ID)
 -> Maybe Spline
 -> Maybe Double
 -> (Maybe Spline, Maybe (Maybe Double)))
-> SimpleWhenMatched
     (ID, ID)
     (Maybe Spline)
     (Maybe Double)
     (Maybe Spline, Maybe (Maybe Double))
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
zipWithMatched (\(ID, ID)
_ Maybe Spline
x Maybe Double
y -> (Maybe Spline
x, Maybe Double -> Maybe (Maybe Double)
forall a. a -> Maybe a
Just Maybe Double
y)))
          (Graph -> Map (ID, ID) (Maybe Spline)
edgeSpline Graph
g)
          (Graph -> Map (ID, ID) (Maybe Double)
edgeWidth Graph
g)

-- |
--
-- https://graphviz.org/docs/attr-types/splineType/
-- format of the example is end point point and then triples (5,8,11 lengths are 1, 2 and 3 cubics)
splinePath :: Spline -> [PathData Double]
splinePath :: Spline -> [PathData Double]
splinePath Spline
sp = [PathData Double]
s' [PathData Double] -> [PathData Double] -> [PathData Double]
forall a. Semigroup a => a -> a -> a
<> [PathData Double]
p1' [PathData Double] -> [PathData Double] -> [PathData Double]
forall a. Semigroup a => a -> a -> a
<> [PathData Double]
cs [PathData Double] -> [PathData Double] -> [PathData Double]
forall a. Semigroup a => a -> a -> a
<> [PathData Double]
e'
  where
    s' :: [PathData Double]
s' = [PathData Double]
-> (Point Double -> [PathData Double])
-> Maybe (Point Double)
-> [PathData Double]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Point Double
s -> [Point Double -> PathData Double
forall a. Point a -> PathData a
StartP Point Double
s, Point Double -> PathData Double
forall a. Point a -> PathData a
LineP (Point Double -> PathData Double)
-> Point Double -> PathData Double
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens NoIx Spline (Point Double) -> Spline -> Point Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Spline (Point Double)
#splineP1 Spline
sp]) (Optic' A_Lens NoIx Spline (Maybe (Point Double))
-> Spline -> Maybe (Point Double)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Spline (Maybe (Point Double))
#splineStart Spline
sp)
    e' :: [PathData Double]
e' = [PathData Double]
-> (Point Double -> [PathData Double])
-> Maybe (Point Double)
-> [PathData Double]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Point Double
e -> [Point Double -> PathData Double
forall a. Point a -> PathData a
LineP Point Double
e]) (Optic' A_Lens NoIx Spline (Maybe (Point Double))
-> Spline -> Maybe (Point Double)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Spline (Maybe (Point Double))
#splineEnd Spline
sp)
    p1' :: [PathData Double]
p1' = [Point Double -> PathData Double
forall a. Point a -> PathData a
StartP (Optic' A_Lens NoIx Spline (Point Double) -> Spline -> Point Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Spline (Point Double)
#splineP1 Spline
sp)]
    cs :: [PathData Double]
cs = (\(Point Double
x, Point Double
y, Point Double
z) -> Point Double -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> Point a -> PathData a
CubicP Point Double
x Point Double
y Point Double
z) ((Point Double, Point Double, Point Double) -> PathData Double)
-> [(Point Double, Point Double, Point Double)]
-> [PathData Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic'
  A_Lens NoIx Spline [(Point Double, Point Double, Point Double)]
-> Spline -> [(Point Double, Point Double, Point Double)]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  A_Lens NoIx Spline [(Point Double, Point Double, Point Double)]
#splineTriples Spline
sp

-- | create Statements from a (no edge label) algebraic graph
toStatements :: Directed -> G.Graph ByteString -> [Statement]
toStatements :: Directed -> Graph ByteString -> [Statement]
toStatements Directed
d Graph ByteString
g =
  ((\ByteString
x -> NodeStatement -> Statement
StatementNode (NodeStatement -> Statement) -> NodeStatement -> Statement
forall a b. (a -> b) -> a -> b
$ ID -> Maybe Port -> Map ID ID -> NodeStatement
NodeStatement (ByteString -> ID
IDQuoted ByteString
x) Maybe Port
forall a. Maybe a
Nothing Map ID ID
forall k a. Map k a
Map.empty) (ByteString -> Statement) -> [ByteString] -> [Statement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph ByteString -> [ByteString]
forall a. Ord a => Graph a -> [a]
G.vertexList Graph ByteString
g)
    [Statement] -> [Statement] -> [Statement]
forall a. Semigroup a => a -> a -> a
<> ( ( \(ByteString
x, ByteString
y) ->
             EdgeStatement -> Statement
StatementEdge (EdgeStatement -> Statement) -> EdgeStatement -> Statement
forall a b. (a -> b) -> a -> b
$
               EdgeOp -> EdgeID -> NonEmpty EdgeID -> Map ID ID -> EdgeStatement
EdgeStatement
                 (Directed -> EdgeOp
fromDirected Directed
d)
                 (ID -> Maybe Port -> EdgeID
EdgeID (ByteString -> ID
IDQuoted ByteString
x) Maybe Port
forall a. Maybe a
Nothing)
                 ([EdgeID] -> NonEmpty EdgeID
forall a. HasCallStack => [a] -> NonEmpty a
fromList [ID -> Maybe Port -> EdgeID
EdgeID (ByteString -> ID
IDQuoted ByteString
y) Maybe Port
forall a. Maybe a
Nothing])
                 Map ID ID
forall k a. Map k a
Map.empty
         )
           ((ByteString, ByteString) -> Statement)
-> [(ByteString, ByteString)] -> [Statement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph ByteString -> [(ByteString, ByteString)]
forall a. Ord a => Graph a -> [(a, a)]
G.edgeList Graph ByteString
g
       )

-- | Various configutaion parameters for the chart-svg Chart
data ChartConfig = ChartConfig
  { ChartConfig -> Double
chartHeight :: Double,
    ChartConfig -> Double
chartScale :: Double,
    ChartConfig -> Double
edgeSize :: Double,
    ChartConfig -> Double
nodeBorderSize :: Double,
    ChartConfig -> Colour
chartColor :: Colour,
    ChartConfig -> Colour
chartBackgroundColor :: Colour,
    ChartConfig -> Double
backupNodeHeight :: Double,
    ChartConfig -> Double
backupNodeWidth :: Double,
    ChartConfig -> Double
chartVshift :: Double,
    ChartConfig -> Double
textSize :: Double,
    ChartConfig -> EscapeText
escapeText :: EscapeText
  }
  deriving ((forall x. ChartConfig -> Rep ChartConfig x)
-> (forall x. Rep ChartConfig x -> ChartConfig)
-> Generic ChartConfig
forall x. Rep ChartConfig x -> ChartConfig
forall x. ChartConfig -> Rep ChartConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChartConfig -> Rep ChartConfig x
from :: forall x. ChartConfig -> Rep ChartConfig x
$cto :: forall x. Rep ChartConfig x -> ChartConfig
to :: forall x. Rep ChartConfig x -> ChartConfig
Generic, Int -> ChartConfig -> ShowS
[ChartConfig] -> ShowS
ChartConfig -> String
(Int -> ChartConfig -> ShowS)
-> (ChartConfig -> String)
-> ([ChartConfig] -> ShowS)
-> Show ChartConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChartConfig -> ShowS
showsPrec :: Int -> ChartConfig -> ShowS
$cshow :: ChartConfig -> String
show :: ChartConfig -> String
$cshowList :: [ChartConfig] -> ShowS
showList :: [ChartConfig] -> ShowS
Show, ChartConfig -> ChartConfig -> Bool
(ChartConfig -> ChartConfig -> Bool)
-> (ChartConfig -> ChartConfig -> Bool) -> Eq ChartConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChartConfig -> ChartConfig -> Bool
== :: ChartConfig -> ChartConfig -> Bool
$c/= :: ChartConfig -> ChartConfig -> Bool
/= :: ChartConfig -> ChartConfig -> Bool
Eq)

-- | default parameters
defaultChartConfig :: ChartConfig
defaultChartConfig :: ChartConfig
defaultChartConfig = Double
-> Double
-> Double
-> Double
-> Colour
-> Colour
-> Double
-> Double
-> Double
-> Double
-> EscapeText
-> ChartConfig
ChartConfig Double
500 Double
72 Double
0.5 Double
1 (Double -> Double -> Colour
grey Double
0.4 Double
0.8) (Double -> Double -> Colour
grey Double
0.5 Double
0.2) Double
0.5 Double
0.5 (-Double
6) Double
16 EscapeText
NoEscapeText

-- | convert a 'Graph' processed via the graphviz commands to a 'ChartOptions'
graphToChartWith :: ChartConfig -> (ID -> Text) -> Graph -> ChartOptions
graphToChartWith :: ChartConfig -> (ID -> Text) -> Graph -> ChartOptions
graphToChartWith ChartConfig
cfg ID -> Text
labelf Graph
g =
  ChartOptions
forall a. Monoid a => a
mempty
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions ChartTree ChartTree
-> ChartTree -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx ChartOptions ChartOptions ChartTree ChartTree
#chartTree (Text -> [Chart] -> ChartTree
named Text
"edges" [Chart]
ps ChartTree -> ChartTree -> ChartTree
forall a. Semigroup a => a -> a -> a
<> Text -> [Chart] -> ChartTree
named Text
"shapes" [Chart]
c0 ChartTree -> ChartTree -> ChartTree
forall a. Semigroup a => a -> a -> a
<> Text -> [Chart] -> ChartTree
named Text
"labels" [Chart
ts])
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic
  A_Traversal (Int : NoIx) ChartOptions ChartOptions ScaleP ScaleP
-> ScaleP -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Optic A_Lens NoIx ChartOptions ChartOptions ChartTree ChartTree
#chartTree Optic A_Lens NoIx ChartOptions ChartOptions ChartTree ChartTree
-> Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
-> Optic A_Traversal NoIx ChartOptions ChartOptions [Chart] [Chart]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
charts' Optic A_Traversal NoIx ChartOptions ChartOptions [Chart] [Chart]
-> Optic A_Traversal (Int : NoIx) [Chart] [Chart] Chart Chart
-> Optic
     A_Traversal (Int : NoIx) ChartOptions ChartOptions Chart Chart
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal (Int : NoIx) [Chart] [Chart] Chart Chart
forall i s t a b. Each i s t a b => IxTraversal i s t a b
each Optic
  A_Traversal (Int : NoIx) ChartOptions ChartOptions Chart Chart
-> Optic A_Lens NoIx Chart Chart Style Style
-> Optic
     A_Traversal (Int : NoIx) ChartOptions ChartOptions Style Style
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Chart Chart Style Style
#chartStyle Optic
  A_Traversal (Int : NoIx) ChartOptions ChartOptions Style Style
-> Optic A_Lens NoIx Style Style ScaleP ScaleP
-> Optic
     A_Traversal (Int : NoIx) ChartOptions ChartOptions ScaleP ScaleP
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Style Style ScaleP ScaleP
#scaleP) ScaleP
ScalePArea
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions
    Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens
     NoIx
     MarkupOptions
     MarkupOptions
     (Maybe Double)
     (Maybe Double)
-> Optic
     A_Lens NoIx ChartOptions ChartOptions (Maybe Double) (Maybe Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  MarkupOptions
  MarkupOptions
  (Maybe Double)
  (Maybe Double)
#markupHeight
    Optic
  A_Lens NoIx ChartOptions ChartOptions (Maybe Double) (Maybe Double)
-> Maybe Double -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#chartHeight)
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions
    Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens NoIx MarkupOptions MarkupOptions ChartAspect ChartAspect
-> Optic
     A_Lens NoIx ChartOptions ChartOptions ChartAspect ChartAspect
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens NoIx MarkupOptions MarkupOptions ChartAspect ChartAspect
#chartAspect
    Optic A_Lens NoIx ChartOptions ChartOptions ChartAspect ChartAspect
-> ChartAspect -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ChartAspect
ChartAspect
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions HudOptions HudOptions
#hudOptions
    Optic A_Lens NoIx ChartOptions ChartOptions HudOptions HudOptions
-> HudOptions -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ HudOptions
forall a. Monoid a => a
mempty
  where
    glyphs :: Double -> Style
glyphs Double
w = case Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Graph -> Maybe ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"shape")) Graph
g of
      Just (ID ByteString
"circle") -> Style
defaultGlyphStyle Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style GlyphShape GlyphShape
#glyphShape Optic A_Lens NoIx Style Style GlyphShape GlyphShape
-> GlyphShape -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ GlyphShape
CircleGlyph Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#size Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#chartScale) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#borderSize Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#edgeSize) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#borderColor Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartColor) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#color Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartBackgroundColor)
      Just (ID ByteString
"box") -> Style
defaultGlyphStyle Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style GlyphShape GlyphShape
#glyphShape Optic A_Lens NoIx Style Style GlyphShape GlyphShape
-> GlyphShape -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Double -> GlyphShape
RectSharpGlyph (Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
w) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#size Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#chartScale) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#borderSize Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Optic' A_Lens NoIx ChartConfig Double -> ChartConfig -> Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx ChartConfig Double
#nodeBorderSize ChartConfig
cfg Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#borderColor Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartColor) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#color Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartBackgroundColor)
      -- defaults to circle
      Maybe ID
_ -> Style
defaultGlyphStyle Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style GlyphShape GlyphShape
#glyphShape Optic A_Lens NoIx Style Style GlyphShape GlyphShape
-> GlyphShape -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ GlyphShape
CircleGlyph Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#size Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#chartScale) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#borderSize Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Optic' A_Lens NoIx ChartConfig Double -> ChartConfig -> Double
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx ChartConfig Double
#nodeBorderSize ChartConfig
cfg Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#borderColor Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartColor) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#color Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartBackgroundColor)
    h :: Double
h = Double -> (ID -> Double) -> Maybe ID -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#backupNodeHeight) (ParserT PureMode Error Double -> ByteString -> Double
forall a. Parser Error a -> ByteString -> a
runParser_ ParserT PureMode Error Double
double (ByteString -> Double) -> (ID -> ByteString) -> ID -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 (String -> ByteString) -> (ID -> String) -> ID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label) (Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
-> Graph -> Maybe ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (AttributeType
-> ID -> Optic A_Lens NoIx Graph Graph (Maybe ID) (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"height")) Graph
g)
    vshift' :: Double
vshift' = ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#chartVshift
    -- node information
    ns :: [NodeInfo]
ns = Graph -> Double -> [NodeInfo]
nodeInfo Graph
g (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#backupNodeWidth)
    -- edge information
    es :: [EdgeInfo]
es = Graph -> Double -> [EdgeInfo]
edgeInfo Graph
g (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#edgeSize)
    -- paths
    ps :: [Chart]
ps = (EdgeInfo -> Chart) -> [EdgeInfo] -> [Chart]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EdgeInfo (ID, ID)
_ Double
w [PathData Double]
p) -> Style -> [PathData Double] -> Chart
PathChart (Style
defaultPathStyle Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#borderSize Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#borderColor Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartColor) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#color Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Colour
transparent) [PathData Double]
p) [EdgeInfo]
es
    -- circles
    c0 :: [Chart]
c0 = (NodeInfo -> Chart) -> [NodeInfo] -> [Chart]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(NodeInfo ID
_ Double
w Point Double
p) -> Style -> [Point Double] -> Chart
GlyphChart (Double -> Style
glyphs Double
w) [Point Double
p]) [NodeInfo]
ns
    -- labels
    ts :: Chart
ts =
      Style -> [(Text, Point Double)] -> Chart
TextChart (Style
defaultTextStyle Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style EscapeText EscapeText
#escapeText Optic A_Lens NoIx Style Style EscapeText EscapeText
-> EscapeText -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig
-> Optic' A_Lens NoIx ChartConfig EscapeText -> EscapeText
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig EscapeText
#escapeText) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
#size Optic A_Lens NoIx Style Style Double Double
-> Double -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Double
#textSize) Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
#color Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ChartConfig Colour
#chartColor)) ((\(NodeInfo ID
l Double
_ (Point Double
x Double
y)) -> (ID -> Text
labelf ID
l, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x (Double
vshift' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y))) (NodeInfo -> (Text, Point Double))
-> [NodeInfo] -> [(Text, Point Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeInfo]
ns)

-- | convert a 'Graph' processed via the graphviz commands to a 'ChartOptions' using the default ChartConfig.
graphToChart :: Graph -> ChartOptions
graphToChart :: Graph -> ChartOptions
graphToChart = ChartConfig -> (ID -> Text) -> Graph -> ChartOptions
graphToChartWith ChartConfig
defaultChartConfig (String -> Text
Text.pack (String -> Text) -> (ID -> String) -> ID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label)

-- | Convert an algebraic graph to a dotparse graph.
toDotGraphWith :: Directed -> Graph -> G.Graph ByteString -> Graph
toDotGraphWith :: Directed -> Graph -> Graph ByteString -> Graph
toDotGraphWith Directed
d Graph
g Graph ByteString
gg = Graph
g Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
#directed Optic A_Lens NoIx Graph Graph (Last Directed) (Last Directed)
-> Last Directed -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Maybe Directed -> Last Directed
forall a. Maybe a -> Last a
Last (Directed -> Maybe Directed
forall a. a -> Maybe a
Just Directed
d) Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& [Statement] -> Graph -> Graph
addStatements (Directed -> Graph ByteString -> [Statement]
toStatements Directed
d Graph ByteString
gg)

-- | Convert an algebraic graph to a dotparse graph, starting with the 'defaultGraph'.
toDotGraph :: G.Graph ByteString -> Graph
toDotGraph :: Graph ByteString -> Graph
toDotGraph = Directed -> Graph -> Graph ByteString -> Graph
toDotGraphWith Directed
Directed Graph
defaultGraph