{-# LANGUAGE CPP, OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}

{- |
   Module      : Data.GraphViz.Types.Internal.Common
   Description : Common internal functions for dealing with overall types.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module provides common functions used by both
   "Data.GraphViz.Types" as well as "Data.GraphViz.Types.Generalised".
-}
module Data.GraphViz.Types.Internal.Common
       ( GraphID (..)
       , Number (..)
       , numericValue
       , GlobalAttributes (..)
       , partitionGlobal
       , unPartitionGlobal
       , withGlob
       , DotNode (..)
       , DotEdge (..)
       , parseEdgeLine
       , printGraphID
       , parseGraphID
       , printStmtBased
       , printStmtBasedList
       , printSubGraphID
       , parseSubGraph
       , parseBracesBased
       , parseStatements
       ) where

import Data.GraphViz.Attributes.Complete (Attribute(HeadPort, TailPort),
                                          Attributes, Number(..),
                                          usedByClusters, usedByGraphs,
                                          usedByNodes)
import Data.GraphViz.Attributes.Internal (PortPos, parseEdgeBasedPP)
import Data.GraphViz.Internal.State
import Data.GraphViz.Internal.Util
import Data.GraphViz.Parsing
import Data.GraphViz.Printing

import           Control.Monad       (unless, when)
import           Data.Maybe          (isJust)
import           Data.Text.Lazy      (Text)
import qualified Data.Text.Lazy      as T
import qualified Data.Text.Lazy.Read as T

#if !MIN_VERSION_base (4,13,0)
import Data.Monoid ((<>))
#endif

-- -----------------------------------------------------------------------------
-- This is re-exported by Data.GraphViz.Types

-- | A polymorphic type that covers all possible ID values allowed by
--   Dot syntax.  Note that whilst the 'ParseDot' and 'PrintDot'
--   instances for 'String' will properly take care of the special
--   cases for numbers, they are treated differently here.
data GraphID = Str Text
             | Num Number
             deriving (GraphID -> GraphID -> Bool
(GraphID -> GraphID -> Bool)
-> (GraphID -> GraphID -> Bool) -> Eq GraphID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GraphID -> GraphID -> Bool
== :: GraphID -> GraphID -> Bool
$c/= :: GraphID -> GraphID -> Bool
/= :: GraphID -> GraphID -> Bool
Eq, Eq GraphID
Eq GraphID =>
(GraphID -> GraphID -> Ordering)
-> (GraphID -> GraphID -> Bool)
-> (GraphID -> GraphID -> Bool)
-> (GraphID -> GraphID -> Bool)
-> (GraphID -> GraphID -> Bool)
-> (GraphID -> GraphID -> GraphID)
-> (GraphID -> GraphID -> GraphID)
-> Ord GraphID
GraphID -> GraphID -> Bool
GraphID -> GraphID -> Ordering
GraphID -> GraphID -> GraphID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GraphID -> GraphID -> Ordering
compare :: GraphID -> GraphID -> Ordering
$c< :: GraphID -> GraphID -> Bool
< :: GraphID -> GraphID -> Bool
$c<= :: GraphID -> GraphID -> Bool
<= :: GraphID -> GraphID -> Bool
$c> :: GraphID -> GraphID -> Bool
> :: GraphID -> GraphID -> Bool
$c>= :: GraphID -> GraphID -> Bool
>= :: GraphID -> GraphID -> Bool
$cmax :: GraphID -> GraphID -> GraphID
max :: GraphID -> GraphID -> GraphID
$cmin :: GraphID -> GraphID -> GraphID
min :: GraphID -> GraphID -> GraphID
Ord, Int -> GraphID -> ShowS
[GraphID] -> ShowS
GraphID -> String
(Int -> GraphID -> ShowS)
-> (GraphID -> String) -> ([GraphID] -> ShowS) -> Show GraphID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GraphID -> ShowS
showsPrec :: Int -> GraphID -> ShowS
$cshow :: GraphID -> String
show :: GraphID -> String
$cshowList :: [GraphID] -> ShowS
showList :: [GraphID] -> ShowS
Show, ReadPrec [GraphID]
ReadPrec GraphID
Int -> ReadS GraphID
ReadS [GraphID]
(Int -> ReadS GraphID)
-> ReadS [GraphID]
-> ReadPrec GraphID
-> ReadPrec [GraphID]
-> Read GraphID
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS GraphID
readsPrec :: Int -> ReadS GraphID
$creadList :: ReadS [GraphID]
readList :: ReadS [GraphID]
$creadPrec :: ReadPrec GraphID
readPrec :: ReadPrec GraphID
$creadListPrec :: ReadPrec [GraphID]
readListPrec :: ReadPrec [GraphID]
Read)

instance PrintDot GraphID where
  unqtDot :: GraphID -> DotCode
unqtDot (Str Text
str) = Text -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Text
str
  unqtDot (Num Number
n)   = Number -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Number
n

  toDot :: GraphID -> DotCode
toDot (Str Text
str) = Text -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Text
str
  toDot (Num Number
n)   = Number -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Number
n

instance ParseDot GraphID where
  parseUnqt :: Parse GraphID
parseUnqt = Text -> GraphID
stringNum (Text -> GraphID) -> Parser GraphvizState Text -> Parse GraphID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GraphvizState Text
forall a. ParseDot a => Parse a
parseUnqt

  parse :: Parse GraphID
parse = Text -> GraphID
stringNum (Text -> GraphID) -> Parser GraphvizState Text -> Parse GraphID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GraphvizState Text
forall a. ParseDot a => Parse a
parse
          Parser GraphvizState Text -> ShowS -> Parser GraphvizState Text
forall a. Parser GraphvizState a -> ShowS -> Parser GraphvizState a
forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
          (String
"Not a valid GraphID\n\t"String -> ShowS
forall a. [a] -> [a] -> [a]
++)

stringNum     :: Text -> GraphID
stringNum :: Text -> GraphID
stringNum Text
str = GraphID -> (Int -> GraphID) -> Maybe Int -> GraphID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GraphID
checkDbl (Number -> GraphID
Num (Number -> GraphID) -> (Int -> Number) -> Int -> GraphID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Number
Int) (Maybe Int -> GraphID) -> Maybe Int -> GraphID
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
stringToInt Text
str
  where
    checkDbl :: GraphID
checkDbl = if Bool -> Text -> Bool
isNumString Bool
True Text
str
               then Number -> GraphID
Num (Number -> GraphID) -> (Double -> Number) -> Double -> GraphID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Number
Dbl (Double -> GraphID) -> Double -> GraphID
forall a b. (a -> b) -> a -> b
$ Text -> Double
toDouble Text
str
               else Text -> GraphID
Str Text
str

numericValue           :: GraphID -> Maybe Int
numericValue :: GraphID -> Maybe Int
numericValue (Str Text
str) = (String -> Maybe Int)
-> ((Double, Text) -> Maybe Int)
-> Either String (Double, Text)
-> Maybe Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Int -> String -> Maybe Int
forall a b. a -> b -> a
const Maybe Int
forall a. Maybe a
Nothing) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ((Double, Text) -> Int) -> (Double, Text) -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int)
-> ((Double, Text) -> Double) -> (Double, Text) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Text) -> Double
forall a b. (a, b) -> a
fst)
                         (Either String (Double, Text) -> Maybe Int)
-> Either String (Double, Text) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Reader Double -> Reader Double
forall a. Num a => Reader a -> Reader a
T.signed Reader Double
T.double Text
str
numericValue (Num Number
n)   = case Number
n of
                           Int Int
i -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
                           Dbl Double
d -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
d

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

-- Re-exported by Data.GraphViz.Types.*

