{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# HLINT ignore "Use unwords" #-}
{-# HLINT ignore "Use <$>" #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# 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 (..),

    -- * 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 qualified Algebra.Graph as G
import Chart
import Control.Monad
import Data.Bool
import Data.ByteString hiding (any, empty, filter, head, length, map, zip, zipWith)
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty hiding (filter, head, length, map, zip, zipWith, (!!))
import Data.Map.Merge.Strict
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import Data.These
import DotParse.FlatParse
import FlatParse.Basic hiding (cut, lines)
import GHC.Generics
import NeatInterpolation
import Optics.Core
import System.Exit
import System.Process.ByteString
import Prelude hiding (replicate)

-- $setup
-- >>> import DotParse
-- >>> import qualified Data.Map as Map
-- >>> :set -XOverloadedStrings

-- | printing options, for separators.
data DotConfig = DotConfig
  { DotConfig -> ByteString
topLevelSep :: ByteString,
    DotConfig -> ByteString
statementSep :: ByteString,
    DotConfig -> ByteString
attSep :: ByteString,
    DotConfig -> ByteString
subGraphSep :: ByteString
  }
  deriving (DotConfig -> DotConfig -> Bool
(DotConfig -> DotConfig -> Bool)
-> (DotConfig -> DotConfig -> Bool) -> Eq DotConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotConfig -> DotConfig -> Bool
$c/= :: DotConfig -> DotConfig -> Bool
== :: DotConfig -> DotConfig -> Bool
$c== :: DotConfig -> DotConfig -> Bool
Eq, Int -> DotConfig -> ShowS
[DotConfig] -> ShowS
DotConfig -> String
(Int -> DotConfig -> ShowS)
-> (DotConfig -> String)
-> ([DotConfig] -> ShowS)
-> Show DotConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotConfig] -> ShowS
$cshowList :: [DotConfig] -> ShowS
show :: DotConfig -> String
$cshow :: DotConfig -> String
showsPrec :: Int -> DotConfig -> ShowS
$cshowsPrec :: Int -> DotConfig -> ShowS
Show, (forall x. DotConfig -> Rep DotConfig x)
-> (forall x. Rep DotConfig x -> DotConfig) -> Generic DotConfig
forall x. Rep DotConfig x -> DotConfig
forall x. DotConfig -> Rep DotConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 :: Proxy a -> DotConfig -> ByteString -> IO ()
testDotParser Proxy a
_ DotConfig
cfg ByteString
b =
  case Parser Error a -> ByteString -> Result Error a
forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
forall a. DotParse a => Parser Error a
dotParse ByteString
b :: Result Error a of
    Err Error
e -> ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> ByteString
prettyError ByteString
b Error
e
    OK a
a ByteString
left -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
left ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"parsed with leftovers: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
left)
      case Parser Error a -> ByteString -> Result Error a
forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
forall a. DotParse a => Parser Error a
dotParse (DotConfig -> a -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg a
a) :: Result Error a of
        Err Error
e -> ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"round trip error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Error -> ByteString
prettyError (DotConfig -> a -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg a
a) Error
e
        Result Error a
Fail -> ByteString -> IO ()
B.putStrLn ByteString
"uncaught round trip parse error"
        OK a
_ ByteString
left' -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
left' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"round trip parse with left overs" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
left)
    Result Error a
Fail -> ByteString -> IO ()
B.putStrLn ByteString
"uncaught parse error"

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

-- | Representation of a full graphviz graph, as per the dot language specification
data Graph = Graph
  { Graph -> Last Strict
strict :: Last Strict,
    Graph -> Last Directed
directed :: Last Directed,
    Graph -> Last ID
graphid :: Last ID,
    Graph -> Map ID ID
nodeAttributes :: Map.Map ID ID,
    Graph -> Map ID ID
graphAttributes :: Map.Map ID ID,
    Graph -> Map ID ID
edgeAttributes :: Map.Map ID ID,
    Graph -> Map ID ID
globalAttributes :: Map.Map ID ID,
    Graph -> [NodeStatement]
nodes :: [NodeStatement],
    Graph -> [EdgeStatement]
edges :: [EdgeStatement],
    Graph -> [SubGraphStatement]
subgraphs :: [SubGraphStatement]
  }
  deriving (Graph -> Graph -> Bool
(Graph -> Graph -> Bool) -> (Graph -> Graph -> Bool) -> Eq Graph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Graph -> Graph -> Bool
$c/= :: Graph -> Graph -> Bool
== :: Graph -> Graph -> Bool
$c== :: Graph -> Graph -> Bool
Eq, Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Int -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Graph] -> ShowS
$cshowList :: [Graph] -> ShowS
show :: Graph -> String
$cshow :: Graph -> String
showsPrec :: Int -> Graph -> ShowS
$cshowsPrec :: Int -> Graph -> ShowS
Show, (forall x. Graph -> Rep Graph x)
-> (forall x. Rep Graph x -> Graph) -> Generic Graph
forall x. Rep Graph x -> Graph
forall x. Graph -> Rep Graph x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 Last Strict -> Last Strict -> Last Strict
forall a. Semigroup a => a -> a -> a
<> Last Strict
m') (Last Directed
d Last Directed -> Last Directed -> Last Directed
forall a. Semigroup a => a -> a -> a
<> Last Directed
d') (Last ID
i Last ID -> Last ID -> Last ID
forall a. Semigroup a => a -> a -> a
<> Last ID
i') (Map ID ID
na Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
na') (Map ID ID
ga Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
ga') (Map ID ID
ea Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
ea') (Map ID ID
gs Map ID ID -> Map ID ID -> Map ID ID
forall a. Semigroup a => a -> a -> a
<> Map ID ID
gs') ([NodeStatement]
ns [NodeStatement] -> [NodeStatement] -> [NodeStatement]
forall a. Semigroup a => a -> a -> a
<> [NodeStatement]
ns') ([EdgeStatement]
es [EdgeStatement] -> [EdgeStatement] -> [EdgeStatement]
forall a. Semigroup a => a -> a -> a
<> [EdgeStatement]
es') ([SubGraphStatement]
ss [SubGraphStatement] -> [SubGraphStatement] -> [SubGraphStatement]
forall a. Semigroup a => a -> a -> a
<> [SubGraphStatement]
ss')

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

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

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

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

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

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

-- * Dot Grammar

