module Text.Dot.Monad where

import "this" Prelude

import Control.Lens
import Control.Monad.RWS.Class
import Data.List.NonEmpty      qualified as NE

import Text.Dot.Types


--------------------------------------------------------------------------------
-- Dot monad

-- | Dot creation monad.
newtype DotT m a = DotT (DotGraph -> Path -> m (a, DotGraph))
  deriving
    ( (forall a b. (a -> b) -> DotT m a -> DotT m b)
-> (forall a b. a -> DotT m b -> DotT m a) -> Functor (DotT m)
forall a b. a -> DotT m b -> DotT m a
forall a b. (a -> b) -> DotT m a -> DotT m b
forall (m :: * -> *) a b. Functor m => a -> DotT m b -> DotT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DotT m a -> DotT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DotT m a -> DotT m b
fmap :: forall a b. (a -> b) -> DotT m a -> DotT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> DotT m b -> DotT m a
<$ :: forall a b. a -> DotT m b -> DotT m a
Functor
    , Functor (DotT m)
Functor (DotT m) =>
(forall a. a -> DotT m a)
-> (forall a b. DotT m (a -> b) -> DotT m a -> DotT m b)
-> (forall a b c.
    (a -> b -> c) -> DotT m a -> DotT m b -> DotT m c)
-> (forall a b. DotT m a -> DotT m b -> DotT m b)
-> (forall a b. DotT m a -> DotT m b -> DotT m a)
-> Applicative (DotT m)
forall a. a -> DotT m a
forall a b. DotT m a -> DotT m b -> DotT m a
forall a b. DotT m a -> DotT m b -> DotT m b
forall a b. DotT m (a -> b) -> DotT m a -> DotT m b
forall a b c. (a -> b -> c) -> DotT m a -> DotT m b -> DotT m c
forall (m :: * -> *). Monad m => Functor (DotT m)
forall (m :: * -> *) a. Monad m => a -> DotT m a
forall (m :: * -> *) a b.
Monad m =>
DotT m a -> DotT m b -> DotT m a
forall (m :: * -> *) a b.
Monad m =>
DotT m a -> DotT m b -> DotT m b
forall (m :: * -> *) a b.
Monad m =>
DotT m (a -> b) -> DotT m a -> DotT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DotT m a -> DotT m b -> DotT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> DotT m a
pure :: forall a. a -> DotT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
DotT m (a -> b) -> DotT m a -> DotT m b
<*> :: forall a b. DotT m (a -> b) -> DotT m a -> DotT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DotT m a -> DotT m b -> DotT m c
liftA2 :: forall a b c. (a -> b -> c) -> DotT m a -> DotT m b -> DotT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
DotT m a -> DotT m b -> DotT m b
*> :: forall a b. DotT m a -> DotT m b -> DotT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
DotT m a -> DotT m b -> DotT m a
<* :: forall a b. DotT m a -> DotT m b -> DotT m a
Applicative
    , Applicative (DotT m)
Applicative (DotT m) =>
(forall a b. DotT m a -> (a -> DotT m b) -> DotT m b)
-> (forall a b. DotT m a -> DotT m b -> DotT m b)
-> (forall a. a -> DotT m a)
-> Monad (DotT m)
forall a. a -> DotT m a
forall a b. DotT m a -> DotT m b -> DotT m b
forall a b. DotT m a -> (a -> DotT m b) -> DotT m b
forall (m :: * -> *). Monad m => Applicative (DotT m)
forall (m :: * -> *) a. Monad m => a -> DotT m a
forall (m :: * -> *) a b.
Monad m =>
DotT m a -> DotT m b -> DotT m b
forall (m :: * -> *) a b.
Monad m =>
DotT m a -> (a -> DotT m b) -> DotT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
DotT m a -> (a -> DotT m b) -> DotT m b
>>= :: forall a b. DotT m a -> (a -> DotT m b) -> DotT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
DotT m a -> DotT m b -> DotT m b
>> :: forall a b. DotT m a -> DotT m b -> DotT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> DotT m a
return :: forall a. a -> DotT m a
Monad
    , MonadReader Path
    , MonadState  DotGraph
    , Monad (DotT m)
Monad (DotT m) => (forall a. IO a -> DotT m a) -> MonadIO (DotT m)
forall a. IO a -> DotT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (DotT m)
forall (m :: * -> *) a. MonadIO m => IO a -> DotT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> DotT m a
liftIO :: forall a. IO a -> DotT m a
MonadIO
    , MonadWriter w
    , MonadError  e
    ) via (StateT DotGraph (ReaderT Path m))

instance MonadTrans DotT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> DotT m a
lift m a
x = (DotGraph -> Path -> m (a, DotGraph)) -> DotT m a
forall (m :: * -> *) a.
(DotGraph -> Path -> m (a, DotGraph)) -> DotT m a
DotT \DotGraph
s Path
_ -> (a -> (a, DotGraph)) -> m a -> m (a, DotGraph)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,DotGraph
s) m a
x

-- | An alias for @DotT Identity@.
type Dot = DotT Identity

-- | The constraint that all functions require.
--
-- We choose to express this as a constraint rather than a typeclass
-- for simplicity.
type MonadDot m = (MonadState DotGraph m, MonadReader Path m)