-- | Represents a list of top-level list of 'Attribute's for the
--   entire graph/sub-graph.  Note that 'GraphAttrs' also applies to
--   'DotSubGraph's.
--
--   Note that Dot allows a single 'Attribute' to be listed on a line;
--   if this is the case then when parsing, the type of 'Attribute' it
--   is determined and that type of 'GlobalAttribute' is created.
data GlobalAttributes = GraphAttrs { GlobalAttributes -> Attributes
attrs :: Attributes }
                      | NodeAttrs  { attrs :: Attributes }
                      | EdgeAttrs  { attrs :: Attributes }
                      deriving (GlobalAttributes -> GlobalAttributes -> Bool
(GlobalAttributes -> GlobalAttributes -> Bool)
-> (GlobalAttributes -> GlobalAttributes -> Bool)
-> Eq GlobalAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalAttributes -> GlobalAttributes -> Bool
== :: GlobalAttributes -> GlobalAttributes -> Bool
$c/= :: GlobalAttributes -> GlobalAttributes -> Bool
/= :: GlobalAttributes -> GlobalAttributes -> Bool
Eq, Eq GlobalAttributes
Eq GlobalAttributes =>
(GlobalAttributes -> GlobalAttributes -> Ordering)
-> (GlobalAttributes -> GlobalAttributes -> Bool)
-> (GlobalAttributes -> GlobalAttributes -> Bool)
-> (GlobalAttributes -> GlobalAttributes -> Bool)
-> (GlobalAttributes -> GlobalAttributes -> Bool)
-> (GlobalAttributes -> GlobalAttributes -> GlobalAttributes)
-> (GlobalAttributes -> GlobalAttributes -> GlobalAttributes)
-> Ord GlobalAttributes
GlobalAttributes -> GlobalAttributes -> Bool
GlobalAttributes -> GlobalAttributes -> Ordering
GlobalAttributes -> GlobalAttributes -> GlobalAttributes
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GlobalAttributes -> GlobalAttributes -> Ordering
compare :: GlobalAttributes -> GlobalAttributes -> Ordering
$c< :: GlobalAttributes -> GlobalAttributes -> Bool
< :: GlobalAttributes -> GlobalAttributes -> Bool
$c<= :: GlobalAttributes -> GlobalAttributes -> Bool
<= :: GlobalAttributes -> GlobalAttributes -> Bool
$c> :: GlobalAttributes -> GlobalAttributes -> Bool
> :: GlobalAttributes -> GlobalAttributes -> Bool
$c>= :: GlobalAttributes -> GlobalAttributes -> Bool
>= :: GlobalAttributes -> GlobalAttributes -> Bool
$cmax :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
max :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
$cmin :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
min :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
Ord, Int -> GlobalAttributes -> ShowS
[GlobalAttributes] -> ShowS
GlobalAttributes -> String
(Int -> GlobalAttributes -> ShowS)
-> (GlobalAttributes -> String)
-> ([GlobalAttributes] -> ShowS)
-> Show GlobalAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalAttributes -> ShowS
showsPrec :: Int -> GlobalAttributes -> ShowS
$cshow :: GlobalAttributes -> String
show :: GlobalAttributes -> String
$cshowList :: [GlobalAttributes] -> ShowS
showList :: [GlobalAttributes] -> ShowS
Show, ReadPrec [GlobalAttributes]
ReadPrec GlobalAttributes
Int -> ReadS GlobalAttributes
ReadS [GlobalAttributes]
(Int -> ReadS GlobalAttributes)
-> ReadS [GlobalAttributes]
-> ReadPrec GlobalAttributes
-> ReadPrec [GlobalAttributes]
-> Read GlobalAttributes
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS GlobalAttributes
readsPrec :: Int -> ReadS GlobalAttributes
$creadList :: ReadS [GlobalAttributes]
readList :: ReadS [GlobalAttributes]
$creadPrec :: ReadPrec GlobalAttributes
readPrec :: ReadPrec GlobalAttributes
$creadListPrec :: ReadPrec [GlobalAttributes]
readListPrec :: ReadPrec [GlobalAttributes]
Read)

instance PrintDot GlobalAttributes where
  unqtDot :: GlobalAttributes -> DotCode
unqtDot = Bool
-> (GlobalAttributes -> DotCode)
-> (GlobalAttributes -> Maybe AttributeType)
-> (GlobalAttributes -> Attributes)
-> GlobalAttributes
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> a
-> DotCode
printAttrBased Bool
True GlobalAttributes -> DotCode
printGlobAttrType GlobalAttributes -> Maybe AttributeType
globAttrType GlobalAttributes -> Attributes
attrs

  unqtListToDot :: [GlobalAttributes] -> DotCode
unqtListToDot = Bool
-> (GlobalAttributes -> DotCode)
-> (GlobalAttributes -> Maybe AttributeType)
-> (GlobalAttributes -> Attributes)
-> [GlobalAttributes]
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> [a]
-> DotCode
printAttrBasedList Bool
True GlobalAttributes -> DotCode
printGlobAttrType GlobalAttributes -> Maybe AttributeType
globAttrType GlobalAttributes -> Attributes
attrs

  listToDot :: [GlobalAttributes] -> DotCode
listToDot = [GlobalAttributes] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot

-- GraphAttrs, NodeAttrs and EdgeAttrs respectively
partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal = (GlobalAttributes
 -> (Attributes, Attributes, Attributes)
 -> (Attributes, Attributes, Attributes))
-> (Attributes, Attributes, Attributes)
-> [GlobalAttributes]
-> (Attributes, Attributes, Attributes)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalAttributes
-> (Attributes, Attributes, Attributes)
-> (Attributes, Attributes, Attributes)
select ([], [], [])
  where
    select :: GlobalAttributes
-> (Attributes, Attributes, Attributes)
-> (Attributes, Attributes, Attributes)
select GlobalAttributes
globA ~(Attributes
gs,Attributes
ns,Attributes
es) = case GlobalAttributes
globA of
                                 GraphAttrs Attributes
as -> (Attributes
as Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++ Attributes
gs, Attributes
ns, Attributes
es)
                                 NodeAttrs  Attributes
as -> (Attributes
gs, Attributes
as Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++ Attributes
ns, Attributes
es)
                                 EdgeAttrs  Attributes
as -> (Attributes
gs, Attributes
ns, Attributes
as Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++ Attributes
es)

unPartitionGlobal :: (Attributes, Attributes, Attributes) -> [GlobalAttributes]
unPartitionGlobal :: (Attributes, Attributes, Attributes) -> [GlobalAttributes]
unPartitionGlobal (Attributes
gas,Attributes
nas,Attributes
eas) = [ Attributes -> GlobalAttributes
GraphAttrs Attributes
gas
                                  , Attributes -> GlobalAttributes
NodeAttrs  Attributes
nas
                                  , Attributes -> GlobalAttributes
EdgeAttrs  Attributes
eas
                                  ]

printGlobAttrType              :: GlobalAttributes -> DotCode
printGlobAttrType :: GlobalAttributes -> DotCode
printGlobAttrType GraphAttrs{} = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
"graph"
printGlobAttrType NodeAttrs{}  = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
"node"
printGlobAttrType EdgeAttrs{}  = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
"edge"

instance ParseDot GlobalAttributes where
  -- Not using parseAttrBased here because we want to force usage of
  -- Attributes.
  parseUnqt :: Parse GlobalAttributes
parseUnqt = do Attributes -> GlobalAttributes
gat <- Parse (Attributes -> GlobalAttributes)
parseGlobAttrType

                 -- Determine if we need to set the attribute type.
                 let mtp :: Maybe AttributeType
mtp = GlobalAttributes -> Maybe AttributeType
globAttrType (GlobalAttributes -> Maybe AttributeType)
-> GlobalAttributes -> Maybe AttributeType
forall a b. (a -> b) -> a -> b
$ Attributes -> GlobalAttributes
gat [] -- Only need the constructor
                 AttributeType
oldTp <- Parser GraphvizState AttributeType
forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType
                 Parser GraphvizState ()
-> (AttributeType -> Parser GraphvizState ())
-> Maybe AttributeType
-> Parser GraphvizState ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Parser GraphvizState ()
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) AttributeType -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType Maybe AttributeType
mtp

                 Attributes
as <- Parser GraphvizState ()
whitespace Parser GraphvizState ()
-> Parser GraphvizState Attributes
-> Parser GraphvizState Attributes
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState Attributes
forall a. ParseDot a => Parse a
parse

                 -- Safe to set back even if not changed.
                 AttributeType -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
oldTp
                 GlobalAttributes -> Parse GlobalAttributes
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalAttributes -> Parse GlobalAttributes)
-> GlobalAttributes -> Parse GlobalAttributes
forall a b. (a -> b) -> a -> b
$ Attributes -> GlobalAttributes
gat Attributes
as
              Parse GlobalAttributes
-> Parse GlobalAttributes -> Parse GlobalAttributes
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
              (Attribute -> GlobalAttributes)
-> Parser GraphvizState Attribute -> Parse GlobalAttributes
forall a b.
(a -> b) -> Parser GraphvizState a -> Parser GraphvizState b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attribute -> GlobalAttributes
determineType Parser GraphvizState Attribute
forall a. ParseDot a => Parse a
parse

  parse :: Parse GlobalAttributes
parse = Parse GlobalAttributes
forall a. ParseDot a => Parse a
parseUnqt -- Don't want the option of quoting
          Parse GlobalAttributes -> ShowS -> Parse GlobalAttributes
forall a. Parser GraphvizState a -> ShowS -> Parser GraphvizState a
forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
          (String
"Not a valid listing of global attributes\n\t"String -> ShowS
forall a. [a] -> [a] -> [a]
++)

  -- Have to do this manually because of the special case
  parseUnqtList :: Parse [GlobalAttributes]
parseUnqtList = Parse GlobalAttributes -> Parse [GlobalAttributes]
forall a. Parse a -> Parse [a]
parseStatements Parse GlobalAttributes
forall a. ParseDot a => Parse a
parseUnqt

  parseList :: Parse [GlobalAttributes]
parseList = Parse [GlobalAttributes]
forall a. ParseDot a => Parse [a]
parseUnqtList

