{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE FlexibleInstances #-}

{- |
   Module      : Data.GraphViz.Internal.State
   Description : Printing and parsing state.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   When printing and parsing Dot code, some items depend on values
   that are set earlier.
-}
module Data.GraphViz.Internal.State
       ( GraphvizStateM(..)
       , GraphvizState(..)
       , AttributeType(..)
       , setAttributeType
       , getAttributeType
       , initialState
       , setDirectedness
       , getDirectedness
       , setLayerSep
       , getLayerSep
       , setLayerListSep
       , getLayerListSep
       , setColorScheme
       , getColorScheme
       ) where

import Data.GraphViz.Attributes.ColorScheme

import Text.ParserCombinators.Poly.StateText (Parser, stQuery, stUpdate)

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

class (Monad m) => GraphvizStateM m where
  modifyGS :: (GraphvizState -> GraphvizState) -> m ()

  getsGS :: (GraphvizState -> a) -> m a

instance GraphvizStateM (Parser GraphvizState) where
  modifyGS :: (GraphvizState -> GraphvizState) -> Parser GraphvizState ()
modifyGS = forall s. (s -> s) -> Parser s ()
stUpdate

  getsGS :: forall a. (GraphvizState -> a) -> Parser GraphvizState a
getsGS = forall s a. (s -> a) -> Parser s a
stQuery

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

-- | Several aspects of Dot code are either global or mutable state.
data GraphvizState = GS { GraphvizState -> Bool
parseStrictly :: !Bool
                          -- ^ If 'False', allow fallbacks for
                          --   attributes that don't match known
                          --   specification when parsing.
                        , GraphvizState -> Bool
directedEdges :: !Bool
                        , GraphvizState -> String
layerSep      :: [Char]
                        , GraphvizState -> String
layerListSep  :: [Char]
                        , GraphvizState -> AttributeType
attributeType :: !AttributeType
                        , GraphvizState -> ColorScheme
graphColor    :: !ColorScheme
                        , GraphvizState -> ColorScheme
clusterColor  :: !ColorScheme
                        , GraphvizState -> ColorScheme
nodeColor     :: !ColorScheme
                        , GraphvizState -> ColorScheme
edgeColor     :: !ColorScheme
                        }
                   deriving (GraphvizState -> GraphvizState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GraphvizState -> GraphvizState -> Bool
$c/= :: GraphvizState -> GraphvizState -> Bool
== :: GraphvizState -> GraphvizState -> Bool
$c== :: GraphvizState -> GraphvizState -> Bool
Eq, Eq GraphvizState
GraphvizState -> GraphvizState -> Bool
GraphvizState -> GraphvizState -> Ordering
GraphvizState -> GraphvizState -> GraphvizState
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 :: GraphvizState -> GraphvizState -> GraphvizState
$cmin :: GraphvizState -> GraphvizState -> GraphvizState
max :: GraphvizState -> GraphvizState -> GraphvizState
$cmax :: GraphvizState -> GraphvizState -> GraphvizState
>= :: GraphvizState -> GraphvizState -> Bool
$c>= :: GraphvizState -> GraphvizState -> Bool
> :: GraphvizState -> GraphvizState -> Bool
$c> :: GraphvizState -> GraphvizState -> Bool
<= :: GraphvizState -> GraphvizState -> Bool
$c<= :: GraphvizState -> GraphvizState -> Bool
< :: GraphvizState -> GraphvizState -> Bool
$c< :: GraphvizState -> GraphvizState -> Bool
compare :: GraphvizState -> GraphvizState -> Ordering
$ccompare :: GraphvizState -> GraphvizState -> Ordering
Ord, Int -> GraphvizState -> ShowS
[GraphvizState] -> ShowS
GraphvizState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GraphvizState] -> ShowS
$cshowList :: [GraphvizState] -> ShowS
show :: GraphvizState -> String
$cshow :: GraphvizState -> String
showsPrec :: Int -> GraphvizState -> ShowS
$cshowsPrec :: Int -> GraphvizState -> ShowS
Show, ReadPrec [GraphvizState]
ReadPrec GraphvizState
Int -> ReadS GraphvizState
ReadS [GraphvizState]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GraphvizState]
$creadListPrec :: ReadPrec [GraphvizState]
readPrec :: ReadPrec GraphvizState
$creadPrec :: ReadPrec GraphvizState
readList :: ReadS [GraphvizState]
$creadList :: ReadS [GraphvizState]
readsPrec :: Int -> ReadS GraphvizState
$creadsPrec :: Int -> ReadS GraphvizState
Read)

initialState :: GraphvizState
initialState :: GraphvizState
initialState = GS { parseStrictly :: Bool
parseStrictly = Bool
True
                  , directedEdges :: Bool
directedEdges = Bool
True
                  , layerSep :: String
layerSep      = String
defLayerSep
                  , layerListSep :: String
layerListSep  = String
defLayerListSep
                  , attributeType :: AttributeType
attributeType = AttributeType
GraphAttribute
                  , graphColor :: ColorScheme
graphColor    = ColorScheme
X11
                  , clusterColor :: ColorScheme
clusterColor  = ColorScheme
X11
                  , nodeColor :: ColorScheme
nodeColor     = ColorScheme
X11
                  , edgeColor :: ColorScheme
edgeColor     = ColorScheme
X11
                  }

