{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GraphID -> GraphID -> Bool
$c/= :: GraphID -> GraphID -> Bool
== :: GraphID -> GraphID -> Bool
$c== :: GraphID -> GraphID -> Bool
Eq, Eq 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
min :: GraphID -> GraphID -> GraphID
$cmin :: GraphID -> GraphID -> GraphID
max :: GraphID -> GraphID -> GraphID
$cmax :: GraphID -> GraphID -> GraphID
>= :: GraphID -> GraphID -> Bool
$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
compare :: GraphID -> GraphID -> Ordering
$ccompare :: GraphID -> GraphID -> Ordering
Ord, Int -> GraphID -> ShowS
[GraphID] -> ShowS
GraphID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GraphID] -> ShowS
$cshowList :: [GraphID] -> ShowS
show :: GraphID -> String
$cshow :: GraphID -> String
showsPrec :: Int -> GraphID -> ShowS
$cshowsPrec :: Int -> GraphID -> ShowS
Show, ReadPrec [GraphID]
ReadPrec GraphID
Int -> ReadS GraphID
ReadS [GraphID]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GraphID]
$creadListPrec :: ReadPrec [GraphID]
readPrec :: ReadPrec GraphID
$creadPrec :: ReadPrec GraphID
readList :: ReadS [GraphID]
$creadList :: ReadS [GraphID]
readsPrec :: Int -> ReadS GraphID
$creadsPrec :: Int -> ReadS GraphID
Read)

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

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

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

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

stringNum     :: Text -> GraphID
stringNum :: Text -> GraphID
stringNum Text
str = forall b a. b -> (a -> b) -> Maybe a -> b
maybe GraphID
checkDbl (Number -> GraphID
Num forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Number
Int) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Number
Dbl 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) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                         forall a b. (a -> b) -> a -> b
$ 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 -> forall a. a -> Maybe a
Just Int
i
                           Dbl Double
d -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlobalAttributes -> GlobalAttributes -> Bool
$c/= :: GlobalAttributes -> GlobalAttributes -> Bool
== :: GlobalAttributes -> GlobalAttributes -> Bool
$c== :: GlobalAttributes -> GlobalAttributes -> Bool
Eq, Eq 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
min :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
$cmin :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
max :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
$cmax :: GlobalAttributes -> GlobalAttributes -> GlobalAttributes
>= :: GlobalAttributes -> GlobalAttributes -> Bool
$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
compare :: GlobalAttributes -> GlobalAttributes -> Ordering
$ccompare :: GlobalAttributes -> GlobalAttributes -> Ordering
Ord, Int -> GlobalAttributes -> ShowS
[GlobalAttributes] -> ShowS
GlobalAttributes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobalAttributes] -> ShowS
$cshowList :: [GlobalAttributes] -> ShowS
show :: GlobalAttributes -> String
$cshow :: GlobalAttributes -> String
showsPrec :: Int -> GlobalAttributes -> ShowS
$cshowsPrec :: Int -> GlobalAttributes -> ShowS
Show, ReadPrec [GlobalAttributes]
ReadPrec GlobalAttributes
Int -> ReadS GlobalAttributes
ReadS [GlobalAttributes]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GlobalAttributes]
$creadListPrec :: ReadPrec [GlobalAttributes]
readPrec :: ReadPrec GlobalAttributes
$creadPrec :: ReadPrec GlobalAttributes
readList :: ReadS [GlobalAttributes]
$creadList :: ReadS [GlobalAttributes]
readsPrec :: Int -> ReadS GlobalAttributes
$creadsPrec :: Int -> ReadS GlobalAttributes
Read)

instance PrintDot GlobalAttributes where
  unqtDot :: GlobalAttributes -> DotCode
unqtDot = 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 = 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 = forall a. PrintDot a => [a] -> DotCode
unqtListToDot

-- GraphAttrs, NodeAttrs and EdgeAttrs respectively
partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal = 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 forall a. [a] -> [a] -> [a]
++ Attributes
gs, Attributes
ns, Attributes
es)
                                 NodeAttrs  Attributes