-- Cheat: rather than determine whether it's a graph, cluster or
-- sub-graph just don't set it.
globAttrType :: GlobalAttributes -> Maybe AttributeType
globAttrType :: GlobalAttributes -> Maybe AttributeType
globAttrType NodeAttrs{} = AttributeType -> Maybe AttributeType
forall a. a -> Maybe a
Just AttributeType
NodeAttribute
globAttrType EdgeAttrs{} = AttributeType -> Maybe AttributeType
forall a. a -> Maybe a
Just AttributeType
EdgeAttribute
globAttrType GlobalAttributes
_           = Maybe AttributeType
forall a. Maybe a
Nothing

parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)
parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)
parseGlobAttrType = [Parse (Attributes -> GlobalAttributes)]
-> Parse (Attributes -> GlobalAttributes)
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ (Attributes -> GlobalAttributes)
-> String -> Parse (Attributes -> GlobalAttributes)
forall a. a -> String -> Parse a
stringRep Attributes -> GlobalAttributes
GraphAttrs String
"graph"
                          , (Attributes -> GlobalAttributes)
-> String -> Parse (Attributes -> GlobalAttributes)
forall a. a -> String -> Parse a
stringRep Attributes -> GlobalAttributes
NodeAttrs String
"node"
                          , (Attributes -> GlobalAttributes)
-> String -> Parse (Attributes -> GlobalAttributes)
forall a. a -> String -> Parse a
stringRep Attributes -> GlobalAttributes
EdgeAttrs String
"edge"
                          ]

determineType :: Attribute -> GlobalAttributes
determineType :: Attribute -> GlobalAttributes
determineType Attribute
attr
  | Attribute -> Bool
usedByGraphs Attribute
attr   = Attributes -> GlobalAttributes
GraphAttrs Attributes
attr'
  | Attribute -> Bool
usedByClusters Attribute
attr = Attributes -> GlobalAttributes
GraphAttrs Attributes
attr' -- Also covers SubGraph case
  | Attribute -> Bool
usedByNodes Attribute
attr    = Attributes -> GlobalAttributes
NodeAttrs Attributes
attr'
  | Bool
otherwise           = Attributes -> GlobalAttributes
EdgeAttrs Attributes
attr' -- Must be for edges.
  where
    attr' :: Attributes
attr' = [Attribute
attr]

withGlob :: (Attributes -> Attributes) -> GlobalAttributes -> GlobalAttributes
withGlob :: (Attributes -> Attributes) -> GlobalAttributes -> GlobalAttributes
withGlob Attributes -> Attributes
f (GraphAttrs Attributes
as) = Attributes -> GlobalAttributes
GraphAttrs (Attributes -> GlobalAttributes) -> Attributes -> GlobalAttributes
forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
f Attributes
as
withGlob Attributes -> Attributes
f (NodeAttrs  Attributes
as) = Attributes -> GlobalAttributes
NodeAttrs  (Attributes -> GlobalAttributes) -> Attributes -> GlobalAttributes
forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
f Attributes
as
withGlob Attributes -> Attributes
f (EdgeAttrs  Attributes
as) = Attributes -> GlobalAttributes
EdgeAttrs  (Attributes -> GlobalAttributes) -> Attributes -> GlobalAttributes
forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
f Attributes
as

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