run :: Monad m => Entity -> DotT m a -> m DotGraph
run :: forall (m :: * -> *) a. Monad m => Entity -> DotT m a -> m DotGraph
run Entity
e (DotT DotGraph -> Path -> m (a, DotGraph)
f) = (a, DotGraph) -> DotGraph
forall a b. (a, b) -> b
snd ((a, DotGraph) -> DotGraph) -> m (a, DotGraph) -> m DotGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotGraph -> Path -> m (a, DotGraph)
f (Entity -> DotGraph
initialGraph Entity
e) (NonEmpty Entity -> Path
Path (NonEmpty Entity -> Path) -> NonEmpty Entity -> Path
forall a b. (a -> b) -> a -> b
$ Entity -> NonEmpty Entity
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity
e)


--------------------------------------------------------------------------------
-- State manipulation

-- | Retrieve the current path.
--
-- The path is the stack of entities, representing the graph /
-- subgraphs / clusters between the root of the graph and the current
-- location.
--
-- > graph do
-- >   p1 <- currentPath     -- returns [$graphID]
-- >   subgraph do
-- >     cluster do
-- >       p2 <- currentPath -- returns [$clusterID, $subgraphID, $graphID]
-- >       doStuff
currentPath :: MonadDot m => m (NonEmpty Entity)
currentPath :: forall (m :: * -> *). MonadDot m => m (NonEmpty Entity)
currentPath = (Path -> NonEmpty Entity) -> m (NonEmpty Entity)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Path -> NonEmpty Entity
unwrapPath

-- | Retrieves the unique ID of the last created t'Entity'.
itsID :: MonadDot m => m Entity
itsID :: forall (m :: * -> *). MonadDot m => m Entity
itsID = Getting Entity DotGraph Entity -> m Entity
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Entity DotGraph Entity
Lens' DotGraph Entity
latest

-- | Retrieves the unique ID of the top-level graph.
rootGraph :: MonadDot m => m Entity
rootGraph :: forall (m :: * -> *). MonadDot m => m Entity
rootGraph = LensLike' (Const Entity) Path (NonEmpty Entity)
-> (NonEmpty Entity -> Entity) -> m Entity
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const Entity) Path (NonEmpty Entity)
Iso' Path (NonEmpty Entity)
_Path NonEmpty Entity -> Entity
forall a. NonEmpty a -> a
NE.last

withPath :: MonadDot m => Entity -> m a -> m a
withPath :: forall (m :: * -> *) a. MonadDot m => Entity -> m a -> m a
withPath Entity
e = (Path -> Path) -> m a -> m a
forall a. (Path -> Path) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((NonEmpty Entity -> Identity (NonEmpty Entity))
-> Path -> Identity Path
Iso' Path (NonEmpty Entity)
_Path ((NonEmpty Entity -> Identity (NonEmpty Entity))
 -> Path -> Identity Path)
-> NonEmpty Entity -> Path -> Path
forall b s t. Semigroup b => ASetter s t b b -> b -> s -> t
<>:~ Entity -> NonEmpty Entity
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity
e)

context :: Lens' DotGraph DotContext
context :: Lens' DotGraph DotContext
context DotContext -> f DotContext
f DotGraph
d = (DotContext -> DotGraph) -> f DotContext -> f DotGraph
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DotContext -> DotGraph
go (DotContext -> f DotContext
f DotContext
c)
  where
    (DotContext
c :| [DotContext]
cs) = DotGraph
d DotGraph
-> Getting (NonEmpty DotContext) DotGraph (NonEmpty DotContext)
-> NonEmpty DotContext
forall s a. s -> Getting a s a -> a
^. Getting (NonEmpty DotContext) DotGraph (NonEmpty DotContext)
Lens' DotGraph (NonEmpty DotContext)
contextStack
    go :: DotContext -> DotGraph
go DotContext
nc = DotGraph
d DotGraph -> (DotGraph -> DotGraph) -> DotGraph
forall a b. a -> (a -> b) -> b
& (NonEmpty DotContext -> Identity (NonEmpty DotContext))
-> DotGraph -> Identity DotGraph
Lens' DotGraph (NonEmpty DotContext)
contextStack ((NonEmpty DotContext -> Identity (NonEmpty DotContext))
 -> DotGraph -> Identity DotGraph)
-> NonEmpty DotContext -> DotGraph -> DotGraph
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DotContext
nc DotContext -> [DotContext] -> NonEmpty DotContext
forall a. a -> [a] -> NonEmpty a
:| [DotContext]
cs

popContext :: MonadDot m => m DotContext
popContext :: forall (m :: * -> *). MonadDot m => m DotContext
popContext = do
  DotContext
c <- Getting DotContext DotGraph DotContext -> m DotContext
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting DotContext DotGraph DotContext
Lens' DotGraph DotContext
context
  (NonEmpty DotContext -> Identity (NonEmpty DotContext))
-> DotGraph -> Identity DotGraph
Lens' DotGraph (NonEmpty DotContext)
contextStack ((NonEmpty DotContext -> Identity (NonEmpty DotContext))
 -> DotGraph -> Identity DotGraph)
-> (NonEmpty DotContext -> NonEmpty DotContext) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [DotContext] -> NonEmpty DotContext
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([DotContext] -> NonEmpty DotContext)
-> (NonEmpty DotContext -> [DotContext])
-> NonEmpty DotContext
-> NonEmpty DotContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty DotContext -> [DotContext]
forall a. NonEmpty a -> [a]
NE.tail
  pure DotContext
c