module Dingo.Internal.SessionTypes
       ( SessionState
       , SessionT(..)
       , addWidget
       , getWidgetStateM
       , lookupCallback
       , lookupResource
       , mkSessionState
       , newCallbackId
       , newWidgetId
       , registerCallback
       , registerResourceBundle
       , registerWidgetType
       , runSessionT
       , setWidgetStateM
       -- Accessors:
       , callbackCounter
       , widgetCounter
       , widgetSet
       ) where

import           Control.Monad (liftM, unless)
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.State.Strict (StateT, runStateT)
import           Data.ByteString (ByteString)
import           Data.Label (mkLabels, (:->))
import qualified Data.Label as L
import           Data.Label.PureM (gets, puts, modify)
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Monoid (mappend)
import           Data.Set (Set)
import qualified Data.Set as S
import           Data.Text (Text)
import           Dingo.Internal.Base (CallbackId, WidgetId, succCallbackId, succWidgetId, zeroCallbackId, zeroWidgetId)
import           Dingo.Internal.ResourceBundle.Internal (ResourceBundle, ResourceBundleSet, elemResourceBundleSet, findResourceInBundleSet, resourceBundleSetFromList)
import           Dingo.Internal.TypeableShim (TypeId)
import           Dingo.Internal.WidgetSet (WidgetSet, emptyWidgetSet, setWidgetState, getWidgetState)
import           Dingo.Internal.WidgetTypes (Widget)

-- Generalized session state with a user-defined callback
-- type.
data SessionState c =
  SessionState { _callbackCounter :: CallbackId
               , _widgetCounter :: WidgetId
               , _sessionCallbacks :: Map CallbackId c
               , _widgetSet :: WidgetSet
               , _widgetTypeSet :: Set TypeId
               , _resourceBundleSet :: ResourceBundleSet
               }

-- Define the session monad transformer.
newtype SessionT c m a = SessionT { unSession :: Session c m a }
    deriving (Functor, Monad)

-- Session base type.
type Session c = StateT (SessionState c)

-- Generate accessors.
$(mkLabels [''SessionState])

-- Empty session state.
mkSessionState :: c -> [ResourceBundle] -> SessionState c
mkSessionState c0 bootResourceBundles =
  -- We use successors as starting IDs to accomodate the bootstrap HTML and callback.
  SessionState cid1 wid1 bootstrapCallbacks emptyWidgetSet S.empty $ resourceBundleSetFromList bootResourceBundles
  where
    wid0 = zeroWidgetId  -- Pre-rendered main widget.
    wid1 = succWidgetId wid0
    cid0 = zeroCallbackId
    cid1 = succCallbackId cid0
    bootstrapCallbacks = M.singleton cid0 c0

-- SessionT is a monad transformer.
instance MonadTrans (SessionT c) where
   lift m = SessionT $ lift m

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

-- Run a SessionT computation.
runSessionT :: Monad m => SessionState c -> SessionT c m a -> m (a, SessionState c)
runSessionT s0 (SessionT s) = runStateT s s0

-- Increment a label value, returning the old value.
freshIdentifier :: Monad m => (a -> a) -> (SessionState c :-> a) -> SessionT c m a
freshIdentifier succ_ label = SessionT $ do
  i <- gets label
  puts label $ succ_ i
  return i

-- Generate a fresh callback ID.
newCallbackId :: Monad m => SessionT c m CallbackId
newCallbackId = freshIdentifier succCallbackId callbackCounter

-- Generate a fresh widget ID.
newWidgetId :: Monad m => SessionT c m WidgetId
newWidgetId = freshIdentifier succWidgetId widgetCounter

-- Register a callback in the session.
registerCallback :: Monad m => c -> SessionT c m CallbackId
registerCallback callback = SessionT $ do
  callbackId <- unSession newCallbackId
  -- Update the set of callbacks.
  modify sessionCallbacks (M.insertWith' const callbackId callback)
  -- Return the allocated callback ID.
  return callbackId

-- Check if a widget type is registered in the session,
-- and register it if not. Returns
-- true iff the bundle was not previously registered.
registerWidgetType :: (Monad m, Functor m) => TypeId -> SessionT c m Bool
registerWidgetType widgetTypeId = SessionT $ do
  e <- fmap (S.member widgetTypeId) $ gets widgetTypeSet
  unless e $ modify widgetTypeSet $ S.insert widgetTypeId
  return $ not e

-- Register a resource bundle in the session. Returns
-- true iff the bundle was not previously registered.
registerResourceBundle :: (Monad m, Functor m) => ResourceBundle -> SessionT c m Bool
registerResourceBundle resourceBundle = SessionT $ do
  e <- fmap (elemResourceBundleSet resourceBundle) $ gets resourceBundleSet
  unless e $ modify resourceBundleSet (\x -> mappend x (resourceBundleSetFromList [resourceBundle]))
  return $ not e

-- Look a resource up in the session.
lookupResource :: Text -> [Text] -> SessionState c -> Maybe ByteString
lookupResource bundleId path sessionState =
  findResourceInBundleSet bundleId path r
  where
    r = L.get resourceBundleSet sessionState

-- Look a callback up in the session.
lookupCallback :: (Monad m) => CallbackId -> SessionT c m (Maybe c)
lookupCallback callbackId = SessionT $ liftM (M.lookup callbackId) $ gets sessionCallbacks

-- Create a new widget with the given construction function.
addWidget :: Widget w s => (WidgetId -> SessionT b IO ((w, s), a)) -> SessionT b IO ((w, s), a)
addWidget f = do
  widgetId <- newWidgetId                          -- Fresh ID
  ((c,s),a) <- f widgetId                          -- Construct
  SessionT $ modify widgetSet (setWidgetState c s)   -- Register
  return ((c,s),a)

-- Get the current widget state.
getWidgetStateM :: (Monad m, Widget w s) => w -> SessionT b m (Maybe s)
getWidgetStateM c = SessionT $ do
  cs <- gets widgetSet
  return $ getWidgetState cs c

-- Set the current widget state.
setWidgetStateM :: (Monad m, Widget w s) => w -> s -> SessionT b m ()
setWidgetStateM c s = SessionT $ modify widgetSet (setWidgetState c s)