-- | A node in 'DotGraph'.
data DotNode n = DotNode { forall n. DotNode n -> n
nodeID         :: n
                         , forall n. DotNode n -> Attributes
nodeAttributes :: Attributes
                         }
               deriving (DotNode n -> DotNode n -> Bool
(DotNode n -> DotNode n -> Bool)
-> (DotNode n -> DotNode n -> Bool) -> Eq (DotNode n)
forall n. Eq n => DotNode n -> DotNode n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall n. Eq n => DotNode n -> DotNode n -> Bool
== :: DotNode n -> DotNode n -> Bool
$c/= :: forall n. Eq n => DotNode n -> DotNode n -> Bool
/= :: DotNode n -> DotNode n -> Bool
Eq, Eq (DotNode n)
Eq (DotNode n) =>
(DotNode n -> DotNode n -> Ordering)
-> (DotNode n -> DotNode n -> Bool)
-> (DotNode n -> DotNode n -> Bool)
-> (DotNode n -> DotNode n -> Bool)
-> (DotNode n -> DotNode n -> Bool)
-> (DotNode n -> DotNode n -> DotNode n)
-> (DotNode n -> DotNode n -> DotNode n)
-> Ord (DotNode n)
DotNode n -> DotNode n -> Bool
DotNode n -> DotNode n -> Ordering
DotNode n -> DotNode n -> DotNode n
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
forall n. Ord n => Eq (DotNode n)
forall n. Ord n => DotNode n -> DotNode n -> Bool
forall n. Ord n => DotNode n -> DotNode n -> Ordering
forall n. Ord n => DotNode n -> DotNode n -> DotNode n
$ccompare :: forall n. Ord n => DotNode n -> DotNode n -> Ordering
compare :: DotNode n -> DotNode n -> Ordering
$c< :: forall n. Ord n => DotNode n -> DotNode n -> Bool
< :: DotNode n -> DotNode n -> Bool
$c<= :: forall n. Ord n => DotNode n -> DotNode n -> Bool
<= :: DotNode n -> DotNode n -> Bool
$c> :: forall n. Ord n => DotNode n -> DotNode n -> Bool
> :: DotNode n -> DotNode n -> Bool
$c>= :: forall n. Ord n => DotNode n -> DotNode n -> Bool
>= :: DotNode n -> DotNode n -> Bool
$cmax :: forall n. Ord n => DotNode n -> DotNode n -> DotNode n
max :: DotNode n -> DotNode n -> DotNode n
$cmin :: forall n. Ord n => DotNode n -> DotNode n -> DotNode n
min :: DotNode n -> DotNode n -> DotNode n
Ord, Int -> DotNode n -> ShowS
[DotNode n] -> ShowS
DotNode n -> String
(Int -> DotNode n -> ShowS)
-> (DotNode n -> String)
-> ([DotNode n] -> ShowS)
-> Show (DotNode n)
forall n. Show n => Int -> DotNode n -> ShowS
forall n. Show n => [DotNode n] -> ShowS
forall n. Show n => DotNode n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall n. Show n => Int -> DotNode n -> ShowS
showsPrec :: Int -> DotNode n -> ShowS
$cshow :: forall n. Show n => DotNode n -> String
show :: DotNode n -> String
$cshowList :: forall n. Show n => [DotNode n] -> ShowS
showList :: [DotNode n] -> ShowS
Show, ReadPrec [DotNode n]
ReadPrec (DotNode n)
Int -> ReadS (DotNode n)
ReadS [DotNode n]
(Int -> ReadS (DotNode n))
-> ReadS [DotNode n]
-> ReadPrec (DotNode n)
-> ReadPrec [DotNode n]
-> Read (DotNode n)
forall n. Read n => ReadPrec [DotNode n]
forall n. Read n => ReadPrec (DotNode n)
forall n. Read n => Int -> ReadS (DotNode n)
forall n. Read n => ReadS [DotNode n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall n. Read n => Int -> ReadS (DotNode n)
readsPrec :: Int -> ReadS (DotNode n)
$creadList :: forall n. Read n => ReadS [DotNode n]
readList :: ReadS [DotNode n]
$creadPrec :: forall n. Read n => ReadPrec (DotNode n)
readPrec :: ReadPrec (DotNode n)
$creadListPrec :: forall n. Read n => ReadPrec [DotNode n]
readListPrec :: ReadPrec [DotNode n]
Read)

instance (PrintDot n) => PrintDot (DotNode n) where
  unqtDot :: DotNode n -> DotCode
unqtDot = Bool
-> (DotNode n -> DotCode)
-> (DotNode n -> Maybe AttributeType)
-> (DotNode n -> Attributes)
-> DotNode n
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> a
-> DotCode
printAttrBased Bool
False DotNode n -> DotCode
forall n. PrintDot n => DotNode n -> DotCode
printNodeID
                           (Maybe AttributeType -> DotNode n -> Maybe AttributeType
forall a b. a -> b -> a
const (Maybe AttributeType -> DotNode n -> Maybe AttributeType)
-> Maybe AttributeType -> DotNode n -> Maybe AttributeType
forall a b. (a -> b) -> a -> b
$ AttributeType -> Maybe AttributeType
forall a. a -> Maybe a
Just AttributeType
NodeAttribute) DotNode n -> Attributes
forall n. DotNode n -> Attributes
nodeAttributes

  unqtListToDot :: [DotNode n] -> DotCode
unqtListToDot = Bool
-> (DotNode n -> DotCode)
-> (DotNode n -> Maybe AttributeType)
-> (DotNode n -> Attributes)
-> [DotNode n]
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> [a]
-> DotCode
printAttrBasedList Bool
False DotNode n -> DotCode
forall n. PrintDot n => DotNode n -> DotCode
printNodeID
                                     (Maybe AttributeType -> DotNode n -> Maybe AttributeType
forall a b. a -> b -> a
const (Maybe AttributeType -> DotNode n -> Maybe AttributeType)
-> Maybe AttributeType -> DotNode n -> Maybe AttributeType
forall a b. (a -> b) -> a -> b
$ AttributeType -> Maybe AttributeType
forall a. a -> Maybe a
Just AttributeType
NodeAttribute) DotNode n -> Attributes
forall n. DotNode n -> Attributes
nodeAttributes

  listToDot :: [DotNode n] -> DotCode
listToDot = [DotNode n] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot

printNodeID :: (PrintDot n) => DotNode n -> DotCode
printNodeID :: forall n. PrintDot n => DotNode n -> DotCode
printNodeID = n -> DotCode
forall a. PrintDot a => a -> DotCode
toDot (n -> DotCode) -> (DotNode n -> n) -> DotNode n -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotNode n -> n
forall n. DotNode n -> n
nodeID

instance (ParseDot n) => ParseDot (DotNode n) where
  parseUnqt :: Parse (DotNode n)
parseUnqt = AttributeType
-> Bool -> Parse (Attributes -> DotNode n) -> Parse (DotNode n)
forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased AttributeType
NodeAttribute Bool
False Parse (Attributes -> DotNode n)
forall n. ParseDot n => Parse (Attributes -> DotNode n)
parseNodeID

  parse :: Parse (DotNode n)
parse = Parse (DotNode n)
forall a. ParseDot a => Parse a
parseUnqt -- Don't want the option of quoting

  parseUnqtList :: Parse [DotNode n]
parseUnqtList = AttributeType
-> Bool -> Parse (Attributes -> DotNode n) -> Parse [DotNode n]
forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList AttributeType
NodeAttribute Bool
False Parse (Attributes -> DotNode n)
forall n. ParseDot n => Parse (Attributes -> DotNode n)
parseNodeID

  parseList :: Parse [DotNode n]
parseList = Parse [DotNode n]
forall a. ParseDot a => Parse [a]
parseUnqtList

parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n)
parseNodeID :: forall n. ParseDot n => Parse (Attributes -> DotNode n)
parseNodeID = n -> Attributes -> DotNode n
forall n. n -> Attributes -> DotNode n
DotNode (n -> Attributes -> DotNode n)
-> Parser GraphvizState n
-> Parser GraphvizState (Attributes -> DotNode n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GraphvizState n
parseAndCheck
  where
    parseAndCheck :: Parser GraphvizState n
parseAndCheck = do n
n <- Parser GraphvizState n
forall a. ParseDot a => Parse a
parse
                       Maybe ()
me <- Parser GraphvizState () -> Parser GraphvizState (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser GraphvizState ()
parseUnwanted
                       Parser GraphvizState n
-> (() -> Parser GraphvizState n)
-> Maybe ()
-> Parser GraphvizState n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (n -> Parser GraphvizState n
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return n
n) (Parser GraphvizState n -> () -> Parser GraphvizState n
forall a b. a -> b -> a
const Parser GraphvizState n
forall {a}. Parser GraphvizState a
notANode) Maybe ()
me
    notANode :: Parser GraphvizState a
notANode = String -> Parser GraphvizState a
forall a. String -> Parser GraphvizState a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"This appears to be an edge, not a node"
    parseUnwanted :: Parser GraphvizState ()
parseUnwanted = [Parser GraphvizState ()] -> Parser GraphvizState ()
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Parse Bool
parseEdgeType Parse Bool -> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser GraphvizState ()
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          , Char -> Parse Char
character Char
':' Parse Char -> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser GraphvizState ()
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- PortPos value
                          ]

instance Functor DotNode where
  fmap :: forall a b. (a -> b) -> DotNode a -> DotNode b
fmap a -> b
f DotNode a
n = DotNode a
n { nodeID = f $ nodeID n }

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

-- This is re-exported in Data.GraphViz.Types; defined here so that
-- Generalised can access and use parseEdgeLine (needed for "a -> b ->
-- c"-style edge statements).

-- | An edge in 'DotGraph'.
data DotEdge n = DotEdge { forall n. DotEdge n -> n
fromNode       :: n
                         , forall n. DotEdge n -> n
toNode         :: n
                         , forall n. DotEdge n -> Attributes
edgeAttributes :: Attributes
                         }
               deriving (DotEdge n -> DotEdge n -> Bool
(DotEdge n -> DotEdge n -> Bool)
-> (DotEdge n -> DotEdge n -> Bool) -> Eq (DotEdge n)
forall n. Eq n => DotEdge n -> DotEdge n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall n. Eq n => DotEdge n -> DotEdge n -> Bool
== :: DotEdge n -> DotEdge n -> Bool
$c/= :: forall n. Eq n => DotEdge n -> DotEdge n -> Bool
/= :: DotEdge n -> DotEdge n -> Bool
Eq, Eq (DotEdge n)
Eq (DotEdge n) =>
(DotEdge n -> DotEdge n -> Ordering)
-> (DotEdge n -> DotEdge n -> Bool)
-> (DotEdge n -> DotEdge n -> Bool)
-> (DotEdge n -> DotEdge n -> Bool)
-> (DotEdge n -> DotEdge n -> Bool)
-> (DotEdge n -> DotEdge n -> DotEdge n)
-> (DotEdge n -> DotEdge n -> DotEdge n)
-> Ord (DotEdge n)
DotEdge n -> DotEdge n -> Bool
DotEdge n -> DotEdge n -> Ordering
DotEdge n -> DotEdge n -> DotEdge n
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
forall n. Ord n => Eq (DotEdge n)
forall n. Ord n => DotEdge n -> DotEdge n -> Bool
forall n. Ord n => DotEdge n -> DotEdge n -> Ordering
forall n. Ord n => DotEdge n -> DotEdge n -> DotEdge n
$ccompare :: forall n. Ord n => DotEdge n -> DotEdge n -> Ordering
compare :: DotEdge n -> DotEdge n -> Ordering
$c< :: forall n. Ord n => DotEdge n -> DotEdge n -> Bool
< :: DotEdge n -> DotEdge n -> Bool
$c<= :: forall n. Ord n => DotEdge n -> DotEdge n -> Bool
<= :: DotEdge n -> DotEdge n -> Bool
$c> :: forall n. Ord n => DotEdge n -> DotEdge n -> Bool
> :: DotEdge n -> DotEdge n -> Bool
$c>= :: forall n. Ord n => DotEdge n -> DotEdge n -> Bool
>= :: DotEdge n -> DotEdge n -> Bool
$cmax :: forall n. Ord n => DotEdge n -> DotEdge n -> DotEdge n
max :: DotEdge n -> DotEdge n -> DotEdge n
$cmin :: forall n. Ord n => DotEdge n -> DotEdge n -> DotEdge n
min :: DotEdge n -> DotEdge n -> DotEdge n
Ord, Int -> DotEdge n -> ShowS
[DotEdge n] -> ShowS
DotEdge n -> String
(Int -> DotEdge n -> ShowS)
-> (DotEdge n -> String)
-> ([DotEdge n] -> ShowS)
-> Show (DotEdge n)
forall n. Show n => Int -> DotEdge n -> ShowS
forall n. Show n => [DotEdge n] -> ShowS
forall n. Show n => DotEdge n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall n. Show n => Int -> DotEdge n -> ShowS
showsPrec :: Int -> DotEdge n -> ShowS
$cshow :: forall n. Show n => DotEdge n -> String
show :: DotEdge n -> String
$cshowList :: forall n. Show n => [DotEdge n] -> ShowS
showList :: [DotEdge n] -> ShowS
Show, ReadPrec [DotEdge n]
ReadPrec (DotEdge n)
Int -> ReadS (DotEdge n)
ReadS [DotEdge n]
(Int -> ReadS (DotEdge n))
-> ReadS [DotEdge n]
-> ReadPrec (DotEdge n)
-> ReadPrec [DotEdge n]
-> Read (DotEdge n)
forall n. Read n => ReadPrec [DotEdge n]
forall n. Read n => ReadPrec (DotEdge n)
forall n. Read n => Int -> ReadS (DotEdge n)
forall n. Read n => ReadS [DotEdge n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall n. Read n => Int -> ReadS (DotEdge n)
readsPrec :: Int -> ReadS (DotEdge n)
$creadList :: forall n. Read n => ReadS [DotEdge n]
readList :: ReadS [DotEdge n]
$creadPrec :: forall n. Read n => ReadPrec (DotEdge n)
readPrec :: ReadPrec (DotEdge n)
$creadListPrec :: forall n. Read n => ReadPrec [DotEdge n]
readListPrec :: ReadPrec [DotEdge n]
Read)

instance (PrintDot n) => PrintDot (DotEdge n) where
  unqtDot :: DotEdge n -> DotCode
unqtDot = Bool
-> (DotEdge n -> DotCode)
-> (DotEdge n -> Maybe AttributeType)
-> (DotEdge n -> Attributes)
-> DotEdge n
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> a
-> DotCode
printAttrBased Bool
False DotEdge n -> DotCode
forall n. PrintDot n => DotEdge n -> DotCode
printEdgeID
                           (Maybe AttributeType -> DotEdge n -> Maybe AttributeType
forall a b. a -> b -> a
const (Maybe AttributeType -> DotEdge n -> Maybe AttributeType)
-> Maybe AttributeType -> DotEdge n -> Maybe AttributeType
forall a b. (a -> b) -> a -> b
$ AttributeType -> Maybe AttributeType
forall a. a -> Maybe a
Just AttributeType
EdgeAttribute) DotEdge n -> Attributes
forall n. DotEdge n -> Attributes
edgeAttributes

  unqtListToDot :: [DotEdge n] -> DotCode
unqtListToDot = Bool
-> (DotEdge n -> DotCode)
-> (DotEdge n -> Maybe AttributeType)
-> (DotEdge n -> Attributes)
-> [DotEdge n]
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> [a]
-> DotCode
printAttrBasedList Bool
False DotEdge n -> DotCode
forall n. PrintDot n => DotEdge n -> DotCode
printEdgeID
                                     (Maybe AttributeType -> DotEdge n -> Maybe AttributeType
forall a b. a -> b -> a
const (Maybe AttributeType -> DotEdge n -> Maybe AttributeType)
-> Maybe AttributeType -> DotEdge n -> Maybe AttributeType
forall a b. (a -> b) -> a -> b
$ AttributeType -> Maybe AttributeType
forall a. a -> Maybe a
Just AttributeType
EdgeAttribute) DotEdge n -> Attributes
forall n. DotEdge n -> Attributes
edgeAttributes

  listToDot :: [DotEdge n] -> DotCode
listToDot = [DotEdge n] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot

printEdgeID   :: (PrintDot n) => DotEdge n -> DotCode
printEdgeID :: forall n. PrintDot n => DotEdge n -> DotCode
printEdgeID DotEdge n
e = do Bool
isDir <- DotCodeM Bool
forall (m :: * -> *). GraphvizStateM m => m Bool
getDirectedness
                   n -> DotCode
forall a. PrintDot a => a -> DotCode
toDot (DotEdge n -> n
forall n. DotEdge n -> n
fromNode DotEdge n
e)
                     DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DotCode -> DotCode -> Bool -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode
undirEdge' DotCode
dirEdge' Bool
isDir
                     DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> n -> DotCode
forall a. PrintDot a => a -> DotCode
toDot (DotEdge n -> n
forall n. DotEdge n -> n
toNode DotEdge n
e)


instance (ParseDot n) => ParseDot (DotEdge n) where
  parseUnqt :: Parse (DotEdge n)
parseUnqt = AttributeType
-> Bool -> Parse (Attributes -> DotEdge n) -> Parse (DotEdge n)
forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased AttributeType
EdgeAttribute Bool
False Parse (Attributes -> DotEdge n)
forall n. ParseDot n => Parse (Attributes -> DotEdge n)
parseEdgeID

  parse :: Parse (DotEdge n)
parse = Parse (DotEdge n)
forall a. ParseDot a => Parse a
parseUnqt -- Don't want the option of quoting

  -- Have to take into account edges of the type "n1 -> n2 -> n3", etc.
  parseUnqtList :: Parse [DotEdge n]
parseUnqtList = [[DotEdge n]] -> [DotEdge n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[DotEdge n]] -> [DotEdge n])
-> Parser GraphvizState [[DotEdge n]] -> Parse [DotEdge n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse [DotEdge n] -> Parser GraphvizState [[DotEdge n]]
forall a. Parse a -> Parse [a]
parseStatements Parse [DotEdge n]
forall n. ParseDot n => Parse [DotEdge n]
parseEdgeLine

  parseList :: Parse [DotEdge n]
parseList = Parse [DotEdge n]
forall a. ParseDot a => Parse [a]
parseUnqtList

parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n)
parseEdgeID :: forall n. ParseDot n => Parse (Attributes -> DotEdge n)
parseEdgeID = (EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n)
-> Parse (EdgeNode n)
-> Parse Bool
-> Parse (EdgeNode n)
-> Parse (Attributes -> DotEdge n)
forall a b c sep.
(a -> b -> c) -> Parse a -> Parse sep -> Parse b -> Parse c
ignoreSep EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
forall n. EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge Parse (EdgeNode n)
forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode Parse Bool
parseEdgeType Parse (EdgeNode n)
forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode
              Parse (Attributes -> DotEdge n)
-> ShowS -> Parse (Attributes -> DotEdge n)
forall a. Parser GraphvizState a -> ShowS -> Parser GraphvizState a
forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
              (String
"Parsed beginning of DotEdge but could not parse Attributes:\n\t"String -> ShowS
forall a. [a] -> [a] -> [a]
++)
              -- Parse both edge types just to be more liberal

type EdgeNode n = (n, Maybe PortPos)

-- | Takes into account edge statements containing something like
--   @a -> \{b c\}@.
parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n]
parseEdgeNodes :: forall n. ParseDot n => Parse [EdgeNode n]
parseEdgeNodes = [Parser GraphvizState [EdgeNode n]]
-> Parser GraphvizState [EdgeNode n]
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Parser GraphvizState [EdgeNode n]
-> Parser GraphvizState [EdgeNode n]
forall a. Parse a -> Parse a
parseBraced (Parser GraphvizState [EdgeNode n]
-> Parser GraphvizState [EdgeNode n]
forall a. Parse a -> Parse a
wrapWhitespace
                                      -- Should really use sepBy1, but this will do.
                                      (Parser GraphvizState [EdgeNode n]
 -> Parser GraphvizState [EdgeNode n])
-> Parser GraphvizState [EdgeNode n]
-> Parser GraphvizState [EdgeNode n]
forall a b. (a -> b) -> a -> b
$ Parse (EdgeNode n) -> Parser GraphvizState [EdgeNode n]
forall a. Parse a -> Parse [a]
parseStatements Parse (EdgeNode n)
forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode)
                       , Parse (EdgeNode n)
-> Parser GraphvizState () -> Parser GraphvizState [EdgeNode n]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 Parse (EdgeNode n)
forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode (Parser GraphvizState () -> Parser GraphvizState ()
forall a. Parse a -> Parse a
wrapWhitespace Parser GraphvizState ()
parseComma)
                       , (EdgeNode n -> [EdgeNode n] -> [EdgeNode n]
forall a. a -> [a] -> [a]
: []) (EdgeNode n -> [EdgeNode n])
-> Parse (EdgeNode n) -> Parser GraphvizState [EdgeNode n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse (EdgeNode n)
forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode
                       ]

parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n)
parseEdgeNode :: forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode = (n -> Maybe PortPos -> EdgeNode n)
-> Parser GraphvizState n
-> Parser GraphvizState (Maybe PortPos)
-> Parser GraphvizState (EdgeNode n)
forall a b c.
(a -> b -> c)
-> Parser GraphvizState a
-> Parser GraphvizState b
-> Parser GraphvizState c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Parser GraphvizState n
forall a. ParseDot a => Parse a
parse
                           (Parser GraphvizState PortPos
-> Parser GraphvizState (Maybe PortPos)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser GraphvizState PortPos
 -> Parser GraphvizState (Maybe PortPos))