-- | MergeEdges (strict)
data Strict = MergeEdges | NoMergeEdges deriving (Strict -> Strict -> Bool
(Strict -> Strict -> Bool)
-> (Strict -> Strict -> Bool) -> Eq Strict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Strict -> Strict -> Bool
$c/= :: Strict -> Strict -> Bool
== :: Strict -> Strict -> Bool
$c== :: Strict -> Strict -> Bool
Eq, Int -> Strict -> ShowS
[Strict] -> ShowS
Strict -> String
(Int -> Strict -> ShowS)
-> (Strict -> String) -> ([Strict] -> ShowS) -> Show Strict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Strict] -> ShowS
$cshowList :: [Strict] -> ShowS
show :: Strict -> String
$cshow :: Strict -> String
showsPrec :: Int -> Strict -> ShowS
$cshowsPrec :: Int -> Strict -> ShowS
Show, (forall x. Strict -> Rep Strict x)
-> (forall x. Rep Strict x -> Strict) -> Generic Strict
forall x. Rep Strict x -> Strict
forall x. Strict -> Rep Strict x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 = Parser Error Strict -> Parser Error Strict
forall e a. Parser e a -> Parser e a
token (Parser Error Strict -> Parser Error Strict)
-> Parser Error Strict -> Parser Error Strict
forall a b. (a -> b) -> a -> b
$ Parser Error ()
-> (() -> Parser Error Strict)
-> Parser Error Strict
-> Parser Error Strict
forall e a b.
Parser e a -> (a -> Parser e b) -> Parser e b -> Parser e b
optioned $(keyword "strict") (Parser Error Strict -> () -> Parser Error Strict
forall a b. a -> b -> a
const (Parser Error Strict -> () -> Parser Error Strict)
-> Parser Error Strict -> () -> Parser Error Strict
forall a b. (a -> b) -> a -> b
$ Strict -> Parser Error Strict
forall (f :: * -> *) a. Applicative f => a -> f a
pure Strict
MergeEdges) (Strict -> Parser Error Strict
forall (f :: * -> *) a. Applicative f => a -> f a
pure Strict
NoMergeEdges)

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

-- | Directed (digraph | graph)
data Directed = Directed | UnDirected deriving (Directed -> Directed -> Bool
(Directed -> Directed -> Bool)
-> (Directed -> Directed -> Bool) -> Eq Directed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Directed -> Directed -> Bool
$c/= :: Directed -> Directed -> Bool
== :: Directed -> Directed -> Bool
$c== :: Directed -> Directed -> Bool
Eq, Int -> Directed -> ShowS
[Directed] -> ShowS
Directed -> String
(Int -> Directed -> ShowS)
-> (Directed -> String) -> ([Directed] -> ShowS) -> Show Directed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Directed] -> ShowS
$cshowList :: [Directed] -> ShowS
show :: Directed -> String
$cshow :: Directed -> String
showsPrec :: Int -> Directed -> ShowS
$cshowsPrec :: Int -> Directed -> ShowS
Show, (forall x. Directed -> Rep Directed x)
-> (forall x. Rep Directed x -> Directed) -> Generic Directed
forall x. Rep Directed x -> Directed
forall x. Directed -> Rep Directed x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 =
    Parser Error Directed -> Parser Error Directed
forall e a. Parser e a -> Parser e a
token (Parser Error Directed -> Parser Error Directed)
-> Parser Error Directed -> Parser Error Directed
forall a b. (a -> b) -> a -> b
$
      (Directed
Directed Directed -> Parser Error () -> Parser Error Directed
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "digraph"))
        Parser Error Directed
-> Parser Error Directed -> Parser Error Directed
forall e a. Parser e a -> Parser e a -> Parser e a
<|> (Directed
UnDirected Directed -> Parser Error () -> Parser Error Directed
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(keyword "graph"))

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

-- | A dot statement as per the dot language specification.
data Statement = StatementNode NodeStatement | StatementEdge EdgeStatement | StatementGlobalAttribute GlobalAttributeStatement | StatementAttribute AttributeStatement | StatementSubGraph SubGraphStatement deriving (Statement -> Statement -> Bool
(Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool) -> Eq Statement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c== :: Statement -> Statement -> Bool
Eq, Int -> Statement -> ShowS
[Statement] -> ShowS
Statement -> String
(Int -> Statement -> ShowS)
-> (Statement -> String)
-> ([Statement] -> ShowS)
-> Show Statement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> String
$cshow :: Statement -> String
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show, (forall x. Statement -> Rep Statement x)
-> (forall x. Rep Statement x -> Statement) -> Generic Statement
forall x. Rep Statement x -> Statement
forall x. Statement -> Rep Statement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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) = DotConfig -> NodeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg NodeStatement
x
  dotPrint DotConfig
cfg (StatementEdge EdgeStatement
x) = DotConfig -> EdgeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg EdgeStatement
x
  dotPrint DotConfig
cfg (StatementAttribute AttributeStatement
x) = DotConfig -> AttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg AttributeStatement
x
  dotPrint DotConfig
cfg (StatementGlobalAttribute GlobalAttributeStatement
x) = DotConfig -> GlobalAttributeStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg GlobalAttributeStatement
x
  dotPrint DotConfig
cfg (StatementSubGraph SubGraphStatement
x) = DotConfig -> SubGraphStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg SubGraphStatement
x

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

-- | Identifier as per the dot language specifications.
--
-- >>> runDotParser "0" :: ID
-- IDInt 0
--
-- >>> runDotParser "-.123" :: ID
-- IDDouble (-0.123)
--
-- >>> runParser dotParse "apple_1'" :: Result Error ID
-- OK (ID "apple_1") "'"
--
-- >>> :set -XQuasiQuotes
-- >>> runParser dotParse "\"hello\"" :: Result Error ID
-- OK (IDQuoted "hello") ""
--
-- >>> runDotParser "<The <font color='red'><b>foo</b></font>,<br/> the <font point-size='20'>bar</font> and<br/> the <i>baz</i>>" :: ID
-- IDHtml "<The <font color='red'><b>foo</b></font>,<br/> the <font point-size='20'>bar</font> and<br/> the <i>baz</i>>"
data ID = ID ByteString | IDInt Int | IDDouble Double | IDQuoted ByteString | IDHtml ByteString deriving (ID -> ID -> Bool
(ID -> ID -> Bool) -> (ID -> ID -> Bool) -> Eq ID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ID -> ID -> Bool
$c/= :: ID -> ID -> Bool
== :: ID -> ID -> Bool
$c== :: ID -> ID -> Bool
Eq, Int -> ID -> ShowS
[ID] -> ShowS
ID -> String
(Int -> ID -> ShowS)
-> (ID -> String) -> ([ID] -> ShowS) -> Show ID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ID] -> ShowS
$cshowList :: [ID] -> ShowS
show :: ID -> String
$cshow :: ID -> String
showsPrec :: Int -> ID -> ShowS
$cshowsPrec :: Int -> ID -> ShowS
Show, (forall x. ID -> Rep ID x)
-> (forall x. Rep ID x -> ID) -> Generic ID
forall x. Rep ID x -> ID
forall x. ID -> Rep ID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ID x -> ID
$cfrom :: forall x. ID -> Rep ID x
Generic, Eq ID
Eq ID
-> (ID -> ID -> Ordering)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> ID)
-> (ID -> ID -> ID)
-> Ord ID
ID -> ID -> Bool
ID -> ID -> Ordering
ID -> ID -> ID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq ID
Ord)

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

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

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

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

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

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

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