as -> (Attributes
gs, Attributes
as forall a. [a] -> [a] -> [a]
++ Attributes
ns, Attributes
es)
                                 EdgeAttrs  Attributes
as -> (Attributes
gs, Attributes
ns, Attributes
as 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{} = forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
"graph"
printGlobAttrType NodeAttrs{}  = forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
"node"
printGlobAttrType EdgeAttrs{}  = 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 forall a b. (a -> b) -> a -> b
$ Attributes -> GlobalAttributes
gat [] -- Only need the constructor
                 AttributeType
oldTp <- forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType
                 forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType Maybe AttributeType
mtp

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

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

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

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

  parseList :: Parse [GlobalAttributes]
parseList = 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{} = forall a. a -> Maybe a
Just AttributeType
NodeAttribute
globAttrType EdgeAttrs{} = forall a. a -> Maybe a
Just AttributeType
EdgeAttribute
globAttrType GlobalAttributes
_           = forall a. Maybe a
Nothing

parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)
parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)
parseGlobAttrType = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ forall a. a -> String -> Parse a
stringRep Attributes -> GlobalAttributes
GraphAttrs String
"graph"
                          , forall a. a -> String -> Parse a
stringRep Attributes -> GlobalAttributes
NodeAttrs String
"node"
                          , 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 forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
f Attributes
as
withGlob Attributes -> Attributes
f (NodeAttrs  Attributes
as) = Attributes -> GlobalAttributes
NodeAttrs  forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
f Attributes
as
withGlob Attributes -> Attributes
f (EdgeAttrs  Attributes
as) = Attributes -> GlobalAttributes
EdgeAttrs  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
forall n. Eq n => DotNode n -> DotNode n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotNode n -> DotNode n -> Bool
$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
Eq, DotNode n -> DotNode n -> Bool
DotNode n -> DotNode n -> Ordering
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
min :: DotNode n -> DotNode n -> DotNode n
$cmin :: forall n. Ord n => DotNode n -> DotNode n -> DotNode n
max :: DotNode n -> DotNode n -> DotNode n
$cmax :: forall n. Ord n => DotNode n -> DotNode n -> DotNode n
>= :: 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
$c< :: forall n. Ord n => DotNode n -> DotNode n -> Bool
compare :: DotNode n -> DotNode n -> Ordering
$ccompare :: forall n. Ord n => DotNode n -> DotNode n -> Ordering
Ord, Int -> DotNode n -> ShowS
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
showList :: [DotNode n] -> ShowS
$cshowList :: forall n. Show n => [DotNode n] -> ShowS
show :: DotNode n -> String
$cshow :: forall n. Show n => DotNode n -> String
showsPrec :: Int -> DotNode n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> DotNode n -> ShowS
Show, ReadPrec [DotNode n]
ReadPrec (DotNode n)
ReadS [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
readListPrec :: ReadPrec [DotNode n]
$creadListPrec :: forall n. Read n => ReadPrec [DotNode n]
readPrec :: ReadPrec (DotNode n)
$creadPrec :: forall n. Read n => ReadPrec (DotNode n)
readList :: ReadS [DotNode n]
$creadList :: forall n. Read n => ReadS [DotNode n]
readsPrec :: Int -> ReadS (DotNode n)
$creadsPrec :: forall n. Read n => Int -> ReadS (DotNode n)
Read)

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

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

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

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

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

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

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

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

parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n)
parseNodeID :: forall n. ParseDot n => Parse (Attributes -> DotNode n)
parseNodeID = forall n. n -> Attributes -> DotNode n
DotNode 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 <- forall a. ParseDot a => Parse a
parse
                       Maybe ()
me <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parse ()
parseUnwanted
                       forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return n
n) (forall a b. a -> b -> a
const forall {a}. Parser GraphvizState a
notANode) Maybe ()
me
    notANode :: Parser GraphvizState a
notANode = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"This appears to be an edge, not a node"
    parseUnwanted :: Parse ()
