{-# LANGUAGE
    GeneralizedNewtypeDeriving
  , DeriveFunctor
  , DeriveGeneric
  , NamedFieldPuns
  , FlexibleInstances
  , UndecidableInstances
  , MultiParamTypeClasses
  , TypeFamilies
  #-}

module Web.Dependencies.Sparrow.Client.Types where

import Web.Dependencies.Sparrow.Types (WSIncoming, WithTopic, Topic)

import Data.Aeson (Value)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Control.Monad.Reader (ReaderT (..), MonadReader (..))
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Writer (MonadWriter)
import Control.Monad.State (MonadState)
import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, Exception)
import Control.Concurrent.STM (STM, atomically, TVar, readTVar, modifyTVar')
import Control.Concurrent.STM.TMapMVar (TMapMVar)
import qualified Control.Concurrent.STM.TMapMVar as TMapMVar
import GHC.Generics (Generic)


-- data ClientRefs m = ClientRefs
--   { clientContinue :: Maybe Value {-initOut-} -> m ()
--   }

type RegisteredTopicSubscriptions m =
  TMapMVar Topic
    ( Value -> m () -- `deltaOut` received from init
    , m () -- onReject
    )


registerSubscription :: Env m -> Topic -> (Value -> m ()) -> m () -> STM ()
registerSubscription Env{envSubscriptions} topic onDeltaOut onReject =
  TMapMVar.insert envSubscriptions topic (onDeltaOut,onReject)

removeSubscription :: Env m -> Topic -> STM ()
removeSubscription Env{envSubscriptions} =
  TMapMVar.delete envSubscriptions

callReject :: MonadIO m => Env m -> Topic -> m ()
callReject Env{envSubscriptions} topic = do
  (_,onReject) <- liftIO $ atomically $ TMapMVar.lookup envSubscriptions topic
  onReject

callOnReceive :: MonadIO m => Env m -> Topic -> Value -> m ()
callOnReceive Env{envSubscriptions} topic v = do
  (onReceive,_) <- liftIO $ atomically $ TMapMVar.observe envSubscriptions topic
  onReceive v


data Env m = Env
  { envSendDelta     :: WSIncoming (WithTopic Value) -> m ()
  , envSendInit      :: Topic -> Value -> m (Maybe Value)
  , envSubscriptions :: {-# UNPACK #-} !(RegisteredTopicSubscriptions m)
  }


newtype SparrowClientT m a = SparrowClientT
  { runSparrowClientT :: ReaderT (Env m) m a
  } deriving (Functor, Applicative, Monad, MonadIO, MonadWriter w, MonadState s, MonadCatch, MonadThrow, MonadMask)

instance MonadReader r m => MonadReader r (SparrowClientT m) where
  ask = lift ask
  local f (SparrowClientT (ReaderT x)) = SparrowClientT $ ReaderT $ \r -> local f (x r)

instance MonadTrans SparrowClientT where
  lift = SparrowClientT . lift


data SparrowClientException
  = InitOutFailed
  | InitOutDecodingError String
  | DeltaOutDecodingError String
  | InitOutHTTPError
  | UnexpectedAddedTopic Topic
  | UnexpectedRemovedTopic Topic
  | NetworkingDecodingError String
  deriving (Show, Generic)

instance Exception SparrowClientException


ask' :: Applicative m => SparrowClientT m (Env m)
ask' = SparrowClientT (ReaderT pure)