-- | Compass instructions which are optionally associated with an identifier
data Compass = CompassN | CompassNE | CompassE | CompassSE | CompassS | CompassSW | CompassW | CompassNW | CompassC | Compass_ deriving (Compass -> Compass -> Bool
(Compass -> Compass -> Bool)
-> (Compass -> Compass -> Bool) -> Eq Compass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Compass -> Compass -> Bool
$c/= :: Compass -> Compass -> Bool
== :: Compass -> Compass -> Bool
$c== :: Compass -> Compass -> Bool
Eq, Int -> Compass -> ShowS
[Compass] -> ShowS
Compass -> String
(Int -> Compass -> ShowS)
-> (Compass -> String) -> ([Compass] -> ShowS) -> Show Compass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Compass] -> ShowS
$cshowList :: [Compass] -> ShowS
show :: Compass -> String
$cshow :: Compass -> String
showsPrec :: Int -> Compass -> ShowS
$cshowsPrec :: Int -> Compass -> ShowS
Show, (forall x. Compass -> Rep Compass x)
-> (forall x. Rep Compass x -> Compass) -> Generic Compass
forall x. Rep Compass x -> Compass
forall x. Compass -> Rep Compass x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 =
    Parser Error Compass -> Parser Error Compass
forall e a. Parser e a -> Parser e a
token
      $( switch
           [|
             case _ of
               "n" -> pure CompassN
               "ne" -> pure CompassNE
               "e" -> pure CompassE
               "se" -> pure CompassSE
               "s" -> pure CompassS
               "sw" -> pure CompassSW
               "w" -> pure CompassW
               "nw" -> pure CompassNW
               "c" -> pure CompassC
               "_" -> pure Compass_
             |]
       )

-- | Port instructions which are optionally associated with an identifier
newtype Port = Port {Port -> These ID Compass
portID :: These ID Compass} deriving (Port -> Port -> Bool
(Port -> Port -> Bool) -> (Port -> Port -> Bool) -> Eq Port
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c== :: Port -> Port -> Bool
Eq, Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show, (forall x. Port -> Rep Port x)
-> (forall x. Rep Port x -> Port) -> Generic Port
forall x. Rep Port x -> Port
forall x. Port -> Rep Port x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i
  dotPrint DotConfig
cfg (Port (That Compass
c)) = ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> Compass -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Compass
c
  dotPrint DotConfig
cfg (Port (These ID
i Compass
c)) = ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" : " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> Compass -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Compass
c

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

-- | A top-level attribute
--
-- >>> runDotParser "rankdir=\"BT\"" :: Statement
-- StatementGlobalAttribute (GlobalAttributeStatement {globalAttributeStatement = (ID "rankdir",IDQuoted "BT")})
newtype GlobalAttributeStatement = GlobalAttributeStatement {GlobalAttributeStatement -> (ID, ID)
globalAttributeStatement :: (ID, ID)} deriving (GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
(GlobalAttributeStatement -> GlobalAttributeStatement -> Bool)
-> (GlobalAttributeStatement -> GlobalAttributeStatement -> Bool)
-> Eq GlobalAttributeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
$c/= :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
== :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
$c== :: GlobalAttributeStatement -> GlobalAttributeStatement -> Bool
Eq, Int -> GlobalAttributeStatement -> ShowS
[GlobalAttributeStatement] -> ShowS
GlobalAttributeStatement -> String
(Int -> GlobalAttributeStatement -> ShowS)
-> (GlobalAttributeStatement -> String)
-> ([GlobalAttributeStatement] -> ShowS)
-> Show GlobalAttributeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobalAttributeStatement] -> ShowS
$cshowList :: [GlobalAttributeStatement] -> ShowS
show :: GlobalAttributeStatement -> String
$cshow :: GlobalAttributeStatement -> String
showsPrec :: Int -> GlobalAttributeStatement -> ShowS
$cshowsPrec :: Int -> GlobalAttributeStatement -> ShowS
Show, (forall x.
 GlobalAttributeStatement -> Rep GlobalAttributeStatement x)
-> (forall x.
    Rep GlobalAttributeStatement x -> GlobalAttributeStatement)
-> Generic GlobalAttributeStatement
forall x.
Rep GlobalAttributeStatement x -> GlobalAttributeStatement
forall x.
GlobalAttributeStatement -> Rep GlobalAttributeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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) = DotConfig -> (ID, ID) -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (ID, ID)
s
  dotParse :: Parser Error GlobalAttributeStatement
dotParse = (ID, ID) -> GlobalAttributeStatement
GlobalAttributeStatement ((ID, ID) -> GlobalAttributeStatement)
-> Parser Error (ID, ID) -> Parser Error GlobalAttributeStatement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error (ID, ID)
forall a. DotParse a => Parser Error a
dotParse

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

-- | Top-level attribute statement
--
-- >>> runDotParser "graph [overlap=false, splines=spline, size=\"1!\"];" :: Statement
-- StatementAttribute (AttributeStatement {attributeType = GraphType, attributes = fromList [(ID "overlap",ID "false"),(ID "size",IDQuoted "1!"),(ID "splines",ID "spline")]})
data AttributeStatement = AttributeStatement {AttributeStatement -> AttributeType
attributeType :: AttributeType, AttributeStatement -> Map ID ID
attributes :: Map.Map ID ID} deriving (AttributeStatement -> AttributeStatement -> Bool
(AttributeStatement -> AttributeStatement -> Bool)
-> (AttributeStatement -> AttributeStatement -> Bool)
-> Eq AttributeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeStatement -> AttributeStatement -> Bool
$c/= :: AttributeStatement -> AttributeStatement -> Bool
== :: AttributeStatement -> AttributeStatement -> Bool
$c== :: AttributeStatement -> AttributeStatement -> Bool
Eq, Int -> AttributeStatement -> ShowS
[AttributeStatement] -> ShowS
AttributeStatement -> String
(Int -> AttributeStatement -> ShowS)
-> (AttributeStatement -> String)
-> ([AttributeStatement] -> ShowS)
-> Show AttributeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeStatement] -> ShowS
$cshowList :: [AttributeStatement] -> ShowS
show :: AttributeStatement -> String
$cshow :: AttributeStatement -> String
showsPrec :: Int -> AttributeStatement -> ShowS
$cshowsPrec :: Int -> AttributeStatement -> ShowS
Show, (forall x. AttributeStatement -> Rep AttributeStatement x)
-> (forall x. Rep AttributeStatement x -> AttributeStatement)
-> Generic AttributeStatement
forall x. Rep AttributeStatement x -> AttributeStatement
forall x. AttributeStatement -> Rep AttributeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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) =
    ByteString -> [ByteString] -> ByteString
