{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotConfig -> DotConfig -> Bool
$c/= :: DotConfig -> DotConfig -> Bool
== :: DotConfig -> DotConfig -> Bool
$c== :: DotConfig -> DotConfig -> Bool
Eq, Int -> DotConfig -> ShowS
[DotConfig] -> ShowS
DotConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotConfig] -> ShowS
$cshowList :: [DotConfig] -> ShowS
show :: DotConfig -> String
$cshow :: DotConfig -> String
showsPrec :: Int -> DotConfig -> ShowS
$cshowsPrec :: Int -> DotConfig -> ShowS
Show, 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
$cto :: forall x. Rep DotConfig x -> DotConfig
$cfrom :: forall x. DotConfig -> Rep DotConfig x
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 forall e a. Parser e a -> ByteString -> Result e a
runParser forall a. DotParse a => Parser Error a
dotParse ByteString
b :: Result Error a of
    Err Error
e -> ByteString -> IO ()
B.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> ByteString
prettyError ByteString
b Error
e
    OK a
a ByteString
left -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
left forall a. Eq a => a -> a -> Bool
/= ByteString
"") (ByteString -> IO ()
B.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString
"parsed with leftovers: " forall a. Semigroup a => a -> a -> a
<> ByteString
left)
      case forall e a. Parser e a -> ByteString -> Result e a
runParser forall a. DotParse a => Parser Error a
dotParse (forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg a
a) :: Result Error a of
        Err Error
e -> ByteString -> IO ()
B.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString
"round trip error: " forall a. Semigroup a => a -> a -> a
<> ByteString -> Error -> ByteString
prettyError (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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
left' forall a. Eq a => a -> a -> Bool
/= ByteString
"") (ByteString -> IO ()
B.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString
"round trip parse with left overs" 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 = forall a. Parser Error a -> ByteString -> a
runParser_ 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Graph -> Graph -> Bool
$c/= :: Graph -> Graph -> Bool
== :: Graph -> Graph -> Bool
$c== :: Graph -> Graph -> Bool
Eq, Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Graph] -> ShowS
$cshowList :: [Graph] -> ShowS
show :: Graph -> String
$cshow :: Graph -> String
showsPrec :: Int -> Graph -> ShowS
$cshowsPrec :: Int -> Graph -> ShowS
Show, 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
$cto :: forall x. Rep Graph x -> Graph
$cfrom :: forall x. Graph -> Rep Graph x
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 forall a. Semigroup a => a -> a -> a
<> Last Strict
m') (Last Directed
d forall a. Semigroup a => a -> a -> a
<> Last Directed
d') (Last ID
i forall a. Semigroup a => a -> a -> a
<> Last ID
i') (Map ID ID
na forall a. Semigroup a => a -> a -> a
<> Map ID ID
na') (Map ID ID
ga forall a. Semigroup a => a -> a -> a
<> Map ID ID
ga') (Map ID ID
ea forall a. Semigroup a => a -> a -> a
<> Map ID ID
ea') (Map ID ID
gs forall a. Semigroup a => a -> a -> a
<> Map ID ID
gs') ([NodeStatement]
ns forall a. Semigroup a => a -> a -> a
<> [NodeStatement]
ns') ([EdgeStatement]
es forall a. Semigroup a => a -> a -> a
<> [EdgeStatement]
es') ([SubGraphStatement]
ss 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 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty 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 =
  forall a. Monoid a => a
mempty
    forall a b. a -> (a -> b) -> b
& 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 -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"height")) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> ID
IDDouble Double
0.5)
    forall a b. a -> (a -> b) -> b
& 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 -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"shape")) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ID
ID ByteString
"circle")
    forall a b. a -> (a -> b) -> b
& 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 -> Lens' Graph (Maybe ID)
attL AttributeType
GraphType (ByteString -> ID
ID ByteString
"overlap")) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ID
ID ByteString
"false")
    forall a b. a -> (a -> b) -> b
& 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 -> Lens' Graph (Maybe ID)
attL AttributeType
GraphType (ByteString -> ID
ID ByteString
"size")) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ID
IDQuoted ByteString
"1!")
    forall a b. a -> (a -> b) -> b
& 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 -> Lens' Graph (Maybe ID)
attL AttributeType
GraphType (ByteString -> ID
ID ByteString
"splines")) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ID
ID ByteString
"spline")
    forall a b. a -> (a -> b) -> b
& 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 -> Lens' Graph (Maybe ID)
attL AttributeType
EdgeType (ByteString -> ID
ID ByteString
"arrowsize")) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> ID
IDDouble Double
0.5)
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set forall a. IsLabel "directed" a => a
#directed (forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just Directed
Directed))
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (ID -> Lens' Graph (Maybe ID)
gattL (ByteString -> ID
ID ByteString
"rankdir")) (forall a. a -> Maybe a
Just (ByteString -> ID
IDQuoted ByteString
"TB"))