-> Parser GraphvizState PortPos
-> Parser GraphvizState (Maybe PortPos)
forall a b. (a -> b) -> a -> b
$ Char -> Parse Char
character Char
':' Parse Char
-> Parser GraphvizState PortPos -> Parser GraphvizState PortPos
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState PortPos
parseEdgeBasedPP)

mkEdge :: EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge :: forall n. EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge (n
eFrom, Maybe PortPos
mFP) (n
eTo, Maybe PortPos
mTP) = n -> n -> Attributes -> DotEdge n
forall n. n -> n -> Attributes -> DotEdge n
DotEdge n
eFrom n
eTo
                                 (Attributes -> DotEdge n)
-> (Attributes -> Attributes) -> Attributes -> DotEdge n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortPos -> Attribute) -> Maybe PortPos -> Attributes -> Attributes
addPortPos PortPos -> Attribute
TailPort Maybe PortPos
mFP
                                 (Attributes -> Attributes)
-> (Attributes -> Attributes) -> Attributes -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortPos -> Attribute) -> Maybe PortPos -> Attributes -> Attributes
addPortPos PortPos -> Attribute
HeadPort Maybe PortPos
mTP

mkEdges :: [EdgeNode n] -> [EdgeNode n]
           -> Attributes -> [DotEdge n]
mkEdges :: forall n. [EdgeNode n] -> [EdgeNode n] -> Attributes -> [DotEdge n]
mkEdges [EdgeNode n]
fs [EdgeNode n]
ts Attributes
as = (EdgeNode n -> EdgeNode n -> DotEdge n)
-> [EdgeNode n] -> [EdgeNode n] -> [DotEdge n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\EdgeNode n
f EdgeNode n
t -> EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
forall n. EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge EdgeNode n
f EdgeNode n
t Attributes
as) [EdgeNode n]
fs [EdgeNode n]
ts

addPortPos   :: (PortPos -> Attribute) -> Maybe PortPos
                -> Attributes -> Attributes
addPortPos :: (PortPos -> Attribute) -> Maybe PortPos -> Attributes -> Attributes
addPortPos PortPos -> Attribute
c = (Attributes -> Attributes)
-> (PortPos -> Attributes -> Attributes)
-> Maybe PortPos
-> Attributes
-> Attributes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attributes -> Attributes
forall a. a -> a
id ((:) (Attribute -> Attributes -> Attributes)
-> (PortPos -> Attribute) -> PortPos -> Attributes -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortPos -> Attribute
c)

