{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-- |
-- Module      : Data.Array.Accelerate.Pretty.Graphviz.Monad
-- Copyright   : [2015..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
module Data.Array.Accelerate.Pretty.Graphviz.Monad
  where

import Control.Monad.State
import Data.Foldable                                    ( toList )
import Data.Sequence                                    ( Seq )
import qualified Data.Sequence                          as Seq
import qualified Data.Text                              as Text

import Data.Array.Accelerate.Pretty.Graphviz.Type


-- Graph construction state ----------------------------------------------------

type Dot a    = State DotState a
data DotState = DotState
  { DotState -> Int
freshLabel  :: !Int
  , DotState -> Int
freshID     :: !Int  -- keep internal node ids in a separate counter from the user-visible node labels
  , DotState -> Seq Graph
dotGraph    :: Seq Graph
  , DotState -> Seq Edge
dotEdges    :: Seq Edge
  , DotState -> Seq Node
dotNodes    :: Seq Node
  }

emptyState :: DotState
emptyState :: DotState
emptyState =  Int -> Int -> Seq Graph -> Seq Edge -> Seq Node -> DotState
DotState Int
0 Int
0 Seq Graph
forall a. Seq a
Seq.empty Seq Edge
forall a. Seq a
Seq.empty Seq Node
forall a. Seq a
Seq.empty

runDot :: Dot a -> (a, DotState)
runDot :: forall a. Dot a -> (a, DotState)
runDot Dot a
dot = Dot a -> DotState -> (a, DotState)
forall s a. State s a -> s -> (a, s)
runState Dot a
dot DotState
emptyState

evalDot :: Dot a -> a
evalDot :: forall a. Dot a -> a
evalDot Dot a
dot = (a, DotState) -> a
forall a b. (a, b) -> a
fst (Dot a -> (a, DotState)
forall a. Dot a -> (a, DotState)
runDot Dot a
dot)

execDot :: Dot a -> DotState
execDot :: forall a. Dot a -> DotState
execDot Dot a
dot = (a, DotState) -> DotState
forall a b. (a, b) -> b
snd (Dot a -> (a, DotState)
forall a. Dot a -> (a, DotState)
runDot Dot a
dot)


-- Utilities -------------------------------------------------------------------

mkLabel :: Dot Label
mkLabel :: Dot Label
mkLabel = (DotState -> (Label, DotState)) -> Dot Label
forall a. (DotState -> (a, DotState)) -> StateT DotState Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((DotState -> (Label, DotState)) -> Dot Label)
-> (DotState -> (Label, DotState)) -> Dot Label
forall a b. (a -> b) -> a -> b
$ \DotState
s ->
  let n :: Int
n = DotState -> Int
freshLabel DotState
s
  in  ( String -> Label
Text.pack (Char
'a' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n), DotState
s { freshLabel :: Int
freshLabel = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } )

genNodeId :: Dot NodeId
genNodeId :: Dot NodeId
genNodeId = (DotState -> (NodeId, DotState)) -> Dot NodeId
forall a. (DotState -> (a, DotState)) -> StateT DotState Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((DotState -> (NodeId, DotState)) -> Dot NodeId)
-> (DotState -> (NodeId, DotState)) -> Dot NodeId
forall a b. (a -> b) -> a -> b
$ \DotState
s ->
  let n :: Int
n = DotState -> Int
freshID DotState
s
  in  ( Int -> NodeId
NodeId Int
n, DotState
s { freshID :: Int
freshID = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } )

mkGraph :: Dot Graph
mkGraph :: Dot Graph
mkGraph =
  (DotState -> (Graph, DotState)) -> Dot Graph
forall a. (DotState -> (a, DotState)) -> StateT DotState Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((DotState -> (Graph, DotState)) -> Dot Graph)
-> (DotState -> (Graph, DotState)) -> Dot Graph
forall a b. (a -> b) -> a -> b
$ \DotState{Int
Seq Edge
Seq Node
Seq Graph
freshLabel :: DotState -> Int
freshID :: DotState -> Int
dotGraph :: DotState -> Seq Graph
dotEdges :: DotState -> Seq Edge
dotNodes :: DotState -> Seq Node
freshLabel :: Int
freshID :: Int
dotGraph :: Seq Graph
dotEdges :: Seq Edge
dotNodes :: Seq Node
..} ->
    ( Label -> [Statement] -> Graph
Graph Label
forall a. Monoid a => a
mempty (Seq Statement -> [Statement]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Statement -> [Statement]) -> Seq Statement -> [Statement]
forall a b. (a -> b) -> a -> b
$ (Node -> Statement) -> Seq Node -> Seq Statement
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Statement
N Seq Node
dotNodes Seq Statement -> Seq Statement -> Seq Statement
forall a. Seq a -> Seq a -> Seq a
Seq.>< (Edge -> Statement) -> Seq Edge -> Seq Statement
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Edge -> Statement
E Seq Edge
dotEdges Seq Statement -> Seq Statement -> Seq Statement
forall a. Seq a -> Seq a -> Seq a
Seq.>< (Graph -> Statement) -> Seq Graph -> Seq Statement
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Graph -> Statement
G Seq Graph
dotGraph)
    , DotState
emptyState { freshLabel :: Int
freshLabel = Int
freshLabel }
    )

mkSubgraph :: Dot Graph -> Dot Graph
mkSubgraph :: Dot Graph -> Dot Graph
mkSubgraph Dot Graph
g = do
  Int
n       <- (DotState -> Int) -> StateT DotState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DotState -> Int
freshLabel
  let (Graph
r, DotState
s') = Dot Graph -> (Graph, DotState)
forall a. Dot a -> (a, DotState)
runDot (Dot Graph -> (Graph, DotState)) -> Dot Graph -> (Graph, DotState)
forall a b. (a -> b) -> a -> b
$ do
        (DotState -> DotState) -> StateT DotState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DotState -> DotState) -> StateT DotState Identity ())
-> (DotState -> DotState) -> StateT DotState Identity ()
forall a b. (a -> b) -> a -> b
$ \DotState
s -> DotState
s { freshLabel :: Int
freshLabel = Int
n }
        Dot Graph
g
  (DotState -> (Graph, DotState)) -> Dot Graph
forall a. (DotState -> (a, DotState)) -> StateT DotState Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((DotState -> (Graph, DotState)) -> Dot Graph)
-> (DotState -> (Graph, DotState)) -> Dot Graph
forall a b. (a -> b) -> a -> b
$ \DotState
s -> (Graph
r, DotState
s { freshLabel :: Int
freshLabel = DotState -> Int
freshLabel DotState
s' })