setDirectedness   :: (GraphvizStateM m) => Bool -> m ()
setDirectedness :: forall (m :: * -> *). GraphvizStateM m => Bool -> m ()
setDirectedness Bool
d = forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (\ GraphvizState
gs -> GraphvizState
gs { directedEdges :: Bool
directedEdges = Bool
d } )

getDirectedness :: (GraphvizStateM m) => m Bool
getDirectedness :: forall (m :: * -> *). GraphvizStateM m => m Bool
getDirectedness = forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> Bool
directedEdges

setAttributeType    :: (GraphvizStateM m) => AttributeType -> m ()
setAttributeType :: forall (m :: * -> *). GraphvizStateM m => AttributeType -> m ()
setAttributeType AttributeType
tp = forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS forall a b. (a -> b) -> a -> b
$ \ GraphvizState
gs -> GraphvizState
gs { attributeType :: AttributeType
attributeType = AttributeType
tp }

getAttributeType :: (GraphvizStateM m) => m AttributeType
getAttributeType :: forall (m :: * -> *). GraphvizStateM m => m AttributeType
getAttributeType = forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> AttributeType
attributeType

setLayerSep     :: (GraphvizStateM m) => [Char] -> m ()
setLayerSep :: forall (m :: * -> *). GraphvizStateM m => String -> m ()
setLayerSep String
sep = forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (\ GraphvizState
gs -> GraphvizState
gs { layerSep :: String
layerSep = String
sep } )

getLayerSep :: (GraphvizStateM m) => m [Char]
getLayerSep :: forall (m :: * -> *). GraphvizStateM m => m String
getLayerSep = forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> String
layerSep

setLayerListSep     :: (GraphvizStateM m) => [Char] -> m ()
setLayerListSep :: forall (m :: * -> *). GraphvizStateM m => String -> m ()
setLayerListSep String
sep = forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (\ GraphvizState
gs -> GraphvizState
gs { layerListSep :: String
layerListSep = String
sep } )

getLayerListSep :: (GraphvizStateM m) => m [Char]
getLayerListSep :: forall (m :: * -> *). GraphvizStateM m => m String
getLayerListSep = forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> String
layerListSep

setColorScheme    :: (GraphvizStateM m) => ColorScheme -> m ()
setColorScheme :: forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
cs = do AttributeType
tp <- forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> AttributeType
attributeType
                       forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS forall a b. (a -> b) -> a -> b
$ \GraphvizState
gs -> case AttributeType
tp of
                                           AttributeType
GraphAttribute    -> GraphvizState
gs { graphColor :: ColorScheme
graphColor   = ColorScheme
cs }
                                            -- subgraphs don't have specified scheme
                                           AttributeType
SubGraphAttribute -> GraphvizState
gs { graphColor :: ColorScheme
graphColor   = ColorScheme
cs }
                                           AttributeType
ClusterAttribute  -> GraphvizState
gs { clusterColor :: ColorScheme
clusterColor = ColorScheme
cs }
                                           AttributeType
NodeAttribute     -> GraphvizState
gs { nodeColor :: ColorScheme
nodeColor    = ColorScheme
cs }
                                           AttributeType
EdgeAttribute     -> GraphvizState
gs { edgeColor :: ColorScheme
edgeColor    = ColorScheme
cs }

getColorScheme :: (GraphvizStateM m) => m ColorScheme
getColorScheme :: forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme = do AttributeType
tp <- forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS GraphvizState -> AttributeType
attributeType
                    forall (m :: * -> *) a.
GraphvizStateM m =>
(GraphvizState -> a) -> m a
getsGS forall a b. (a -> b) -> a -> b
$ case AttributeType
tp of
                               AttributeType
GraphAttribute    -> GraphvizState -> ColorScheme
graphColor
                                -- subgraphs don't have specified scheme
                               AttributeType
SubGraphAttribute -> GraphvizState -> ColorScheme
graphColor
                               AttributeType
ClusterAttribute  -> GraphvizState -> ColorScheme
clusterColor
                               AttributeType
NodeAttribute     -> GraphvizState -> ColorScheme
nodeColor
                               AttributeType
EdgeAttribute     -> GraphvizState -> ColorScheme
edgeColor

-- | The default separators for
--   'Data.GraphViz.Attributes.Complete.LayerSep'.
defLayerSep :: [Char]
defLayerSep :: String
defLayerSep = [Char
' ', Char
':', Char
'\t']

-- | The default separators for
--   'Data.GraphViz.Attributes.Complete.LayerListSep'.
defLayerListSep :: [Char]
defLayerListSep :: String
defLayerListSep = [Char
',']