intercalate
      ByteString
" "
      [DotConfig -> AttributeType -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg AttributeType
t, DotConfig -> Map ID ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]

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

-- | Node statement
--
-- >>> runDotParser "A [shape=diamond; color=blue]" :: Statement
-- StatementNode (NodeStatement {nodeID = ID "A", port = Nothing, nodeAttrs = fromList [(ID "color",ID "blue"),(ID "shape",ID "diamond")]})
data NodeStatement = NodeStatement {NodeStatement -> ID
nodeID :: ID, NodeStatement -> Maybe Port
port :: Maybe Port, NodeStatement -> Map ID ID
nodeAttrs :: Map.Map ID ID} deriving (NodeStatement -> NodeStatement -> Bool
(NodeStatement -> NodeStatement -> Bool)
-> (NodeStatement -> NodeStatement -> Bool) -> Eq NodeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeStatement -> NodeStatement -> Bool
$c/= :: NodeStatement -> NodeStatement -> Bool
== :: NodeStatement -> NodeStatement -> Bool
$c== :: NodeStatement -> NodeStatement -> Bool
Eq, Int -> NodeStatement -> ShowS
[NodeStatement] -> ShowS
NodeStatement -> String
(Int -> NodeStatement -> ShowS)
-> (NodeStatement -> String)
-> ([NodeStatement] -> ShowS)
-> Show NodeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeStatement] -> ShowS
$cshowList :: [NodeStatement] -> ShowS
show :: NodeStatement -> String
$cshow :: NodeStatement -> String
showsPrec :: Int -> NodeStatement -> ShowS
$cshowsPrec :: Int -> NodeStatement -> ShowS
Show, (forall x. NodeStatement -> Rep NodeStatement x)
-> (forall x. Rep NodeStatement x -> NodeStatement)
-> Generic NodeStatement
forall x. Rep NodeStatement x -> NodeStatement
forall x. NodeStatement -> Rep NodeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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
" " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      [DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
i]
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> Port -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (Port -> ByteString) -> [Port] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Port -> [Port]
forall a. Maybe a -> [a]
maybeToList Maybe Port
p)
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [DotConfig -> Map ID ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]

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

-- | An edge can be specified in as a NodeID or as a SubGraph
data EdgeID
  = EdgeID ID (Maybe Port)
  | EdgeSubGraph SubGraphStatement
  deriving (EdgeID -> EdgeID -> Bool
(EdgeID -> EdgeID -> Bool)
-> (EdgeID -> EdgeID -> Bool) -> Eq EdgeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeID -> EdgeID -> Bool
$c/= :: EdgeID -> EdgeID -> Bool
== :: EdgeID -> EdgeID -> Bool
$c== :: EdgeID -> EdgeID -> Bool
Eq, Int -> EdgeID -> ShowS
[EdgeID] -> ShowS
EdgeID -> String
(Int -> EdgeID -> ShowS)
-> (EdgeID -> String) -> ([EdgeID] -> ShowS) -> Show EdgeID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeID] -> ShowS
$cshowList :: [EdgeID] -> ShowS
show :: EdgeID -> String
$cshow :: EdgeID -> String
showsPrec :: Int -> EdgeID -> ShowS
$cshowsPrec :: Int -> EdgeID -> ShowS
Show, (forall x. EdgeID -> Rep EdgeID x)
-> (forall x. Rep EdgeID x -> EdgeID) -> Generic EdgeID
forall x. Rep EdgeID x -> EdgeID
forall x. EdgeID -> Rep EdgeID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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) =
    [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
e] [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (DotConfig -> Port -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (Port -> ByteString) -> [Port] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Port -> [Port]
forall a. Maybe a -> [a]
maybeToList Maybe Port
p)
  dotPrint DotConfig
cfg (EdgeSubGraph SubGraphStatement
s) = DotConfig -> SubGraphStatement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg SubGraphStatement
s

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

-- | An edgeop is -> in directed graphs and -- in undirected graphs.
data EdgeOp = EdgeDirected | EdgeUndirected deriving (EdgeOp -> EdgeOp -> Bool
(EdgeOp -> EdgeOp -> Bool)
-> (EdgeOp -> EdgeOp -> Bool) -> Eq EdgeOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeOp -> EdgeOp -> Bool
$c/= :: EdgeOp -> EdgeOp -> Bool
== :: EdgeOp -> EdgeOp -> Bool
$c== :: EdgeOp -> EdgeOp -> Bool
Eq, Int -> EdgeOp -> ShowS
[EdgeOp] -> ShowS
EdgeOp -> String
(Int -> EdgeOp -> ShowS)
-> (EdgeOp -> String) -> ([EdgeOp] -> ShowS) -> Show EdgeOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeOp] -> ShowS
$cshowList :: [EdgeOp] -> ShowS
show :: EdgeOp -> String
$cshow :: EdgeOp -> String
showsPrec :: Int -> EdgeOp -> ShowS
$cshowsPrec :: Int -> EdgeOp -> ShowS
Show, (forall x. EdgeOp -> Rep EdgeOp x)
-> (forall x. Rep EdgeOp x -> EdgeOp) -> Generic EdgeOp
forall x. Rep EdgeOp x -> EdgeOp
forall x. EdgeOp -> Rep EdgeOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 =
    Parser Error EdgeOp -> Parser Error EdgeOp
forall e a. Parser e a -> Parser e a
token
      $( switch
           [|
             case _ of
               "->" -> pure EdgeDirected
               "--" -> pure EdgeUndirected
             |]
       )

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

-- | Edge statement
--
-- >>> runDotParser "A -> B [style=dashed, color=grey]" :: Statement
-- StatementEdge (EdgeStatement {edgeOp = EdgeDirected, leftEdge = EdgeID (ID "A") Nothing, rightEdges = EdgeID (ID "B") Nothing :| [], edgeAttrs = fromList [(ID "color",ID "grey"),(ID "style",ID "dashed")]})
data EdgeStatement = EdgeStatement {EdgeStatement -> EdgeOp
edgeOp :: EdgeOp, EdgeStatement -> EdgeID
leftEdge :: EdgeID, EdgeStatement -> NonEmpty EdgeID
rightEdges :: NonEmpty EdgeID, EdgeStatement -> Map ID ID
edgeAttrs :: Map.Map ID ID} deriving (EdgeStatement -> EdgeStatement -> Bool
(EdgeStatement -> EdgeStatement -> Bool)
-> (EdgeStatement -> EdgeStatement -> Bool) -> Eq EdgeStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeStatement -> EdgeStatement -> Bool
$c/= :: EdgeStatement -> EdgeStatement -> Bool
== :: EdgeStatement -> EdgeStatement -> Bool
$c== :: EdgeStatement -> EdgeStatement -> Bool
Eq, Int -> EdgeStatement -> ShowS
[EdgeStatement] -> ShowS
EdgeStatement -> String
(Int -> EdgeStatement -> ShowS)
-> (EdgeStatement -> String)
-> ([EdgeStatement] -> ShowS)
-> Show EdgeStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeStatement] -> ShowS
$cshowList :: [EdgeStatement] -> ShowS
show :: EdgeStatement -> String
$cshow :: EdgeStatement -> String
showsPrec :: Int -> EdgeStatement -> ShowS
$cshowsPrec :: Int -> EdgeStatement -> ShowS
Show, (forall x. EdgeStatement -> Rep EdgeStatement x)
-> (forall x. Rep EdgeStatement x -> EdgeStatement)
-> Generic EdgeStatement
forall x. Rep EdgeStatement x -> EdgeStatement
forall x. EdgeStatement -> Rep EdgeStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DotConfig -> EdgeOp -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg EdgeOp
l ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" ") (DotConfig -> EdgeID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (EdgeID -> ByteString) -> [EdgeID] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EdgeID
rs EdgeID -> [EdgeID] -> [EdgeID]
forall a. a -> [a] -> [a]
: NonEmpty EdgeID -> [EdgeID]
forall a. NonEmpty a -> [a]
toList NonEmpty EdgeID
xs))]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [DotConfig -> Map ID ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg Map ID ID
as]
      )

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

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

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

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

