{-# LANGUAGE CPP, OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
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
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
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
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
parseUnqt :: Parse GlobalAttributes
parseUnqt = do Attributes -> GlobalAttributes
gat <- Parse (Attributes -> GlobalAttributes)
parseGlobAttrType
let mtp :: Maybe AttributeType
mtp = GlobalAttributes -> Maybe AttributeType
globAttrType forall a b. (a -> b) -> a -> b
$ Attributes -> GlobalAttributes
gat []
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
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
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]
++)
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
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'
| Attribute -> Bool
usedByNodes Attribute
attr = Attributes -> GlobalAttributes
NodeAttrs Attributes
attr'
| Bool
otherwise = Attributes -> GlobalAttributes
EdgeAttrs Attributes
attr'
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
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
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 ()
]
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 }
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
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]
++)
type EdgeNode n = (n, Maybe PortPos)
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
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
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)
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
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
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
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
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
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
""
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)
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
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)
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]
++)
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
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