-- | global attributes lens
gattL :: ID -> Lens' Graph (Maybe ID)
gattL :: ID -> Lens' Graph (Maybe ID)
gattL ID
k = forall a. IsLabel "globalAttributes" a => a
#globalAttributes 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
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ID
k

-- | attributes lens
attL :: AttributeType -> ID -> Lens' Graph (Maybe ID)
attL :: AttributeType -> ID -> Lens' Graph (Maybe ID)
attL AttributeType
GraphType ID
k = forall a. IsLabel "graphAttributes" a => a
#graphAttributes 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
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ID
k
attL AttributeType
NodeType ID
k = forall a. IsLabel "nodeAttributes" a => a
#nodeAttributes 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
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ID
k
attL AttributeType
EdgeType ID
k = forall a. IsLabel "edgeAttributes" a => a
#edgeAttributes 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
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ID
k

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

  dotParse :: Parser Error Graph
dotParse = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ do
    Strict
me <- forall a. DotParse a => Parser Error a
dotParse
    Directed
d <- forall a. DotParse a => Parser Error a
dotParse
    Maybe ID
i <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall a. DotParse a => Parser Error a
dotParse
    [Statement]
ss <- forall a. Parser Error a -> Parser Error a
wrapCurlyP (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a. DotParse a => Parser Error a
dotParse)
    let g :: Graph
g =
          (forall a. Monoid a => a
mempty :: Graph)
            forall a b. a -> (a -> b) -> b
& forall a. IsLabel "strict" a => a
#strict
            forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just Strict
me)
            forall a b. a -> (a -> b) -> b
& forall a. IsLabel "directed" a => a
#directed
            forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just Directed
d)
            forall a b. a -> (a -> b) -> b
& forall a. IsLabel "graphid" a => a
#graphid
            forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Maybe a -> Last a
Last Maybe ID
i
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Strict -> Strict -> Bool
$c/= :: Strict -> Strict -> Bool
== :: Strict -> Strict -> Bool
$c== :: Strict -> Strict -> Bool
Eq, Int -> Strict -> ShowS
[Strict] -> ShowS
Strict -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Strict] -> ShowS
$cshowList :: [Strict] -> ShowS
show :: Strict -> String
$cshow :: Strict -> String
showsPrec :: Int -> Strict -> ShowS
$cshowsPrec :: Int -> Strict -> ShowS
Show, 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
$cto :: forall x. Rep Strict x -> Strict
$cfrom :: forall x. Strict -> Rep Strict x
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 = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ 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")) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Strict
MergeEdges) (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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Directed -> Directed -> Bool
$c/= :: Directed -> Directed -> Bool
== :: Directed -> Directed -> Bool
$c== :: Directed -> Directed -> Bool
Eq, Int -> Directed -> ShowS
[Directed] -> ShowS
Directed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Directed] -> ShowS
$cshowList :: [Directed] -> ShowS
show :: Directed -> String
$cshow :: Directed -> String
showsPrec :: Int -> Directed -> ShowS
$cshowsPrec :: Int -> Directed -> ShowS
Show, 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
$cto :: forall x. Rep Directed x -> Directed
$cfrom :: forall x. Directed -> Rep Directed x
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 =
    forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$
      (Directed
Directed forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "digraph"))
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Directed
UnDirected 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c== :: Statement -> Statement -> Bool
Eq, Int -> Statement -> ShowS
[Statement] -> ShowS
Statement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> String
$cshow :: Statement -> String
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show, 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
$cto :: forall x. Rep Statement x -> Statement
$cfrom :: forall x. Statement -> Rep Statement x
Generic)

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

  dotParse :: Parser Error Statement
dotParse =
    forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$
      -- Order is important
      (EdgeStatement -> Statement
StatementEdge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse)
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (AttributeStatement -> Statement
StatementAttribute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse)
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (GlobalAttributeStatement -> Statement
StatementGlobalAttribute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse)
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (SubGraphStatement -> Statement
StatementSubGraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse)
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (NodeStatement -> Statement
StatementNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ID -> ID -> Bool
$c/= :: ID -> ID -> Bool
== :: ID -> ID -> Bool
$c== :: ID -> ID -> Bool
Eq, Int -> ID -> ShowS
[ID] -> ShowS
ID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ID] -> ShowS
$cshowList :: [ID] -> ShowS
show :: ID -> String
$cshow :: ID -> String
showsPrec :: Int -> ID -> ShowS
$cshowsPrec :: Int -> ID -> ShowS
Show, 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
$cto :: forall x. Rep ID x -> ID
$cfrom :: forall x. ID -> Rep ID x
Generic, Eq 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
min :: ID -> ID -> ID
$cmin :: ID -> ID -> ID
max :: ID -> ID -> ID
$cmax :: ID -> ID -> ID
>= :: ID -> ID -> Bool
$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
compare :: ID -> ID -> Ordering
$ccompare :: ID -> ID -> Ordering
Ord)