-- | A subgraph statement.
--
-- Note: each subgraph must have a unique name
--
-- >>> runDotParser "subgraph A {A, B, C}" :: Statement
-- StatementSubGraph (SubGraphStatement {subgraphID = Just (ID "A"), subgraphStatements = [StatementNode (NodeStatement {nodeID = ID "A", port = Nothing, nodeAttrs = fromList []}),StatementNode (NodeStatement {nodeID = ID "B", port = Nothing, nodeAttrs = fromList []}),StatementNode (NodeStatement {nodeID = ID "C", port = Nothing, nodeAttrs = fromList []})]})
data SubGraphStatement = SubGraphStatement {SubGraphStatement -> Maybe ID
subgraphID :: Maybe ID, SubGraphStatement -> [Statement]
subgraphStatements :: [Statement]} deriving (SubGraphStatement -> SubGraphStatement -> Bool
(SubGraphStatement -> SubGraphStatement -> Bool)
-> (SubGraphStatement -> SubGraphStatement -> Bool)
-> Eq SubGraphStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubGraphStatement -> SubGraphStatement -> Bool
$c/= :: SubGraphStatement -> SubGraphStatement -> Bool
== :: SubGraphStatement -> SubGraphStatement -> Bool
$c== :: SubGraphStatement -> SubGraphStatement -> Bool
Eq, Int -> SubGraphStatement -> ShowS
[SubGraphStatement] -> ShowS
SubGraphStatement -> String
(Int -> SubGraphStatement -> ShowS)
-> (SubGraphStatement -> String)
-> ([SubGraphStatement] -> ShowS)
-> Show SubGraphStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubGraphStatement] -> ShowS
$cshowList :: [SubGraphStatement] -> ShowS
show :: SubGraphStatement -> String
$cshow :: SubGraphStatement -> String
showsPrec :: Int -> SubGraphStatement -> ShowS
$cshowsPrec :: Int -> SubGraphStatement -> ShowS
Show, (forall x. SubGraphStatement -> Rep SubGraphStatement x)
-> (forall x. Rep SubGraphStatement x -> SubGraphStatement)
-> Generic SubGraphStatement
forall x. Rep SubGraphStatement x -> SubGraphStatement
forall x. SubGraphStatement -> Rep SubGraphStatement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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
" " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      [ByteString] -> (ID -> [ByteString]) -> Maybe ID -> [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        []
        (\ID
x' -> [ByteString -> [ByteString] -> ByteString
intercalate ByteString
" " [ByteString
"subgraph", DotConfig -> ID -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg ID
x']])
        Maybe ID
x
        [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: []) (ByteString -> ByteString
wrapCurlyPrint (ByteString -> [ByteString] -> ByteString
intercalate (DotConfig
cfg DotConfig -> Optic' A_Lens NoIx DotConfig ByteString -> ByteString
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "subGraphSep" (Optic' A_Lens NoIx DotConfig ByteString)
Optic' A_Lens NoIx DotConfig ByteString
#subGraphSep) ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ DotConfig -> Statement -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
dotPrint DotConfig
cfg (Statement -> ByteString) -> [Statement] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Statement]
xs))

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

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

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

-- | default dot graph as a ByteString
defaultBS :: ByteString
defaultBS :: ByteString
defaultBS =
  Text -> ByteString
encodeUtf8
    [trimming|
digraph {
    node [shape=circle
         ,height=0.5];
    graph [overlap=false
          ,splines=spline
          ,size="1!"];
    edge [arrowsize=0];
  }
|]

-- | A default dot graph
--
-- >>> import qualified Data.ByteString.Char8 as B
-- >>> B.putStrLn $ dotPrint defaultDotConfig defaultGraph
-- digraph {
--     node [height=0.5;shape=circle]
--     graph [overlap=false;size="1!";splines=spline]
--     edge [arrowsize=0]
--     }
defaultGraph :: Graph
defaultGraph :: Graph
defaultGraph = ByteString -> Graph
forall a. DotParse a => ByteString -> a
runDotParser ByteString
defaultBS

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

--

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

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

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

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

-- | typical node information after processing a dot bytestring.
data NodeInfo = NodeInfo {NodeInfo -> ID
nlabel :: ID, NodeInfo -> Double
nwidth :: Double, NodeInfo -> Point Double
pos :: Point Double} deriving (NodeInfo -> NodeInfo -> Bool
(NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool) -> Eq NodeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeInfo -> NodeInfo -> Bool
$c/= :: NodeInfo -> NodeInfo -> Bool
== :: NodeInfo -> NodeInfo -> Bool
$c== :: NodeInfo -> NodeInfo -> Bool
Eq, Int -> NodeInfo -> ShowS
[NodeInfo] -> ShowS
NodeInfo -> String
(Int -> NodeInfo -> ShowS)
-> (NodeInfo -> String) -> ([NodeInfo] -> ShowS) -> Show NodeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeInfo] -> ShowS
$cshowList :: [NodeInfo] -> ShowS
show :: NodeInfo -> String
$cshow :: NodeInfo -> String
showsPrec :: Int -> NodeInfo -> ShowS
$cshowsPrec :: Int -> NodeInfo -> ShowS
Show, (forall x. NodeInfo -> Rep NodeInfo x)
-> (forall x. Rep NodeInfo x -> NodeInfo) -> Generic NodeInfo
forall x. Rep NodeInfo x -> NodeInfo
forall x. NodeInfo -> Rep NodeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
w (Maybe (Maybe Double) -> Maybe Double
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Double)
w')) Point Double
p | (ID
x, (Just Point Double
p, Maybe (Maybe Double)
w')) <- [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
xs]
  where
    xs :: [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
xs =
      Map ID (Maybe (Point Double), Maybe (Maybe Double))
-> [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ID (Maybe (Point Double), Maybe (Maybe Double))
 -> [(ID, (Maybe (Point Double), Maybe (Maybe Double)))])
-> Map ID (Maybe (Point Double), Maybe (Maybe Double))
-> [(ID, (Maybe (Point Double), Maybe (Maybe Double)))]
forall a b. (a -> b) -> a -> b
$
        SimpleWhenMissing
  ID
  (Maybe (Point Double))
  (Maybe (Point Double), Maybe (Maybe Double))
-> SimpleWhenMissing
     ID (Maybe Double) (Maybe (Point Double), Maybe (Maybe Double))
-> SimpleWhenMatched
     ID
     (Maybe (Point Double))
     (Maybe Double)
     (Maybe (Point Double), Maybe (Maybe Double))
-> Map ID (Maybe (Point Double))
-> Map ID (Maybe Double)
-> Map ID (Maybe (Point Double), Maybe (Maybe Double))
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge
          ((ID
 -> Maybe (Point Double)
 -> (Maybe (Point Double), Maybe (Maybe Double)))
-> SimpleWhenMissing
     ID
     (Maybe (Point Double))
     (Maybe (Point Double), Maybe (Maybe Double))
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\ID
_ Maybe (Point Double)
v -> (Maybe (Point Double)
v, Maybe (Maybe Double)
forall a. Maybe a
Nothing)))
          SimpleWhenMissing
  ID (Maybe Double) (Maybe (Point Double), Maybe (Maybe Double))
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
dropMissing
          ((ID
 -> Maybe (Point Double)
 -> Maybe Double
 -> (Maybe (Point Double), Maybe (Maybe Double)))
-> SimpleWhenMatched
     ID
     (Maybe (Point Double))
     (Maybe Double)
     (Maybe (Point Double), Maybe (Maybe Double))
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
zipWithMatched (\ID
_ Maybe (Point Double)
x Maybe Double
y -> (Maybe (Point Double)
x, Maybe Double -> Maybe (Maybe Double)
forall a. a -> Maybe a
Just Maybe Double
y)))
          (Graph -> Map ID (Maybe (Point Double))
nodePos Graph
g)
          (Graph -> Map ID (Maybe Double)
nodeWidth Graph
g)

-- | typical edge information after processing a dot bytestring.
data EdgeInfo = EdgeInfo {EdgeInfo -> (ID, ID)
elabel :: (ID, ID), EdgeInfo -> Double
ewidth :: Double, EdgeInfo -> [PathData Double]
curve :: [PathData Double]} deriving (EdgeInfo -> EdgeInfo -> Bool
(EdgeInfo -> EdgeInfo -> Bool)
-> (EdgeInfo -> EdgeInfo -> Bool) -> Eq EdgeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeInfo -> EdgeInfo -> Bool
$c/= :: EdgeInfo -> EdgeInfo -> Bool
== :: EdgeInfo -> EdgeInfo -> Bool
$c== :: EdgeInfo -> EdgeInfo -> Bool
Eq, Int -> EdgeInfo -> ShowS
[EdgeInfo] -> ShowS
EdgeInfo -> String
(Int -> EdgeInfo -> ShowS)
-> (EdgeInfo -> String) -> ([EdgeInfo] -> ShowS) -> Show EdgeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeInfo] -> ShowS
$cshowList :: [EdgeInfo] -> ShowS
show :: EdgeInfo -> String
$cshow :: EdgeInfo -> String
showsPrec :: Int -> EdgeInfo -> ShowS
$cshowsPrec :: Int -> EdgeInfo -> ShowS
Show, (forall x. EdgeInfo -> Rep EdgeInfo x)
-> (forall x. Rep EdgeInfo x -> EdgeInfo) -> Generic EdgeInfo
forall x. Rep EdgeInfo x -> EdgeInfo
forall x. EdgeInfo -> Rep EdgeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
w (Maybe (Maybe Double) -> Maybe Double
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Double)
w')) (Spline -> [PathData Double]
splinePath Spline
p) | ((ID
x, ID
y), (Just Spline
p, Maybe (Maybe Double)
w')) <- [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
xs]
  where
    xs :: [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
xs =
      Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
-> [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
 -> [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))])
-> Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
-> [((ID, ID), (Maybe Spline, Maybe (Maybe Double)))]
forall a b. (a -> b) -> a -> b
$
        SimpleWhenMissing
  (ID, ID) (Maybe Spline) (Maybe Spline, Maybe (Maybe Double))
-> SimpleWhenMissing
     (ID, ID) (Maybe Double) (Maybe Spline, Maybe (Maybe Double))
-> SimpleWhenMatched
     (ID, ID)
     (Maybe Spline)
     (Maybe Double)
     (Maybe Spline, Maybe (Maybe Double))
-> Map (ID, ID) (Maybe Spline)
-> Map (ID, ID) (Maybe Double)
-> Map (ID, ID) (Maybe Spline, Maybe (Maybe Double))
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge
          (((ID, ID) -> Maybe Spline -> (Maybe Spline, Maybe (Maybe Double)))
-> SimpleWhenMissing
     (ID, ID) (Maybe Spline) (Maybe Spline, Maybe (Maybe Double))
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\(ID, ID)
_ Maybe Spline
v -> (Maybe Spline
v, Maybe (Maybe Double)
forall a. Maybe a
Nothing)))
          SimpleWhenMissing
  (ID, ID) (Maybe Double) (Maybe Spline, Maybe (Maybe Double))
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
dropMissing
          (((ID, ID)
 -> Maybe Spline
 -> Maybe Double
 -> (Maybe Spline, Maybe (Maybe Double)))
-> SimpleWhenMatched
     (ID, ID)
     (Maybe Spline)
     (Maybe Double)
     (Maybe Spline, Maybe (Maybe Double))
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
zipWithMatched (\(ID, ID)
_ Maybe Spline
x Maybe Double
y -> (Maybe Spline
x, Maybe Double -> Maybe (Maybe Double)
forall a. a -> Maybe a
Just Maybe Double
y)))
          (Graph -> Map (ID, ID) (Maybe Spline)
edgeSpline Graph
g)
          (Graph -> Map (ID, ID) (Maybe Double)
edgeWidth Graph
g)

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

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

-- | Various configutaion parameters for the chart-svg Chart
data ChartConfig = ChartConfig
  { ChartConfig -> Double
chartHeight :: Double,
    ChartConfig -> Double
chartScale :: Double,
    ChartConfig -> Double
edgeSize :: Double,
    ChartConfig -> Colour
chartColor :: Colour,
    ChartConfig -> Colour
chartBackgroundColor :: Colour,
    ChartConfig -> Double
nodeHeight :: Double,
    ChartConfig -> Double
nodeSize :: Double,
    ChartConfig -> Double
vshift :: Double,
    ChartConfig -> Double
textSize :: Double,
    ChartConfig -> ID -> Text
labelf :: ID -> Text
  }
  deriving ((forall x. ChartConfig -> Rep ChartConfig x)
-> (forall x. Rep ChartConfig x -> ChartConfig)
-> Generic ChartConfig
forall x. Rep ChartConfig x -> ChartConfig
forall x. ChartConfig -> Rep ChartConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChartConfig x -> ChartConfig
$cfrom :: forall x. ChartConfig -> Rep ChartConfig x
Generic)

-- | default parameters
defaultChartConfig :: ChartConfig
defaultChartConfig :: ChartConfig
defaultChartConfig = Double
-> Double
-> Double
-> Colour
-> Colour
-> Double
-> Double
-> Double
-> Double
-> (ID -> Text)
-> ChartConfig
ChartConfig Double
500 Double
72 Double
0.5 (Optic A_Lens NoIx Colour Colour Double Double
-> (Double -> Double) -> Colour -> Colour
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Lens NoIx Colour Colour Double Double
lightness' (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.5) (Int -> Colour
palette1 Int
0)) (Optic A_Lens NoIx Colour Colour Double Double
-> Double -> Colour -> Colour
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Colour Colour Double Double
opac' Double
0.2 (Int -> Colour
palette1 Int
0)) Double
0.5 Double
0.5 (-Double
3.7) Double
14 (String -> Text
Text.pack (String -> Text) -> (ID -> String) -> ID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label)

-- | convert a 'Graph' processed via the graphviz commands to a 'ChartSvg'
--
-- >>> import Chart
-- >>> import DotParse.Examples (exInt)
-- >>> ex <- processGraph exInt
-- >>> writeChartSvg "other/ex.svg" (graphToChartWith defaultChartConfig ex)
--
-- ![Example](other/ex.svg)
graphToChartWith :: ChartConfig -> Graph -> ChartSvg
graphToChartWith :: ChartConfig -> Graph -> ChartSvg
graphToChartWith ChartConfig
cfg Graph
g =
  ChartSvg
forall a. Monoid a => a
mempty
    ChartSvg -> (ChartSvg -> ChartSvg) -> ChartSvg
forall a b. a -> (a -> b) -> b
& IsLabel
  "charts" (Optic A_Lens NoIx ChartSvg ChartSvg ChartTree ChartTree)
Optic A_Lens NoIx ChartSvg ChartSvg ChartTree ChartTree
#charts Optic A_Lens NoIx ChartSvg ChartSvg ChartTree ChartTree
-> ChartTree -> ChartSvg -> ChartSvg
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Text -> [Chart] -> ChartTree
named Text
"edges" [Chart]
ps ChartTree -> ChartTree -> ChartTree
forall a. Semigroup a => a -> a -> a
<> Text -> [Chart] -> ChartTree
named Text
"shapes" [Chart]
c0 ChartTree -> ChartTree -> ChartTree
forall a. Semigroup a => a -> a -> a
<> Text -> [Chart] -> ChartTree
named Text
"labels" [Chart
ts]
    ChartSvg -> (ChartSvg -> ChartSvg) -> ChartSvg
forall a b. a -> (a -> b) -> b
& IsLabel
  "svgOptions"
  (Optic A_Lens NoIx ChartSvg ChartSvg SvgOptions SvgOptions)
Optic A_Lens NoIx ChartSvg ChartSvg SvgOptions SvgOptions
#svgOptions Optic A_Lens NoIx ChartSvg ChartSvg SvgOptions SvgOptions
-> Optic A_Lens NoIx SvgOptions SvgOptions Double Double
-> Optic A_Lens NoIx ChartSvg ChartSvg Double Double
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% IsLabel
  "svgHeight" (Optic A_Lens NoIx SvgOptions SvgOptions Double Double)
Optic A_Lens NoIx SvgOptions SvgOptions Double Double
#svgHeight Optic A_Lens NoIx ChartSvg ChartSvg Double Double
-> Double -> ChartSvg -> ChartSvg
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartHeight" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#chartHeight)
    ChartSvg -> (ChartSvg -> ChartSvg) -> ChartSvg
forall a b. a -> (a -> b) -> b
& IsLabel
  "hudOptions"
  (Optic A_Lens NoIx ChartSvg ChartSvg HudOptions HudOptions)
Optic A_Lens NoIx ChartSvg ChartSvg HudOptions HudOptions
#hudOptions Optic A_Lens NoIx ChartSvg ChartSvg HudOptions HudOptions
-> HudOptions -> ChartSvg -> ChartSvg
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (HudOptions
forall a. Monoid a => a
mempty HudOptions -> (HudOptions -> HudOptions) -> HudOptions
forall a b. a -> (a -> b) -> b
& IsLabel
  "chartAspect"
  (Optic A_Lens NoIx HudOptions HudOptions ChartAspect ChartAspect)
Optic A_Lens NoIx HudOptions HudOptions ChartAspect ChartAspect
#chartAspect Optic A_Lens NoIx HudOptions HudOptions ChartAspect ChartAspect
-> ChartAspect -> HudOptions -> HudOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ChartAspect
ChartAspect)
  where
    glyphs :: Double -> GlyphStyle
glyphs Double
w = case Lens' Graph (Maybe ID) -> Graph -> Maybe ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (AttributeType -> ID -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"shape")) Graph
g of
      Just (ID ByteString
"circle") -> GlyphStyle
defaultGlyphStyle GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "shape"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape)
Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape
#shape Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape
-> GlyphShape -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ GlyphShape
CircleGlyph GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "size" (Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double)
Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
#size Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
-> Double -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartScale" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#chartScale) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderSize"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double)
Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
#borderSize Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
-> Double -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "edgeSize" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#edgeSize) GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderColor"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour)
Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
#borderColor Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
-> Colour -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartColor) GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "color" (Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour)
Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
#color Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
-> Colour -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel
  "chartBackgroundColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartBackgroundColor)
      Just (ID ByteString
"box") -> GlyphStyle
defaultGlyphStyle GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "shape"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape)
Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape
#shape Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape
-> GlyphShape -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Double -> GlyphShape
RectSharpGlyph (Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
w) GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "size" (Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double)
Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
#size Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
-> Double -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Double
72 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderSize"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double)
Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
#borderSize Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
-> Double -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Double
1 GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderColor"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour)
Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
#borderColor Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
-> Colour -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartColor) GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "color" (Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour)
Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
#color Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
-> Colour -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel
  "chartBackgroundColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartBackgroundColor)
      -- defaults to circle
      Maybe ID