parseUnwanted = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Parse Bool
parseEdgeType forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          , Char -> Parse Char
character Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 :: b
nodeID = a -> b
f forall a b. (a -> b) -> a -> b
$ forall n. DotNode n -> n
nodeID DotNode a
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
forall n. Eq n => DotEdge n -> DotEdge n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotEdge n -> DotEdge n -> Bool
$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
Eq, DotEdge n -> DotEdge n -> Bool
DotEdge n -> DotEdge n -> Ordering
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
min :: DotEdge n -> DotEdge n -> DotEdge n
$cmin :: forall n. Ord n => DotEdge n -> DotEdge n -> DotEdge n
max :: DotEdge n -> DotEdge n -> DotEdge n
$cmax :: forall n. Ord n => DotEdge n -> DotEdge n -> DotEdge n
>= :: 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
$c< :: forall n. Ord n => DotEdge n -> DotEdge n -> Bool
compare :: DotEdge n -> DotEdge n -> Ordering
$ccompare :: forall n. Ord n => DotEdge n -> DotEdge n -> Ordering
Ord, Int -> DotEdge n -> ShowS
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
showList :: [DotEdge n] -> ShowS
$cshowList :: forall n. Show n => [DotEdge n] -> ShowS
show :: DotEdge n -> String
$cshow :: forall n. Show n => DotEdge n -> String
showsPrec :: Int -> DotEdge n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> DotEdge n -> ShowS
Show, ReadPrec [DotEdge n]
ReadPrec (DotEdge n)
ReadS [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
readListPrec :: ReadPrec [DotEdge n]
$creadListPrec :: forall n. Read n => ReadPrec [DotEdge n]
readPrec :: ReadPrec (DotEdge n)
$creadPrec :: forall n. Read n => ReadPrec (DotEdge n)
readList :: ReadS [DotEdge n]
$creadList :: forall n. Read n => ReadS [DotEdge n]
readsPrec :: Int -> ReadS (DotEdge n)
$creadsPrec :: forall n. Read n => Int -> ReadS (DotEdge n)
Read)

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

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

  listToDot :: [DotEdge n] -> DotCode
listToDot = 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 <- forall (m :: * -> *). GraphvizStateM m => m Bool
getDirectedness
                   forall a. PrintDot a => a -> DotCode
toDot (forall n. DotEdge n -> n
fromNode DotEdge n
e)
                     forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a. a -> a -> Bool -> a
bool DotCode
undirEdge' DotCode
dirEdge' Bool
isDir
                     forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a. PrintDot a => a -> DotCode
toDot (forall n. DotEdge n -> n
toNode DotEdge n
e)


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

  parse :: Parse (DotEdge n)
parse = 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parse a -> Parse [a]
parseStatements forall n. ParseDot n => Parse [DotEdge n]
parseEdgeLine

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

parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n)
parseEdgeID :: forall n. ParseDot n => Parse (Attributes -> DotEdge n)
parseEdgeID = forall a b c sep.
(a -> b -> c) -> Parse a -> Parse sep -> Parse b -> Parse c
ignoreSep forall n. EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode Parse Bool
parseEdgeType forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode
              forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
              (String
"Parsed beginning of DotEdge but could not parse Attributes:\n\t"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 = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ forall a. Parse a -> Parse a
parseBraced (forall a. Parse a -> Parse a
wrapWhitespace
                                      -- Should really use sepBy1, but this will do.
                                      forall a b. (a -> b) -> a -> b
$ forall a. Parse a -> Parse [a]
parseStatements forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode)
                       , forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode (forall a. Parse a -> Parse a
wrapWhitespace Parse ()
parseComma)
                       , (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode
                       ]

parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n)
parseEdgeNode :: forall n. ParseDot n => Parse (EdgeNode n)
parseEdgeNode = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) forall a. ParseDot a => Parse a
parse
                           (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Char -> Parse Char
character Char
':' 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) = forall n. n -> n -> Attributes -> DotEdge n
DotEdge n
eFrom n
eTo
                                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortPos -> Attribute) -> Maybe PortPos -> Attributes -> Attributes