instance DotParse ID where
  dotPrint :: DotConfig -> ID -> ByteString
dotPrint DotConfig
_ (ID ByteString
s) = ByteString
s
  dotPrint DotConfig
_ (IDInt Int
i) = String -> ByteString
strToUtf8 (forall a. Show a => a -> String
show Int
i)
  dotPrint DotConfig
_ (IDDouble Double
x) = String -> ByteString
strToUtf8 (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 :: Parser Error ID
dotParse =
    (ByteString -> ID
ID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Parser e ByteString
ident)
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Int -> ID
IDInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b e. Num b => Parser e b -> Parser e b
signed ParserT PureMode Error Int
int forall (st :: ZeroBitType) e a b.
ParserT st e a -> ParserT st e b -> ParserT st e a
`notFollowedBy` $(char '.')))
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Double -> ID
IDDouble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b e. Num b => Parser e b -> Parser e b
signed Parser Error Double
double)
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (ByteString -> ID
IDQuoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error String
quoted)
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (ByteString -> ID
IDHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall a. Show a => a -> String
show Int
i
label (IDDouble Double
d) = 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) = forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
x0 forall a. Semigroup a => a -> a -> a
<> ByteString
"=" forall a. Semigroup a => a -> a -> a
<> forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
x1

  dotParse :: Parser Error (ID, ID)
dotParse = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$
    do
      ID
x0 <- forall e a. Parser e a -> Parser e a
token forall a. DotParse a => Parser Error a
dotParse
      ()
_ <- forall e a. Parser e a -> Parser e a
token $(symbol "=")
      ID
x1 <- forall a. DotParse a => Parser Error a
dotParse
      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 =
    forall a. a -> a -> Bool -> a
bool
      (ByteString -> ByteString
wrapSquarePrint (ByteString -> [ByteString] -> ByteString
intercalate (DotConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "attSep" a => a
#attSep) forall a b. (a -> b) -> a -> b
$ forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map ID ID
as))
      forall a. Monoid a => a
mempty
      (Map ID ID
as forall a. Eq a => a -> a -> Bool
== forall k a. Map k a
Map.empty)

  dotParse :: Parser Error (Map ID ID)
dotParse =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> [a]
toList
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Parser e a -> Parser e a
token (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. Parser Error a -> Parser Error a
wrapSquareP (forall e a. Parser e a -> Parser e () -> Parser e (NonEmpty a)
nonEmptyP forall a. DotParse a => Parser Error a
dotParse forall e. Parser e ()
sepP)) forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> ([] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Parser Error a -> Parser Error a
wrapSquareP 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Compass -> Compass -> Bool
$c/= :: Compass -> Compass -> Bool
== :: Compass -> Compass -> Bool
$c== :: Compass -> Compass -> Bool
Eq, Int -> Compass -> ShowS
[Compass] -> ShowS
Compass -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Compass] -> ShowS
$cshowList :: [Compass] -> ShowS
show :: Compass -> String
$cshow :: Compass -> String
showsPrec :: Int -> Compass -> ShowS
$cshowsPrec :: Int -> Compass -> ShowS
Show, 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
$cto :: forall x. Rep Compass x -> Compass
$cfrom :: forall x. Compass -> Rep Compass x
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 =
    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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c== :: Port -> Port -> Bool
Eq, Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show, 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
$cto :: forall x. Rep Port x -> Port
$cfrom :: forall x. Port -> Rep Port x
Generic)

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

  dotParse :: Parser Error Port