_ -> GlyphStyle
defaultGlyphStyle GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "shape"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape)
Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape
#shape Optic A_Lens NoIx GlyphStyle GlyphStyle GlyphShape GlyphShape
-> GlyphShape -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ GlyphShape
CircleGlyph GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "size" (Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double)
Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
#size Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
-> Double -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Double
72 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderSize"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double)
Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
#borderSize Optic A_Lens NoIx GlyphStyle GlyphStyle Double Double
-> Double -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Double
1 GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderColor"
  (Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour)
Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
#borderColor Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
-> Colour -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartColor) GlyphStyle -> (GlyphStyle -> GlyphStyle) -> GlyphStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "color" (Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour)
Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
#color Optic A_Lens NoIx GlyphStyle GlyphStyle Colour Colour
-> Colour -> GlyphStyle -> GlyphStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel
  "chartBackgroundColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartBackgroundColor)
    h :: Double
h = Double -> (ID -> Double) -> Maybe ID -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "nodeHeight" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#nodeHeight) (Parser Error Double -> ByteString -> Double
forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error Double
double (ByteString -> Double) -> (ID -> ByteString) -> ID -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
packUTF8 (String -> ByteString) -> (ID -> String) -> ID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID -> String
label) (Lens' Graph (Maybe ID) -> Graph -> Maybe ID
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (AttributeType -> ID -> Lens' Graph (Maybe ID)
attL AttributeType
NodeType (ByteString -> ID
ID ByteString
"height")) Graph
g)
    vshift' :: Double