addPortPos PortPos -> Attribute
TailPort Maybe PortPos
mFP
                                 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 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\EdgeNode n
f EdgeNode n
t -> 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortPos -> Attribute
c)

parseEdgeType :: Parse Bool
parseEdgeType :: Parse Bool
parseEdgeType = forall a. Parse a -> Parse a
wrapWhitespace forall a b. (a -> b) -> a -> b
$ forall a. a -> String -> Parse a
stringRep Bool
True String
dirEdge
                                 forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                                 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 <- forall n. ParseDot n => Parse [EdgeNode n]
parseEdgeNodes
                   [[EdgeNode n]]
ens <- forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 forall a b. (a -> b) -> a -> b
$ Parse Bool
parseEdgeType forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. ParseDot n => Parse [EdgeNode n]
parseEdgeNodes
                   let ens' :: [[EdgeNode n]]
ens' = [EdgeNode n]
n1 forall a. a -> [a] -> [a]
: [[EdgeNode n]]
ens
                       efs :: [Attributes -> [DotEdge n]]
efs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall n. [EdgeNode n] -> [EdgeNode n] -> Attributes -> [DotEdge n]
mkEdges [[EdgeNode n]]
ens' (forall a. [a] -> [a]
tail [[EdgeNode n]]
ens')
                       ef :: Parser GraphvizState (Attributes -> [DotEdge n])
ef = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ Attributes
as -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> a -> b
$Attributes
as) [Attributes -> [DotEdge n]]
efs
                   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 :: b
fromNode = a -> b
f forall a b. (a -> b) -> a -> b
$ forall n. DotEdge n -> n
fromNode DotEdge a
e
               , toNode :: b
toNode   = a -> b
f forall a b. (a -> b) -> a -> b
$ forall n. DotEdge n -> n
toNode DotEdge a
e
               }

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

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

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

undirEdge' :: DotCode
undirEdge' :: DotCode
undirEdge' = forall (m :: * -> *). Applicative m => Text -> m Doc
text 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' = forall (m :: * -> *). Applicative m => Text -> m Doc
text 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' = forall (m :: * -> *). Applicative m => Text -> m Doc
text 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' = forall (m :: * -> *). Applicative m => Text -> m Doc
text 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' = forall (m :: * -> *). Applicative m => Text -> m Doc
text 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' = forall (m :: * -> *). Applicative m => Text -> m Doc
text 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 forall (m :: * -> *). GraphvizStateM m => Bool -> m ()
setDirectedness Bool
isDir'
                                  forall a. a -> a -> Bool -> a
bool forall (m :: * -> *). Applicative m => m Doc
empty DotCode
strGraph' (a -> Bool
str a
g)
                                    forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a. a -> a -> Bool -> a
bool DotCode
undirGraph' DotCode
dirGraph' Bool
isDir'
                                    forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). Applicative m => m Doc
empty 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 Parse ()
whitespace
                    Bool
str <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. Parse a -> Parse a
parseAndSpace forall a b. (a -> b) -> a -> b
$ String -> Parse ()
string String
strGraph)
                    Bool
dir <- forall a. Parse a -> Parse a
parseAndSpace ( forall a. a -> String -> Parse a
stringRep Bool
True String
dirGraph
                                           forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                                           forall a. a -> String -> Parse a
stringRep Bool
False String
undirGraph
                                         )
                    forall (m :: * -> *). GraphvizStateM m => Bool -> m ()
setDirectedness Bool
dir
                    Maybe GraphID
gID <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall a. Parse a -> Parse a
parseAndSpace forall a. ParseDot a => Parse a
parse
                    forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS forall a. a -> a
id
                                 forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType 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 forall a b. (a -> b) -> a -> b
$ a -> stmts
r a
a)
                                 forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (forall a b. a -> b -> a
const GraphvizState
gs)
                                 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 = forall (m :: * -> *). Functor m => m [Doc] -> m Doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 = forall (m :: * -> *). Functor m => m [Doc] -> m Doc
vcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ DotCode
h forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => m Doc
lbrace
                                       , DotCode -> DotCode
ind DotCode
i
                                       , forall (m :: * -> *). Applicative m => m Doc
rbrace
                                       ]
  where
    ind :: DotCode -> DotCode
ind = 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 <- forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS forall a. a -> a
id
                           forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
tp
                           a
a <- Parse ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parse a -> Parse a
parseBraced (forall a. Parse a -> Parse a
wrapWhitespace Parse a
p)
                           forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (forall a b. a -> b -> a
const GraphvizState
gs)
                           forall (m :: * -> *) a. Monad m => a -> m a
return a
a
                        forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
                        (String
"Not a valid value wrapped in braces.\n\t"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'
                      forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> 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 = forall a. a -> a -> Bool -> a
bool 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 = forall a. a -> a -> Bool -> a
bool DotCode
noClust DotCode
addClust Bool
isCl
  where
    noClust :: DotCode
noClust = forall a. PrintDot a => a -> DotCode
toDot GraphID
sID
    -- Have to manually render it as we need the un-quoted form.
    addClust :: DotCode
addClust = forall a. PrintDot a => a -> DotCode
toDot forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append (String -> Text
T.pack String
clust) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
'_'
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> Text
renderDot forall a b. (a -> b) -> a -> b
$ GraphID -> DotCode
mkDot GraphID
sID
    mkDot :: GraphID -> DotCode
mkDot (Str Text
str) = forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
str -- Quotes will be escaped later
    mkDot GraphID
gid       = 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) <- forall c. (Bool -> Maybe GraphID -> c) -> Parse (Bool, c)
parseSubGraphID Bool -> Maybe GraphID -> stmt -> c
pid
                           let tp :: AttributeType
tp = forall a. a -> a -> Bool -> a
bool AttributeType
SubGraphAttribute AttributeType
ClusterAttribute Bool
isC
                           stmt -> c
fID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parse ()
string String
sGraph forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse ()
whitespace1 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 = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ GraphID -> (Bool, Maybe GraphID)
getClustFrom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parse a -> Parse a
parseAndSpace forall a. ParseDot a => Parse a
parse
                  , forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, 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) = forall a. Parse a -> Text -> a
runParser' Parser GraphvizState (Bool, Maybe GraphID)
pStr Text
str
    getClustFrom GraphID
gid       = (Bool
False, forall a. a -> Maybe a
Just GraphID
gid)

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

    emptyID :: Maybe GraphID
emptyID = forall a. a -> Maybe a
Just 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. (Char -> Bool) -> Parser s Text
manySatisfy (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 <- forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType
                                       forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType Maybe AttributeType
mtp
                                       ColorScheme
oldCS <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
                                       (DotCode
dc forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *). Applicative m => m Doc
semi) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
prEmp (forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
oldCS)
                                                    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* 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 forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> 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 = forall (m :: * -> *). Functor m => m [Doc] -> m Doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 <- forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType
                            forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
tp
                            ColorScheme
oldCS <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
                            Attributes -> a
f <- Parse (Attributes -> a)
p
                            Attributes
atts <- forall a. Parse [a] -> Parse [a]
tryParseList' (Parse ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. ParseDot a => Parse a
parse)
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
lc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
oldCS
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AttributeType
tp forall a. Eq a => a -> a -> Bool
/= AttributeType
oldType) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
oldType
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Attributes -> a
f Attributes
atts
                         forall (p :: * -> *) a. Commitment p => p a -> ShowS -> p a
`adjustErr`
                         (String
"Not a valid attribute-based structure\n\t"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 = forall a. Parse a -> Parse [a]
parseStatements forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: Parse ()
statementEnd = Parse ()
parseSplit forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse ()
newline'
  where
    parseSplit :: Parse ()
parseSplit = (Parse ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Char -> Parse Char
character Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                      , Parse ()
newline
                                      ]
                 )
                 forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                 Parse ()
whitespace1

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