dotParse =
    forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$
      ((\ID
x0 Compass
x1 -> These ID Compass -> Port
Port (forall a b. a -> b -> These a b
These ID
x0 Compass
x1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ($(symbol ":") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. DotParse a => Parser Error a
dotParse) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ($(symbol ":") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. DotParse a => Parser Error a
dotParse))
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (These ID Compass -> Port
Port forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> These a b
This forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ($(symbol ":") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. DotParse a => Parser Error a
dotParse))
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (These ID Compass -> Port
Port forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> These a b
That forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ($(symbol ":") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
$c/= :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
== :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
$c== :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
Eq, Int -> GlobalAttributeStatement -> ShowS
[GlobalAttributeStatement] -> ShowS
GlobalAttributeStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobalAttributeStatement] -> ShowS
$cshowList :: [GlobalAttributeStatement] -> ShowS
show :: GlobalAttributeStatement -> String
$cshow :: GlobalAttributeStatement -> String
showsPrec :: Int -> GlobalAttributeStatement -> ShowS
$cshowsPrec :: Int -> GlobalAttributeStatement -> ShowS
Show, 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
$cto :: forall x.
Rep GlobalAttributeStatement x -> GlobalAttributeStatement
$cfrom :: forall x.
GlobalAttributeStatement -> Rep GlobalAttributeStatement x
Generic)

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

-- | Category of attribute
data AttributeType = GraphType | NodeType | EdgeType deriving (AttributeType -> AttributeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeType -> AttributeType -> Bool
$c/= :: AttributeType -> AttributeType -> Bool
== :: AttributeType -> AttributeType -> Bool
$c== :: AttributeType -> AttributeType -> Bool
Eq, Int -> AttributeType -> ShowS
[AttributeType] -> ShowS
AttributeType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeType] -> ShowS
$cshowList :: [AttributeType] -> ShowS
show :: AttributeType -> String
$cshow :: AttributeType -> String
showsPrec :: Int -> AttributeType -> ShowS
$cshowsPrec :: Int -> AttributeType -> ShowS
Show, 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
$cto :: forall x. Rep AttributeType x -> AttributeType
$cfrom :: forall x. AttributeType -> Rep AttributeType x
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 =
    forall e a. Parser e a -> Parser e a
token
      (AttributeType
GraphType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "graph"))
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (AttributeType
NodeType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "node"))
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (AttributeType
EdgeType 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeStatement -> AttributeStatement -> Bool
$c/= :: AttributeStatement -> AttributeStatement -> Bool
== :: AttributeStatement -> AttributeStatement -> Bool
$c== :: AttributeStatement -> AttributeStatement -> Bool
Eq, Int -> AttributeStatement -> ShowS
[AttributeStatement] -> ShowS
AttributeStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeStatement] -> ShowS
$cshowList :: [AttributeStatement] -> ShowS
show :: AttributeStatement -> String
$cshow :: AttributeStatement -> String
showsPrec :: Int -> AttributeStatement -> ShowS
$cshowsPrec :: Int -> AttributeStatement -> ShowS
Show, 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
$cto :: forall x. Rep AttributeStatement x -> AttributeStatement
$cfrom :: forall x. AttributeStatement -> Rep AttributeStatement x
Generic)

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

  dotParse :: Parser Error AttributeStatement
dotParse = AttributeType -> Map ID ID -> AttributeStatement
AttributeStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeStatement -> NodeStatement -> Bool
$c/= :: NodeStatement -> NodeStatement -> Bool
== :: NodeStatement -> NodeStatement -> Bool
$c== :: NodeStatement -> NodeStatement -> Bool
Eq, Int -> NodeStatement -> ShowS
[NodeStatement] -> ShowS
NodeStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeStatement] -> ShowS
$cshowList :: [NodeStatement] -> ShowS
show :: NodeStatement -> String
$cshow :: NodeStatement -> String
showsPrec :: Int -> NodeStatement -> ShowS
$cshowsPrec :: Int -> NodeStatement -> ShowS
Show, 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
$cto :: forall x. Rep NodeStatement x -> NodeStatement
$cfrom :: forall x. NodeStatement -> Rep NodeStatement x
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
" " forall a b. (a -> b) -> a -> b
$
      [forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i]
        forall a. Semigroup a => a -> a -> a
<> (forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> [a]
maybeToList Maybe Port
p)
        forall a. Semigroup a => a -> a -> a
<> [forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]

  dotParse :: Parser Error NodeStatement
dotParse = ID -> Maybe Port -> Map ID ID -> NodeStatement
NodeStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall a. DotParse a => Parser Error a
dotParse forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeID -> EdgeID -> Bool
$c/= :: EdgeID -> EdgeID -> Bool
== :: EdgeID -> EdgeID -> Bool
$c== :: EdgeID -> EdgeID -> Bool
Eq, Int -> EdgeID -> ShowS
[EdgeID] -> ShowS
EdgeID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeID] -> ShowS
$cshowList :: [EdgeID] -> ShowS
show :: EdgeID -> String
$cshow :: EdgeID -> String
showsPrec :: Int -> EdgeID -> ShowS
$cshowsPrec :: Int -> EdgeID -> ShowS
Show, 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
$cto :: forall x. Rep EdgeID x -> EdgeID
$cfrom :: forall x. EdgeID -> Rep EdgeID x
Generic)

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

  dotParse :: Parser Error EdgeID
dotParse =
    (ID -> Maybe Port -> EdgeID
EdgeID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall a. DotParse a => Parser Error a
dotParse)
      forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (SubGraphStatement -> EdgeID
EdgeSubGraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeOp -> EdgeOp -> Bool
$c/= :: EdgeOp -> EdgeOp -> Bool
== :: EdgeOp -> EdgeOp -> Bool
$c== :: EdgeOp -> EdgeOp -> Bool
Eq, Int -> EdgeOp -> ShowS
[EdgeOp] -> ShowS
EdgeOp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeOp] -> ShowS
$cshowList :: [EdgeOp] -> ShowS
show :: EdgeOp -> String
$cshow :: EdgeOp -> String
showsPrec :: Int -> EdgeOp -> ShowS
$cshowsPrec :: Int -> EdgeOp -> ShowS
Show, 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
$cto :: forall x. Rep EdgeOp x -> EdgeOp
$cfrom :: forall x. EdgeOp -> Rep EdgeOp x
Generic)

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

  dotParse :: Parser Error EdgeOp