vshift' = ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "vshift" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#vshift
    -- node information
    ns :: [NodeInfo]
ns = Graph -> Double -> [NodeInfo]
nodeInfo Graph
g (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "nodeSize" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#nodeSize)
    -- edge information
    es :: [EdgeInfo]
es = Graph -> Double -> [EdgeInfo]
edgeInfo Graph
g (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "edgeSize" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#edgeSize)
    -- paths
    ps :: [Chart]
ps = (EdgeInfo -> Chart) -> [EdgeInfo] -> [Chart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EdgeInfo (ID, ID)
_ Double
w [PathData Double]
p) -> PathStyle -> [PathData Double] -> Chart
PathChart (PathStyle
defaultPathStyle PathStyle -> (PathStyle -> PathStyle) -> PathStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderSize" (Optic A_Lens NoIx PathStyle PathStyle Double Double)
Optic A_Lens NoIx PathStyle PathStyle Double Double
#borderSize Optic A_Lens NoIx PathStyle PathStyle Double Double
-> Double -> PathStyle -> PathStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w) PathStyle -> (PathStyle -> PathStyle) -> PathStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "borderColor" (Optic A_Lens NoIx PathStyle PathStyle Colour Colour)
Optic A_Lens NoIx PathStyle PathStyle Colour Colour
#borderColor Optic A_Lens NoIx PathStyle PathStyle Colour Colour
-> Colour -> PathStyle -> PathStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartColor) PathStyle -> (PathStyle -> PathStyle) -> PathStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "color" (Optic A_Lens NoIx PathStyle PathStyle Colour Colour)
Optic A_Lens NoIx PathStyle PathStyle Colour Colour
#color Optic A_Lens NoIx PathStyle PathStyle Colour Colour
-> Colour -> PathStyle -> PathStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Colour
transparent) [PathData Double]
p) [EdgeInfo]
es
    -- circles
    c0 :: [Chart]
