module Dingo.Internal.CallbackTypes
       ( CallbackState
       , CallbackM
       , CallbackT(..)
       , WrapCallback(..)
       , addCommand
       , augmentState
       , getCommands
       , mkSession
       , runCallbackT
       ) where

import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.State.Strict (StateT, runStateT)
import qualified Control.Monad.Trans.State.Strict as MTS
import qualified Data.Label as L
import           Data.Label.PureM (modify)
import           Data.Monoid (Monoid(..))
import           Data.Sequence (Seq, (|>))
import qualified Data.Sequence as S
import           Dingo.Internal.Base (Command(..))
import           Dingo.Internal.SessionTypes
import           Dingo.ResourceBundle (ResourceBundle)

-- Wrapper type to avoid cyclic type definition.
data WrapCallback = WrapCallback { unWrapCallback :: CallbackM () }

-- Define the session state.
data CallbackState =
  CallbackState { _csCommands :: Seq Command
                }

-- Callback state is a monoid.
instance Monoid CallbackState where
  mempty = CallbackState S.empty
  mappend (CallbackState s1) (CallbackState s2) = CallbackState $ s1 `mappend` s2

-- Define the monad transformer.
newtype CallbackT m a = CallbackT { unCallback :: StateT CallbackState m a }
    deriving (Functor, Monad)

-- CallbackT is a monad transformer.
instance MonadTrans CallbackT where
   lift m = CallbackT $ lift m

-- CallbackT where the underlying monad is a MonadIO is also a MonadIO.
instance (MonadIO m) => MonadIO (CallbackT m) where
  liftIO = lift . liftIO

-- Type alias for convenience.
type CallbackM = CallbackT (SessionT WrapCallback IO)

-- Generate accessors.
$(L.mkLabels [''CallbackState])

-- Create an empty session state.
mkSession :: CallbackM () -> [ResourceBundle] -> SessionState WrapCallback
mkSession main = mkSessionState (WrapCallback main)

-- Sort the stream of commands appropriately.
getCommands :: CallbackState -> Seq Command
getCommands = L.get csCommands

-- Run a callback computation and return the stream of commands
-- to send to the browser.
runCallbackT :: Monad m => CallbackT m a -> m (a, CallbackState)
runCallbackT (CallbackT callback) = runStateT callback mempty

-- Add a command to the callback.
addCommand :: Monad m => Command -> CallbackT m ()
addCommand command = CallbackT $ modify csCommands (|> command)

-- Augment state with a different callback state.
augmentState :: Monad m => CallbackState -> CallbackT m ()
augmentState st = CallbackT $ MTS.modify $ \s -> s `mappend` st