dotParse =
    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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeStatement -> EdgeStatement -> Bool
$c/= :: EdgeStatement -> EdgeStatement -> Bool
== :: EdgeStatement -> EdgeStatement -> Bool
$c== :: EdgeStatement -> EdgeStatement -> Bool
Eq, Int -> EdgeStatement -> ShowS
[EdgeStatement] -> ShowS
EdgeStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeStatement] -> ShowS
$cshowList :: [EdgeStatement] -> ShowS
show :: EdgeStatement -> String
$cshow :: EdgeStatement -> String
showsPrec :: Int -> EdgeStatement -> ShowS
$cshowsPrec :: Int -> EdgeStatement -> ShowS
Show, 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
$cto :: forall x. Rep EdgeStatement x -> EdgeStatement
$cfrom :: forall x. EdgeStatement -> Rep EdgeStatement x
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
" " forall a. Semigroup a => a -> a -> a
<> forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg EdgeOp
l forall a. Semigroup a => a -> a -> a
<> ByteString
" ") (forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EdgeID
rs forall a. a -> [a] -> [a]
: forall a. NonEmpty a -> [a]
toList NonEmpty EdgeID
xs))]
          forall a. Semigroup a => a -> a -> a
<> [forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]
      )

  dotParse :: Parser Error EdgeStatement
dotParse = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ do
    EdgeID
l <- forall a. DotParse a => Parser Error a
dotParse
    EdgeOp
o0 <- forall a. DotParse a => Parser Error a
dotParse
    EdgeID
r0 <- forall a. DotParse a => Parser Error a
dotParse
    [(EdgeOp, EdgeID)]
ors <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DotParse a => Parser Error a
dotParse forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. DotParse a => Parser Error a
dotParse)
    Map ID ID
as <- forall a. DotParse a => Parser Error a
dotParse
    forall a. a -> a -> Bool -> a
bool
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure (EdgeOp -> EdgeID -> NonEmpty EdgeID -> Map ID ID -> EdgeStatement
EdgeStatement EdgeOp
o0 EdgeID
l (EdgeID
r0 forall a. a -> [a] -> NonEmpty a
:| (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(EdgeOp, EdgeID)]
ors)) Map ID ID
as))
      forall (f :: * -> *) a. Alternative f => f a
empty
      (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
/= EdgeOp
o0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_) = 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 = forall a b. [a] -> [b] -> [(a, b)]
zip (Maybe ID
id0 forall a. a -> [a] -> [a]
: [Maybe ID]
id1) [Maybe ID]
id1
  where
    id0 :: Maybe ID
id0 = EdgeID -> Maybe ID
edgeID (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "leftEdge" a => a
#leftEdge EdgeStatement
e)
    id1 :: [Maybe ID]
id1 = EdgeID -> Maybe ID
edgeID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
toList (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "rightEdges" a => a
#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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubGraphStatement -> SubGraphStatement -> Bool
$c/= :: SubGraphStatement -> SubGraphStatement -> Bool
== :: SubGraphStatement -> SubGraphStatement -> Bool
$c== :: SubGraphStatement -> SubGraphStatement -> Bool
Eq, Int -> SubGraphStatement -> ShowS
[SubGraphStatement] -> ShowS
SubGraphStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubGraphStatement] -> ShowS
$cshowList :: [SubGraphStatement] -> ShowS
show :: SubGraphStatement -> String
$cshow :: SubGraphStatement -> String
showsPrec :: Int -> SubGraphStatement -> ShowS
$cshowsPrec :: Int -> SubGraphStatement -> ShowS
Show, 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
$cto :: forall x. Rep SubGraphStatement x -> SubGraphStatement
$cfrom :: forall x. SubGraphStatement -> Rep SubGraphStatement x
Generic)

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

  dotParse :: Parser Error SubGraphStatement
dotParse = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ do
    Maybe ID
x <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional ($(keyword "subgraph") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. DotParse a => Parser Error a
dotParse)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ID -> [Statement] -> SubGraphStatement
SubGraphStatement Maybe ID
x) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser Error a -> Parser Error a
wrapCurlyP (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall e. Parser e ()
sepP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 forall a b. a -> (a -> b) -> b
& forall a. IsLabel "nodes" a => a
#nodes forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> [NodeStatement
n])
addStatement (StatementEdge EdgeStatement
e) Graph
g = Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "edges" a => a
#edges forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> [EdgeStatement
e])
addStatement (StatementSubGraph SubGraphStatement
s) Graph
g = Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "subgraphs" a => a
#subgraphs forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> [SubGraphStatement
s])
addStatement (StatementAttribute (AttributeStatement AttributeType
GraphType Map ID ID
as)) Graph
g = Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "graphAttributes" a => a
#graphAttributes forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Map ID ID
as)
addStatement (StatementAttribute (AttributeStatement AttributeType
NodeType Map ID ID
as)) Graph
g = Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "nodeAttributes" a => a
#nodeAttributes forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Map ID ID
as)
addStatement (StatementAttribute (AttributeStatement AttributeType
EdgeType Map ID ID
as)) Graph
g = Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "edgeAttributes" a => a
#edgeAttributes forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Map ID ID
as)
addStatement (StatementGlobalAttribute (GlobalAttributeStatement (ID, ID)
s)) Graph
g = Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "globalAttributes" a => a
#globalAttributes forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> 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 = 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
  forall a. a -> a -> Bool -> a