parseEdgeType :: Parse Bool
parseEdgeType :: Parse Bool
parseEdgeType = Parse Bool -> Parse Bool
forall a. Parse a -> Parse a
wrapWhitespace (Parse Bool -> Parse Bool) -> Parse Bool -> Parse Bool
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Parse Bool
forall a. a -> String -> Parse a
stringRep Bool
True String
dirEdge
                                 Parse Bool -> Parse Bool -> Parse Bool
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                                 Bool -> String -> Parse Bool
forall a. a -> String -> Parse a
stringRep Bool
False String
undirEdge

parseEdgeLine :: (ParseDot n) => Parse [DotEdge n]
parseEdgeLine :: forall n. ParseDot n => Parse [DotEdge n]
parseEdgeLine = do [EdgeNode n]
n1 <- Parse [EdgeNode n]
forall n. ParseDot n => Parse [EdgeNode n]
parseEdgeNodes
                   [[EdgeNode n]]
ens <- Parse [EdgeNode n] -> Parser GraphvizState [[EdgeNode n]]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 (Parse [EdgeNode n] -> Parser GraphvizState [[EdgeNode n]])
-> Parse [EdgeNode n] -> Parser GraphvizState [[EdgeNode n]]
forall a b. (a -> b) -> a -> b
$ Parse Bool
parseEdgeType Parse Bool -> Parse [EdgeNode n] -> Parse [EdgeNode n]
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse [EdgeNode n]
forall n. ParseDot n => Parse [EdgeNode n]
parseEdgeNodes
                   let ens' :: [[EdgeNode n]]
ens' = [EdgeNode n]
n1 [EdgeNode n] -> [[EdgeNode n]] -> [[EdgeNode n]]
forall a. a -> [a] -> [a]
: [[EdgeNode n]]
ens
                       efs :: [Attributes -> [DotEdge n]]
efs = ([EdgeNode n] -> [EdgeNode n] -> Attributes -> [DotEdge n])
-> [[EdgeNode n]] -> [[EdgeNode n]] -> [Attributes -> [DotEdge n]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [EdgeNode n] -> [EdgeNode n] -> Attributes -> [DotEdge n]
forall n. [EdgeNode n] -> [EdgeNode n] -> Attributes -> [DotEdge n]
mkEdges [[EdgeNode n]]
ens' ([[EdgeNode n]] -> [[EdgeNode n]]
forall a. HasCallStack => [a] -> [a]
tail [[EdgeNode n]]
ens')
                       ef :: Parser GraphvizState (Attributes -> [DotEdge n])
ef = (Attributes -> [DotEdge n])
-> Parser GraphvizState (Attributes -> [DotEdge n])
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Attributes -> [DotEdge n])
 -> Parser GraphvizState (Attributes -> [DotEdge n]))
-> (Attributes -> [DotEdge n])
-> Parser GraphvizState (Attributes -> [DotEdge n])
forall a b. (a -> b) -> a -> b
$ \ Attributes
as -> ((Attributes -> [DotEdge n]) -> [DotEdge n])
-> [Attributes -> [DotEdge n]] -> [DotEdge n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Attributes -> [DotEdge n]) -> Attributes -> [DotEdge n]
forall a b. (a -> b) -> a -> b
$Attributes
as) [Attributes -> [DotEdge n]]
efs
                   AttributeType
-> Bool
-> Parser GraphvizState (Attributes -> [DotEdge n])
-> Parse [DotEdge n]
forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased AttributeType
EdgeAttribute Bool
False Parser GraphvizState (Attributes -> [DotEdge n])
ef

instance Functor DotEdge where
  fmap :: forall a b. (a -> b) -> DotEdge a -> DotEdge b
fmap a -> b
f DotEdge a
e = DotEdge a
e { fromNode = f $ fromNode e
               , toNode   = f $ toNode e
               }

dirEdge :: String
dirEdge :: String
dirEdge = String
"->"

dirEdge' :: DotCode
dirEdge' :: DotCode
dirEdge' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
dirEdge

undirEdge :: String
undirEdge :: String
undirEdge = String
"--"

undirEdge' :: DotCode
undirEdge' :: DotCode
undirEdge' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
undirEdge

-- -----------------------------------------------------------------------------
-- Labels

dirGraph :: String
dirGraph :: String
dirGraph = String
"digraph"

dirGraph' :: DotCode
dirGraph' :: DotCode
dirGraph' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
dirGraph

undirGraph :: String
undirGraph :: String
undirGraph = String
"graph"

undirGraph' :: DotCode
undirGraph' :: DotCode
undirGraph' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
undirGraph

strGraph :: String
strGraph :: String
strGraph = String
"strict"

strGraph' :: DotCode
strGraph' :: DotCode
strGraph' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
strGraph

sGraph :: String
sGraph :: String
sGraph = String
"subgraph"

sGraph' :: DotCode
sGraph' :: DotCode
sGraph' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
sGraph

clust :: String
clust :: String
clust = String
"cluster"

clust' :: DotCode
clust' :: DotCode
clust' = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
clust

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

printGraphID                 :: (a -> Bool) -> (a -> Bool)
                                -> (a -> Maybe GraphID)
                                -> a -> DotCode
printGraphID :: forall a.
(a -> Bool) -> (a -> Bool) -> (a -> Maybe GraphID) -> a -> DotCode
printGraphID a -> Bool
str a -> Bool
isDir a -> Maybe GraphID
mID a
g = do Bool -> DotCodeM ()
forall (m :: * -> *). GraphvizStateM m => Bool -> m ()
setDirectedness Bool
isDir'
                                  DotCode -> DotCode -> Bool -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode
forall (m :: * -> *). Applicative m => m Doc
empty DotCode
strGraph' (a -> Bool
str a
g)
                                    DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DotCode -> DotCode -> Bool -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode
undirGraph' DotCode
dirGraph' Bool
isDir'
                                    DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DotCode -> (GraphID -> DotCode) -> Maybe GraphID -> DotCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DotCode
forall (m :: * -> *). Applicative m => m Doc
empty GraphID -> DotCode
forall a. PrintDot a => a -> DotCode
toDot (a -> Maybe GraphID
mID a
g)
  where
    isDir' :: Bool
isDir' = a -> Bool
isDir a
g

parseGraphID   :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a
parseGraphID :: forall a. (Bool -> Bool -> Maybe GraphID -> a) -> Parse a
parseGraphID Bool -> Bool -> Maybe GraphID -> a
f = do Parser GraphvizState ()
whitespace
                    Bool
str <- Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> Parser GraphvizState (Maybe ()) -> Parse Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GraphvizState () -> Parser GraphvizState (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser GraphvizState () -> Parser GraphvizState ()
forall a. Parse a -> Parse a
parseAndSpace (Parser GraphvizState () -> Parser GraphvizState ())
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b. (a -> b) -> a -> b
$ String -> Parser GraphvizState ()
string String
strGraph)
                    Bool
dir <- Parse Bool -> Parse Bool
forall a. Parse a -> Parse a
parseAndSpace ( Bool -> String -> Parse Bool
forall a. a -> String -> Parse a
stringRep Bool
True String
dirGraph
                                           Parse Bool -> Parse Bool -> Parse Bool
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                                           Bool -> String -> Parse Bool
forall a. a -> String -> Parse a
stringRep Bool
False String
undirGraph
                                         )
                    Bool -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => Bool -> m ()
setDirectedness Bool
dir
                    Maybe GraphID
gID <- Parse GraphID -> Parser GraphvizState (Maybe GraphID)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parse GraphID -> Parser GraphvizState (Maybe GraphID))
-> Parse GraphID -> Parser GraphvizState (Maybe GraphID)
forall a b. (a -> b) -> a -> b
$ Parse GraphID -> Parse GraphID
forall a. Parse a -> Parse a
parseAndSpace Parse GraphID
forall a. ParseDot a => Parse a
parse
                    a -> Parse a
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parse a) -> a -> Parse a
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Maybe GraphID -> a
f Bool
str Bool
dir Maybe GraphID
gID

printStmtBased              :: (a -> DotCode) -> (a -> AttributeType)
                               -> (a -> stmts) -> (stmts -> DotCode)
                               -> a -> DotCode
printStmtBased :: forall a stmts.
(a -> DotCode)
-> (a -> AttributeType)
-> (a -> stmts)
-> (stmts -> DotCode)
-> a
-> DotCode
printStmtBased a -> DotCode
f a -> AttributeType
ftp a -> stmts
r stmts -> DotCode
dr a
a = do GraphvizState
gs <- (GraphvizState -> GraphvizState) -> DotCodeM GraphvizState
forall a. (GraphvizState -> a) -> DotCodeM a
forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> GraphvizState
forall a. a -> a
id
                                 AttributeType -> DotCodeM ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType (AttributeType -> DotCodeM ()) -> AttributeType -> DotCodeM ()
