{-# 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.Applicative
import Control.Monad.State
import Data.Foldable                                    ( toList )
import Data.Sequence                                    ( Seq )
import System.Mem.StableName
import Prelude
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    = StateT DotState IO a
data DotState = DotState
  { DotState -> Int
fresh       :: !Int
  , DotState -> Seq Graph
dotGraph    :: Seq Graph
  , DotState -> Seq Edge
dotEdges    :: Seq Edge
  , DotState -> Seq Node
dotNodes    :: Seq Node
  }

emptyState :: DotState
emptyState :: DotState
emptyState =  Int -> Seq Graph -> Seq Edge -> Seq Node -> DotState
DotState 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 -> IO (a, DotState)
runDot :: Dot a -> IO (a, DotState)
runDot Dot a
dot = Dot a -> DotState -> IO (a, DotState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Dot a
dot DotState
emptyState

evalDot :: Dot a -> IO a
evalDot :: Dot a -> IO a
evalDot Dot a
dot = (a, DotState) -> a
forall a b. (a, b) -> a
fst ((a, DotState) -> a) -> IO (a, DotState) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dot a -> IO (a, DotState)
forall a. Dot a -> IO (a, DotState)
runDot Dot a
dot

execDot :: Dot a -> IO DotState
execDot :: Dot a -> IO DotState
execDot Dot a
dot = (a, DotState) -> DotState
forall a b. (a, b) -> b
snd ((a, DotState) -> DotState) -> IO (a, DotState) -> IO DotState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dot a -> IO (a, DotState)
forall a. Dot a -> IO (a, DotState)
runDot Dot a
dot


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

mkLabel :: Dot Label
mkLabel :: Dot Label
mkLabel = (DotState -> (Label, DotState)) -> Dot Label
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
fresh 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 { fresh :: Int
fresh = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } )

mkNodeId :: a -> Dot NodeId
mkNodeId :: a -> Dot NodeId
mkNodeId a
node = do
  StableName a
sn    <- IO (StableName a) -> StateT DotState IO (StableName a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (StableName a) -> StateT DotState IO (StableName a))
-> IO (StableName a) -> StateT DotState IO (StableName a)
forall a b. (a -> b) -> a -> b
$ a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName a
node
  NodeId -> Dot NodeId
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeId -> Dot NodeId) -> NodeId -> Dot NodeId
forall a b. (a -> b) -> a -> b
$ Int -> NodeId
NodeId (StableName a -> Int
forall a. StableName a -> Int
hashStableName StableName a
sn)

mkGraph :: Dot Graph
mkGraph :: Dot Graph
mkGraph =
  (DotState -> (Graph, DotState)) -> Dot Graph
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
dotNodes :: Seq Node
dotEdges :: Seq Edge
dotGraph :: Seq Graph
fresh :: Int
dotNodes :: DotState -> Seq Node
dotEdges :: DotState -> Seq Edge
dotGraph :: DotState -> Seq Graph
fresh :: DotState -> Int
..} ->
    ( Label -> [Statement] -> Graph
Graph Label
forall a. Monoid a => a
mempty (Seq Statement -> [Statement]
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 (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Graph -> Statement
G Seq Graph
dotGraph)
    , DotState
emptyState { fresh :: Int
fresh = Int
fresh }
    )

mkSubgraph :: Dot Graph -> Dot Graph
mkSubgraph :: Dot Graph -> Dot Graph
mkSubgraph Dot Graph
g = do
  Int
n       <- (DotState -> Int) -> StateT DotState IO Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DotState -> Int
fresh
  (Graph
r, DotState
s') <- IO (Graph, DotState) -> StateT DotState IO (Graph, DotState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Graph, DotState) -> StateT DotState IO (Graph, DotState))
-> (Dot Graph -> IO (Graph, DotState))
-> Dot Graph
-> StateT DotState IO (Graph, DotState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot Graph -> IO (Graph, DotState)
forall a. Dot a -> IO (a, DotState)
runDot (Dot Graph -> StateT DotState IO (Graph, DotState))
-> Dot Graph -> StateT DotState IO (Graph, DotState)
forall a b. (a -> b) -> a -> b
$ do
    (DotState -> DotState) -> StateT DotState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DotState -> DotState) -> StateT DotState IO ())
-> (DotState -> DotState) -> StateT DotState IO ()
forall a b. (a -> b) -> a -> b
$ \DotState
s -> DotState
s { fresh :: Int
fresh = Int
n }
    Dot Graph
g
  (DotState -> (Graph, DotState)) -> Dot Graph
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 { fresh :: Int
fresh = DotState -> Int
fresh DotState
s' })