bool
    (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ ByteString -> String
utf8ToStr ByteString
e)
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
input)
    (ExitCode
r 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 =
  forall a. DotParse a => ByteString -> a
runDotParser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Directed -> ByteString -> IO ByteString
processDot (Last Directed -> Directed
defDirected forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "directed" a => a
#directed Graph
g) (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 =
  forall a. DotParse a => ByteString -> a
runDotParser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Directed -> ByteString -> IO ByteString
processDot (Last Directed -> Directed
defDirected forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "directed" a => a
#directed Graph
g) (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
"," forall a b. (a -> b) -> a -> b
$
      String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double
x, Double
y]

  dotParse :: Parser Error (Point Double)
dotParse = 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 =
  forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error (Point Double)
pointP forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label)
    (ByteString -> ID
IDQuoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"," forall a b. (a -> b) -> a -> b
$
      String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show 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 = 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 =
  forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error (Rect Double)
rectP forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label)
    (ByteString -> ID
IDQuoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
defaultDotConfig)

-- | Bounding box ID lens
bb_ :: Lens' Graph (Maybe ID)
bb_ :: Lens' Graph (Maybe ID)
bb_ = forall a. IsLabel "graphAttributes" a => a
#graphAttributes 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
% 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 = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Lens' Graph (Maybe ID)
bb_ 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
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just 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 -> forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Lens' Graph (Maybe ID)
bb_ (forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' ID (Rect Double)
rectI 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 =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    ( \Graph
g ->
        Graph
g
          forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodes" a => a
#nodes
          forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NodeStatement
x -> (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodeID" a => a
#nodeID NodeStatement
x, (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "port" a => a
#port NodeStatement
x, forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodeAttrs" a => a
#nodeAttrs NodeStatement
x)))
          forall a b. a -> (a -> b) -> b
& forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    )
    (\Graph
g Map ID (Maybe Port, Map ID ID)
m -> Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "nodes" a => a
#nodes 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    ( \Graph
g ->
        Graph
g
          forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodes" a => a
#nodes
          forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NodeStatement
x -> (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodeID" a => a
#nodeID NodeStatement
x, forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodeAttrs" a => a
#nodeAttrs NodeStatement
x))
          forall a b. a -> (a -> b) -> b
& forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    )
    (\Graph
g Map ID (Map ID ID)
m -> Graph
g forall a b. a -> (a -> b) -> b
& forall a. IsLabel "nodes" a => a
#nodes 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 forall a. Maybe a
Nothing Map ID ID
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
  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 =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    forall a. Monoid a => [a] -> a
mconcat 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ID, ID)]
xs)
        [(EdgeStatement -> [(ID, ID)]
edgeIDsNamed EdgeStatement
e, forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "edgeAttrs" a => a
#edgeAttrs EdgeStatement
e) | EdgeStatement
e <- forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "edges" a => a
#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
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "edges" a => a
#edges
    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 forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "directed" a => a
#directed Graph
g))
               (ID -> Maybe Port -> EdgeID
EdgeID ID
x0 forall a. Maybe a
Nothing)
               (ID -> Maybe Port -> EdgeID
EdgeID ID
x1 forall a. Maybe a
Nothing forall a. a -> [a] -> NonEmpty a
:| [])
               Map ID ID