forall a b. (a -> b) -> a -> b
$ a -> AttributeType
ftp a
a
                                 Doc
dc <- DotCode -> DotCode -> DotCode
printBracesBased (a -> DotCode
f a
a) (stmts -> DotCode
dr (stmts -> DotCode) -> stmts -> DotCode
forall a b. (a -> b) -> a -> b
$ a -> stmts
r a
a)
                                 (GraphvizState -> GraphvizState) -> DotCodeM ()
forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (GraphvizState -> GraphvizState -> GraphvizState
forall a b. a -> b -> a
const GraphvizState
gs)
                                 Doc -> DotCode
forall a. a -> DotCodeM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
dc

printStmtBasedList            :: (a -> DotCode) -> (a -> AttributeType)
                                 -> (a -> stmts) -> (stmts -> DotCode)
                                 -> [a] -> DotCode
printStmtBasedList :: forall a stmts.
(a -> DotCode)
-> (a -> AttributeType)
-> (a -> stmts)
-> (stmts -> DotCode)
-> [a]
-> DotCode
printStmtBasedList a -> DotCode
f a -> AttributeType
ftp a -> stmts
r stmts -> DotCode
dr = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
vcat (DotCodeM [Doc] -> DotCode)
-> ([a] -> DotCodeM [Doc]) -> [a] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> DotCode) -> [a] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((a -> DotCode)
-> (a -> AttributeType)
-> (a -> stmts)
-> (stmts -> DotCode)
-> a
-> DotCode
forall a stmts.
(a -> DotCode)
-> (a -> AttributeType)
-> (a -> stmts)
-> (stmts -> DotCode)
-> a
-> DotCode
printStmtBased a -> DotCode
f a -> AttributeType
ftp a -> stmts
r stmts -> DotCode
dr)

-- Can't use the 'braces' combinator here because we want the closing
-- brace lined up with the h value, which due to indentation might not
-- be the case with braces.
printBracesBased     :: DotCode -> DotCode -> DotCode
printBracesBased :: DotCode -> DotCode -> DotCode
printBracesBased DotCode
h DotCode
i = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
vcat (DotCodeM [Doc] -> DotCode) -> DotCodeM [Doc] -> DotCode
forall a b. (a -> b) -> a -> b
$ [DotCode] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ DotCode
h DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DotCode
forall (m :: * -> *). Applicative m => m Doc
lbrace
                                       , DotCode -> DotCode
ind DotCode
i
                                       , DotCode
forall (m :: * -> *). Applicative m => m Doc
rbrace
                                       ]
  where
    ind :: DotCode -> DotCode
ind = Int -> DotCode -> DotCode
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
indent Int
4

-- | This /must/ only be used for sub-graphs, etc.
parseBracesBased      :: AttributeType -> Parse a -> Parse a
parseBracesBased :: forall a. AttributeType -> Parse a -> Parse a
parseBracesBased AttributeType
tp Parse a
p = do GraphvizState
gs <- (GraphvizState -> GraphvizState)
-> Parser GraphvizState GraphvizState
forall a. (GraphvizState -> a) -> Parser GraphvizState a
forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> GraphvizState
forall a. a -> a
id
                           AttributeType -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
tp
                           a
a <- Parser GraphvizState ()
whitespace Parser GraphvizState () -> Parse a -> Parse a
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse a -> Parse a
forall a. Parse a -> Parse a
parseBraced (Parse a -> Parse a
forall a. Parse a -> Parse a
wrapWhitespace Parse a
p)
                           (GraphvizState -> GraphvizState) -> Parser GraphvizState ()
forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (GraphvizState -> GraphvizState -> GraphvizState
forall a b. a -> b -> a
const GraphvizState
gs)
                           a -> Parse a
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
                        Parse a -> ShowS -> Parse a
forall a. Parser GraphvizState a -> ShowS -> Parser GraphvizState a
forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
                        (String
"Not a valid value wrapped in braces.\n\t"String -> ShowS
forall a. [a] -> [a] -> [a]
++)

printSubGraphID     :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode
printSubGraphID :: forall a. (a -> (Bool, Maybe GraphID)) -> a -> DotCode
printSubGraphID a -> (Bool, Maybe GraphID)
f a
a = DotCode
sGraph'
                      DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DotCode -> (GraphID -> DotCode) -> Maybe GraphID -> DotCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DotCode
cl GraphID -> DotCode
dtID Maybe GraphID
mID
  where
    (Bool
isCl, Maybe GraphID
mID) = a -> (Bool, Maybe GraphID)
f a
a
    cl :: DotCode
cl = DotCode -> DotCode -> Bool -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode
forall (m :: * -> *). Applicative m => m Doc
empty DotCode
clust' Bool
isCl
    dtID :: GraphID -> DotCode
dtID = Bool -> GraphID -> DotCode
printSGID Bool
isCl

-- | Print the actual ID for a 'DotSubGraph'.
printSGID          :: Bool -> GraphID -> DotCode
printSGID :: Bool -> GraphID -> DotCode
printSGID Bool
isCl GraphID
sID = DotCode -> DotCode -> Bool -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode
noClust DotCode
addClust Bool
isCl
  where
    noClust :: DotCode
noClust = GraphID -> DotCode
forall a. PrintDot a => a -> DotCode
toDot GraphID
sID
    -- Have to manually render it as we need the un-quoted form.
    addClust :: DotCode
addClust = Text -> DotCode
forall a. PrintDot a => a -> DotCode
toDot (Text -> DotCode) -> (DotCode -> Text) -> DotCode -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append (String -> Text
T.pack String
clust) (Text -> Text) -> (DotCode -> Text) -> DotCode -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
'_'
               (Text -> Text) -> (DotCode -> Text) -> DotCode -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> Text
renderDot (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ GraphID -> DotCode
mkDot GraphID
sID
    mkDot :: GraphID -> DotCode
mkDot (Str Text
str) = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
str -- Quotes will be escaped later
    mkDot GraphID
gid       = GraphID -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot GraphID
gid

parseSubGraph         :: (Bool -> Maybe GraphID -> stmt -> c) -> Parse stmt -> Parse c
parseSubGraph :: forall stmt c.
(Bool -> Maybe GraphID -> stmt -> c) -> Parse stmt -> Parse c
parseSubGraph Bool -> Maybe GraphID -> stmt -> c
pid Parse stmt
pst = do (Bool
isC, stmt -> c
fID) <- (Bool -> Maybe GraphID -> stmt -> c) -> Parse (Bool, stmt -> c)
forall c. (Bool -> Maybe GraphID -> c) -> Parse (Bool, c)
parseSubGraphID Bool -> Maybe GraphID -> stmt -> c
pid
                           let tp :: AttributeType
tp = AttributeType -> AttributeType -> Bool -> AttributeType
forall a. a -> a -> Bool -> a
bool AttributeType
SubGraphAttribute AttributeType
ClusterAttribute Bool
isC
                           stmt -> c
fID (stmt -> c) -> Parse stmt -> Parse c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeType -> Parse stmt -> Parse stmt
forall a. AttributeType -> Parse a -> Parse a
parseBracesBased AttributeType
tp Parse stmt
pst

parseSubGraphID   :: (Bool -> Maybe GraphID -> c) -> Parse (Bool,c)
parseSubGraphID :: forall c. (Bool -> Maybe GraphID -> c) -> Parse (Bool, c)
parseSubGraphID Bool -> Maybe GraphID -> c
f = (Bool, Maybe GraphID) -> (Bool, c)
appl ((Bool, Maybe GraphID) -> (Bool, c))
-> Parser GraphvizState (Bool, Maybe GraphID)
-> Parser GraphvizState (Bool, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser GraphvizState ()
string String
sGraph Parser GraphvizState ()
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState ()
whitespace1 Parser GraphvizState ()
-> Parser GraphvizState (Bool, Maybe GraphID)
-> Parser GraphvizState (Bool, Maybe GraphID)
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState (Bool, Maybe GraphID)
parseSGID)
  where
    appl :: (Bool, Maybe GraphID) -> (Bool, c)
appl (Bool
isC, Maybe GraphID
mid) = (Bool
isC, Bool -> Maybe GraphID -> c
f Bool
isC Maybe GraphID
mid)

parseSGID :: Parse (Bool, Maybe GraphID)
parseSGID :: Parser GraphvizState (Bool, Maybe GraphID)
parseSGID = [Parser GraphvizState (Bool, Maybe GraphID)]
-> Parser GraphvizState (Bool, Maybe GraphID)
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ GraphID -> (Bool, Maybe GraphID)
getClustFrom (GraphID -> (Bool, Maybe GraphID))
-> Parse GraphID -> Parser GraphvizState (Bool, Maybe GraphID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse GraphID -> Parse GraphID
forall a. Parse a -> Parse a
parseAndSpace Parse GraphID
forall a. ParseDot a => Parse a
parse
                  , (Bool, Maybe GraphID) -> Parser GraphvizState (Bool, Maybe GraphID)
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Maybe GraphID
forall a. Maybe a
Nothing)
                  ]
  where
    -- If it's a String value, check to see if it's actually a
    -- cluster_Blah value; thus need to manually re-parse it.
    getClustFrom :: GraphID -> (Bool, Maybe GraphID)