c0 = (NodeInfo -> Chart) -> [NodeInfo] -> [Chart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(NodeInfo ID
_ Double
w Point Double
p) -> GlyphStyle -> [Point Double] -> Chart
GlyphChart (Double -> GlyphStyle
glyphs Double
w) [Point Double
p]) [NodeInfo]
ns
    -- labels
    ts :: Chart
ts =
      TextStyle -> [(Text, Point Double)] -> Chart
TextChart (TextStyle
defaultTextStyle TextStyle -> (TextStyle -> TextStyle) -> TextStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "size" (Optic A_Lens NoIx TextStyle TextStyle Double Double)
Optic A_Lens NoIx TextStyle TextStyle Double Double
#size Optic A_Lens NoIx TextStyle TextStyle Double Double
-> Double -> TextStyle -> TextStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Double -> Double
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "textSize" (Optic' A_Lens NoIx ChartConfig Double)
Optic' A_Lens NoIx ChartConfig Double
#textSize) TextStyle -> (TextStyle -> TextStyle) -> TextStyle
forall a b. a -> (a -> b) -> b
& IsLabel
  "color" (Optic A_Lens NoIx TextStyle TextStyle Colour Colour)
Optic A_Lens NoIx TextStyle TextStyle Colour Colour
#color Optic A_Lens NoIx TextStyle TextStyle Colour Colour
-> Colour -> TextStyle -> TextStyle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (ChartConfig
cfg ChartConfig -> Optic' A_Lens NoIx ChartConfig Colour -> Colour
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "chartColor" (Optic' A_Lens NoIx ChartConfig Colour)
Optic' A_Lens NoIx ChartConfig Colour
#chartColor)) ((\(NodeInfo ID
l Double
_ (Point Double
x Double
y)) -> ((ChartConfig
cfg ChartConfig
-> Optic' A_Lens NoIx ChartConfig (ID -> Text) -> ID -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. IsLabel "labelf" (Optic' A_Lens NoIx ChartConfig (ID -> Text))
Optic' A_Lens NoIx ChartConfig (ID -> Text)
#labelf) ID
l, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x (Double
vshift' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y))) (NodeInfo -> (Text, Point Double))
-> [NodeInfo] -> [(Text, Point Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeInfo]
ns)

-- | convert a 'Graph' processed via the graphviz commands to a 'ChartSvg' using the default ChartConfig.
graphToChart :: Graph -> ChartSvg
graphToChart :: Graph -> ChartSvg
graphToChart = ChartConfig -> Graph -> ChartSvg
graphToChartWith ChartConfig
defaultChartConfig

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

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