as
         )
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ID
a) (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' ID (Point Double)
pointI)) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ID
a) (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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        Just (IDDouble Double
x') -> forall a. a -> Maybe a
Just Double
x'
        Maybe ID
_ -> forall a. Maybe a
Nothing
    )
    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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        Just (IDDouble Double
x') -> forall a. a -> Maybe a
Just Double
x'
        Maybe ID
_ -> forall a. Maybe a
Nothing
    )
    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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        Just (IDQuoted ByteString
x') -> forall a. a -> Maybe a
Just (forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error Spline
splineP ByteString
x')
        Maybe ID
_ -> forall a. Maybe a
Nothing
    )
    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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeInfo -> NodeInfo -> Bool
$c/= :: NodeInfo -> NodeInfo -> Bool
== :: NodeInfo -> NodeInfo -> Bool
$c== :: NodeInfo -> NodeInfo -> Bool
Eq, Int -> NodeInfo -> ShowS
[NodeInfo] -> ShowS
NodeInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeInfo] -> ShowS
$cshowList :: [NodeInfo] -> ShowS
show :: NodeInfo -> String
$cshow :: NodeInfo -> String
showsPrec :: Int -> NodeInfo -> ShowS
$cshowsPrec :: Int -> NodeInfo -> ShowS
Show, 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
$cto :: forall x. Rep NodeInfo x -> NodeInfo
$cfrom :: forall x. NodeInfo -> Rep NodeInfo x
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 (forall a. a -> Maybe a -> a
fromMaybe Double
w (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 =
      forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
        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
          (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, forall a. Maybe a
Nothing)))
          forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
dropMissing
          (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, 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeInfo -> EdgeInfo -> Bool
$c/= :: EdgeInfo -> EdgeInfo -> Bool
== :: EdgeInfo -> EdgeInfo -> Bool
$c== :: EdgeInfo -> EdgeInfo -> Bool
Eq, Int -> EdgeInfo -> ShowS
[EdgeInfo] -> ShowS
EdgeInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeInfo] -> ShowS
$cshowList :: [EdgeInfo] -> ShowS
show :: EdgeInfo -> String
$cshow :: EdgeInfo -> String
showsPrec :: Int -> EdgeInfo -> ShowS
$cshowsPrec :: Int -> EdgeInfo -> ShowS
Show, 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
$cto :: forall x. Rep EdgeInfo x -> EdgeInfo
$cfrom :: forall x. EdgeInfo -> Rep EdgeInfo x
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) (forall a. a -> Maybe a -> a
fromMaybe Double
w (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 =
      forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
        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
          (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\(ID, ID)
_ Maybe Spline
v -> (Maybe Spline
v, forall a. Maybe a
Nothing)))
          forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
dropMissing
          (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, 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' forall a. Semigroup a => a -> a -> a
<> [PathData Double]
p1' forall a. Semigroup a => a -> a -> a
<> [PathData Double]
cs forall a. Semigroup a => a -> a -> a
<> [PathData Double]
e'
  where
    s' :: [PathData Double]
s' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Point Double
s -> [forall a. Point a -> PathData a
StartP Point Double
s, forall a. Point a -> PathData a
LineP forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "splineP1" a => a
#splineP1 Spline
sp]) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "splineStart" a => a
#splineStart Spline
sp)
    e' :: [PathData Double]
e' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Point Double
e -> [forall a. Point a -> PathData a
LineP Point Double
e]) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "splineEnd" a => a
#splineEnd Spline
sp)
    p1' :: [PathData Double]
p1' = [forall a. Point a -> PathData a
StartP (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "splineP1" a => a
#splineP1 Spline
sp)]
    cs :: [PathData Double]
cs = (\(Point Double
x, Point Double
y, Point Double
z) -> forall a. Point a -> Point a -> Point a -> PathData a
CubicP Point Double
x Point Double
y Point Double
z) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "splineTriples" a => a
#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 forall a b. (a -> b) -> a -> b
$ ID -> Maybe Port -> Map ID ID -> NodeStatement
NodeStatement (ByteString -> ID
IDQuoted ByteString
x) forall a. Maybe a
Nothing forall k a. Map k a
Map.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => Graph a -> [a]
G.vertexList Graph ByteString
g)
    forall a. Semigroup a => a -> a -> a
<> ( ( \(ByteString
x, ByteString
y) ->
             EdgeStatement -> Statement
StatementEdge 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) forall a. Maybe a
Nothing)
                 (forall a. [a] -> NonEmpty a
fromList [ID -> Maybe Port -> EdgeID
EdgeID (ByteString -> ID
IDQuoted ByteString
y) forall a. Maybe a
Nothing])
                 forall k a. Map k a
Map.empty
         )
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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. 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
$cto :: forall x. Rep ChartConfig x -> ChartConfig
$cfrom :: forall x. ChartConfig -> Rep ChartConfig x
Generic, Int -> ChartConfig -> ShowS
[ChartConfig] -> ShowS
ChartConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChartConfig] -> ShowS
$cshowList :: [ChartConfig] -> ShowS
show :: ChartConfig -> String
$cshow :: ChartConfig -> String
showsPrec :: Int -> ChartConfig -> ShowS
$cshowsPrec :: Int -> ChartConfig -> ShowS
Show, ChartConfig -> ChartConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChartConfig -> ChartConfig -> Bool
$c/= :: ChartConfig -> ChartConfig -> Bool
== :: ChartConfig -> ChartConfig -> Bool
$c== :: 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 =
  forall a. Monoid a => a