getClustFrom (Str Text
str) = Parser GraphvizState (Bool, Maybe GraphID)
-> Text -> (Bool, Maybe GraphID)
forall a. Parse a -> Text -> a
runParser' Parser GraphvizState (Bool, Maybe GraphID)
pStr Text
str
    getClustFrom GraphID
gid       = (Bool
False, GraphID -> Maybe GraphID
forall a. a -> Maybe a
Just GraphID
gid)

    checkCl :: Parse Bool
checkCl = Bool -> String -> Parse Bool
forall a. a -> String -> Parse a
stringRep Bool
True String
clust
    pStr :: Parser GraphvizState (Bool, Maybe GraphID)
pStr = do Bool
isCl <- Parse Bool
checkCl
                      Parse Bool -> Parse Bool -> Parse Bool
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                      Bool -> Parse Bool
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
              Bool -> Parser GraphvizState () -> Parser GraphvizState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCl (Parser GraphvizState () -> Parser GraphvizState ())
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b. (a -> b) -> a -> b
$ Parse Char -> Parser GraphvizState (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parse Char
character Char
'_') Parser GraphvizState (Maybe Char)
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser GraphvizState ()
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Maybe GraphID
sID <- Parse GraphID -> Parser GraphvizState (Maybe GraphID)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parse GraphID
forall {s}. Parser s GraphID
pID
              let sID' :: Maybe GraphID
sID' = if Maybe GraphID
sID Maybe GraphID -> Maybe GraphID -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe GraphID
emptyID
                         then Maybe GraphID
forall a. Maybe a
Nothing
                         else Maybe GraphID
sID
              (Bool, Maybe GraphID) -> Parser GraphvizState (Bool, Maybe GraphID)
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isCl, Maybe GraphID
sID')

    emptyID :: Maybe GraphID
emptyID = GraphID -> Maybe GraphID
forall a. a -> Maybe a
Just (GraphID -> Maybe GraphID) -> GraphID -> Maybe GraphID
forall a b. (a -> b) -> a -> b
$ Text -> GraphID
Str Text
""

    -- For Strings, there are no more quotes to unescape, so consume
    -- what you can.
    pID :: Parser s GraphID
pID = Text -> GraphID
stringNum (Text -> GraphID) -> Parser s Text -> Parser s GraphID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser s Text
forall s. (Char -> Bool) -> Parser s Text
manySatisfy (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

{- This is a much nicer definition, but unfortunately it doesn't work.
   The problem is that Graphviz decides that a subgraph is a cluster
   if the ID starts with "cluster" (no quotes); thus, we _have_ to do
   the double layer of parsing to get it to work :@

            do isCl <- stringRep True clust
                       `onFail`
                       return False
               sID <- optional $ do when isCl
                                      $ optional (character '_') *> return ()
                                    parseUnqt
               when (isCl || isJust sID) $ whitespace1 *> return ()
               return (isCl, sID)
-}

-- The Bool is True for global, False for local.
printAttrBased                    :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType)
                                     -> (a -> Attributes) -> a -> DotCode
printAttrBased :: forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> a
-> DotCode
printAttrBased Bool
prEmp a -> DotCode
ff a -> Maybe AttributeType
ftp a -> Attributes
fas a
a = do AttributeType
oldType <- DotCodeM AttributeType
forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType
                                       DotCodeM ()
-> (AttributeType -> DotCodeM ())
-> Maybe AttributeType
-> DotCodeM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> DotCodeM ()
forall a. a -> DotCodeM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) AttributeType -> DotCodeM ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType Maybe AttributeType
mtp
                                       ColorScheme
oldCS <- DotCodeM ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
                                       (DotCode
dc DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode
forall (m :: * -> *). Applicative m => m Doc
semi) DotCode -> DotCodeM () -> DotCode
forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bool -> DotCodeM () -> DotCodeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
prEmp (ColorScheme -> DotCodeM ()
forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
oldCS)
                                                    DotCode -> DotCodeM () -> DotCode
forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* AttributeType -> DotCodeM ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
oldType
  where
    mtp :: Maybe AttributeType
mtp = a -> Maybe AttributeType
ftp a
a
    f :: DotCode
f = a -> DotCode
ff a
a
    dc :: DotCode
dc = case a -> Attributes
fas a
a of
           [] | Bool -> Bool
not Bool
prEmp -> DotCode
f
           Attributes
as -> DotCode
f DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Attributes -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Attributes
as

-- The Bool is True for global, False for local.
printAttrBasedList                    :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType)
                                         -> (a -> Attributes) -> [a] -> DotCode
printAttrBasedList :: forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> [a]
-> DotCode
printAttrBasedList Bool
prEmp a -> DotCode
ff a -> Maybe AttributeType
ftp a -> Attributes
fas = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
vcat (DotCodeM [Doc] -> DotCode)
-> ([a] -> DotCodeM [Doc]) -> [a] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> DotCode) -> [a] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> a
-> DotCode
forall a.
Bool
-> (a -> DotCode)
-> (a -> Maybe AttributeType)
-> (a -> Attributes)
-> a
-> DotCode
printAttrBased Bool
prEmp a -> DotCode
ff a -> Maybe AttributeType
ftp a -> Attributes
fas)

-- The Bool is True for global, False for local.
parseAttrBased         :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased :: forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased AttributeType
tp Bool
lc Parse (Attributes -> a)
p = do AttributeType
oldType <- Parser GraphvizState AttributeType
forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType
                            AttributeType -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
tp
                            ColorScheme
oldCS <- Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
                            Attributes -> a
f <- Parse (Attributes -> a)
p
                            Attributes
atts <- Parser GraphvizState Attributes -> Parser GraphvizState Attributes
forall a. Parse [a] -> Parse [a]
tryParseList' (Parser GraphvizState ()
whitespace Parser GraphvizState ()
-> Parser GraphvizState Attributes
-> Parser GraphvizState Attributes
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState Attributes
forall a. ParseDot a => Parse a
parse)
                            Bool -> Parser GraphvizState () -> Parser GraphvizState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
lc (Parser GraphvizState () -> Parser GraphvizState ())
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b. (a -> b) -> a -> b
$ ColorScheme -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
oldCS
                            Bool -> Parser GraphvizState () -> Parser GraphvizState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AttributeType
tp AttributeType -> AttributeType -> Bool
forall a. Eq a => a -> a -> Bool
/= AttributeType
oldType) (Parser GraphvizState () -> Parser GraphvizState ())
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b. (a -> b) -> a -> b
$ AttributeType -> Parser GraphvizState ()
forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
oldType
                            a -> Parser GraphvizState a
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser GraphvizState a) -> a -> Parser GraphvizState a
forall a b. (a -> b) -> a -> b
$ Attributes -> a
f Attributes
atts
                         Parser GraphvizState a -> ShowS -> Parser GraphvizState a
forall a. Parser GraphvizState a -> ShowS -> Parser GraphvizState a
forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
                         (String
"Not a valid attribute-based structure\n\t"String -> ShowS
forall a. [a] -> [a] -> [a]
++)

-- The Bool is True for global, False for local.
parseAttrBasedList       :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList :: forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList AttributeType
tp Bool
lc = Parse a -> Parse [a]
forall a. Parse a -> Parse [a]
parseStatements (Parse a -> Parse [a])
-> (Parse (Attributes -> a) -> Parse a)
-> Parse (Attributes -> a)
-> Parse [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
forall a.
AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased AttributeType
tp Bool
lc

-- | Parse the separator (and any other whitespace1 present) between statements.
statementEnd :: Parse ()
statementEnd :: Parser GraphvizState ()
statementEnd = Parser GraphvizState ()
parseSplit Parser GraphvizState ()
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState ()
newline'
  where
    parseSplit :: Parser GraphvizState ()
parseSplit = (Parser GraphvizState ()
whitespace Parser GraphvizState ()
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser GraphvizState ()] -> Parser GraphvizState ()
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Char -> Parse Char
character Char
';' Parse Char -> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser GraphvizState ()
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                      , Parser GraphvizState ()
newline
                                      ]
                 )
                 Parser GraphvizState ()
-> Parser GraphvizState () -> Parser GraphvizState ()
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                 Parser GraphvizState ()
whitespace1

parseStatements   :: Parse a -> Parse [a]
parseStatements :: forall a. Parse a -> Parse [a]
parseStatements Parse a
p = Parse a -> Parser GraphvizState () -> Parser GraphvizState [a]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy (Parser GraphvizState ()
whitespace Parser GraphvizState () -> Parse a -> Parse a
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse a
p) Parser GraphvizState ()
statementEnd
                    Parser GraphvizState [a]
-> Parser GraphvizState (Maybe ()) -> Parser GraphvizState [a]
forall (p :: * -> *) a b. PolyParse p => p a -> p b -> p a
`discard`
                    Parser GraphvizState () -> Parser GraphvizState (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser GraphvizState ()
statementEnd