{-# 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 = (GraphvizState -> GraphvizState) -> Parser GraphvizState ()
forall s. (s -> s) -> Parser s ()
stUpdate

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

data AttributeType = GraphAttribute
                   | SubGraphAttribute
                   | ClusterAttribute
                   | NodeAttribute
                   | EdgeAttribute
                     deriving (AttributeType -> AttributeType -> Bool
(AttributeType -> AttributeType -> Bool)
-> (AttributeType -> AttributeType -> Bool) -> Eq AttributeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeType -> AttributeType -> Bool
$c/= :: AttributeType -> AttributeType -> Bool
== :: AttributeType -> AttributeType -> Bool
$c== :: AttributeType -> AttributeType -> Bool
Eq, Eq AttributeType
Eq AttributeType =>
(AttributeType -> AttributeType -> Ordering)
-> (AttributeType -> AttributeType -> Bool)
-> (AttributeType -> AttributeType -> Bool)
-> (AttributeType -> AttributeType -> Bool)
-> (AttributeType -> AttributeType -> Bool)
-> (AttributeType -> AttributeType -> AttributeType)
-> (AttributeType -> AttributeType -> AttributeType)
-> Ord 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
$cp1Ord :: Eq AttributeType
Ord, Int -> AttributeType -> ShowS
[AttributeType] -> ShowS
AttributeType -> String
(Int -> AttributeType -> ShowS)
-> (AttributeType -> String)
-> ([AttributeType] -> ShowS)
-> Show AttributeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeType] -> ShowS
$cshowList :: [AttributeType] -> ShowS
show :: AttributeType -> String
$cshow :: AttributeType -> String
showsPrec :: Int -> AttributeType -> ShowS
$cshowsPrec :: Int -> AttributeType -> ShowS
Show, ReadPrec [AttributeType]
ReadPrec AttributeType
Int -> ReadS AttributeType
ReadS [AttributeType]
(Int -> ReadS AttributeType)
-> ReadS [AttributeType]
-> ReadPrec AttributeType
-> ReadPrec [AttributeType]
-> Read 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
(GraphvizState -> GraphvizState -> Bool)
-> (GraphvizState -> GraphvizState -> Bool) -> Eq GraphvizState
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
Eq GraphvizState =>
(GraphvizState -> GraphvizState -> Ordering)
-> (GraphvizState -> GraphvizState -> Bool)
-> (GraphvizState -> GraphvizState -> Bool)
-> (GraphvizState -> GraphvizState -> Bool)
-> (GraphvizState -> GraphvizState -> Bool)
-> (GraphvizState -> GraphvizState -> GraphvizState)
-> (GraphvizState -> GraphvizState -> GraphvizState)
-> Ord 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
$cp1Ord :: Eq GraphvizState
Ord, Int -> GraphvizState -> ShowS
[GraphvizState] -> ShowS
GraphvizState -> String
(Int -> GraphvizState -> ShowS)
-> (GraphvizState -> String)
-> ([GraphvizState] -> ShowS)
-> Show GraphvizState
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]
(Int -> ReadS GraphvizState)
-> ReadS [GraphvizState]
-> ReadPrec GraphvizState
-> ReadPrec [GraphvizState]
-> Read 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 = $WGS :: Bool
-> Bool
-> String
-> String
-> AttributeType
-> ColorScheme
-> ColorScheme
-> ColorScheme
-> ColorScheme
-> GraphvizState
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 :: Bool -> m ()
setDirectedness d :: Bool
d = (GraphvizState -> GraphvizState) -> m ()
forall (m :: * -> *).
GraphvizStateM m =>
(GraphvizState -> GraphvizState) -> m ()
modifyGS (\ gs :: GraphvizState
gs -> GraphvizState
gs { directedEdges :: Bool
directedEdges = Bool
d } )

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

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

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

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

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

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

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

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

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

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

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