mempty
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set forall a. IsLabel "chartTree" a => a
#chartTree (Text -> [Chart] -> ChartTree
named Text
"edges" [Chart]
ps forall a. Semigroup a => a -> a -> a
<> Text -> [Chart] -> ChartTree
named Text
"shapes" [Chart]
c0 forall a. Semigroup a => a -> a -> a
<> Text -> [Chart] -> ChartTree
named Text
"labels" [Chart
ts])
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (forall a. IsLabel "chartTree" a => a
#chartTree 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
% Traversal' ChartTree [Chart]
charts' 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
% forall i s t a b. Each i s t a b => IxTraversal i s t a b
each 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
% forall a. IsLabel "chartStyle" a => a
#chartStyle 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
% forall a. IsLabel "scaleP" a => a
#scaleP) ScaleP
ScalePArea
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "markupOptions" a => a
#markupOptions
    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
% forall a. IsLabel "markupHeight" a => a
#markupHeight
    forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartHeight" a => a
#chartHeight)
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "markupOptions" a => a
#markupOptions
    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
% forall a. IsLabel "chartAspect" a => a
#chartAspect
    forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ChartAspect
ChartAspect
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "hudOptions" a => a
#hudOptions
    forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty
  where
    glyphs :: Double -> Style
glyphs Double
w = case forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (AttributeType -> ID -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"shape")) Graph
g of
      Just (ID ByteString
"circle") -> Style
defaultGlyphStyle forall a b. a -> (a -> b) -> b
& forall a. IsLabel "glyphShape" a => a
#glyphShape forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ GlyphShape
CircleGlyph forall a b. a -> (a -> b) -> b
& forall a. IsLabel "size" a => a
#size forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartScale" a => a
#chartScale) forall a. Num a => a -> a -> a
* Double
w forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderSize" a => a
#borderSize forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "edgeSize" a => a
#edgeSize) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderColor" a => a
#borderColor forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartColor" a => a
#chartColor) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "color" a => a
#color forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartBackgroundColor" a => a
#chartBackgroundColor)
      Just (ID ByteString
"box") -> Style
defaultGlyphStyle forall a b. a -> (a -> b) -> b
& forall a. IsLabel "glyphShape" a => a
#glyphShape 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 forall a. Fractional a => a -> a -> a
/ Double
w) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "size" a => a
#size forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartScale" a => a
#chartScale) forall a. Num a => a -> a -> a
* Double
w forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderSize" a => a
#borderSize forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodeBorderSize" a => a
#nodeBorderSize ChartConfig
cfg forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderColor" a => a
#borderColor forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartColor" a => a
#chartColor) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "color" a => a
#color forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartBackgroundColor" a => a
#chartBackgroundColor)
      -- defaults to circle
      Maybe ID
_ -> Style
defaultGlyphStyle forall a b. a -> (a -> b) -> b
& forall a. IsLabel "glyphShape" a => a
#glyphShape forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ GlyphShape
CircleGlyph forall a b. a -> (a -> b) -> b
& forall a. IsLabel "size" a => a
#size forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartScale" a => a
#chartScale) forall a. Num a => a -> a -> a
* Double
w forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderSize" a => a
#borderSize forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "nodeBorderSize" a => a
#nodeBorderSize ChartConfig
cfg forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderColor" a => a
#borderColor forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartColor" a => a
#chartColor) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "color" a => a
#color forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartBackgroundColor" a => a
#chartBackgroundColor)
    h :: Double
h = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "backupNodeHeight" a => a
#backupNodeHeight) (forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error Double
double forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (AttributeType -> ID -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"height")) Graph
g)
    vshift' :: Double
vshift' = ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartVshift" a => a
#chartVshift
    -- node information
    ns :: [NodeInfo]
ns = Graph -> Double -> [NodeInfo]
nodeInfo Graph
g (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "backupNodeWidth" a => a
#backupNodeWidth)
    -- edge information
    es :: [EdgeInfo]
es = Graph -> Double -> [EdgeInfo]
edgeInfo Graph
g (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "edgeSize" a => a
#edgeSize)
    -- paths
    ps :: [Chart]
ps = 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 forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderSize" a => a
#borderSize forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (Double
2 forall a. Num a => a -> a -> a
* Double
w) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "borderColor" a => a
#borderColor forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartColor" a => a
#chartColor) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "color" a => a
#color 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 = 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 forall a b. a -> (a -> b) -> b
& forall a. IsLabel "escapeText" a => a
#escapeText forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "escapeText" a => a
#escapeText) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "size" a => a
#size forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "textSize" a => a
#textSize) forall a b. a -> (a -> b) -> b
& forall a. IsLabel "color" a => a
#color forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "chartColor" a => a
#chartColor)) ((\(NodeInfo ID
l Double
_ (Point Double
x Double
y)) -> (ID -> Text
labelf ID
l, forall a. a -> a -> Point a
Point Double
x (Double
vshift' forall a. Num a => a -> a -> a
+ Double
y))) 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 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 forall a b. a -> (a -> b) -> b
& forall a. IsLabel "directed" a => a
#directed forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just Directed
d) 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