PartyT

{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude,
    RankNTypes, RecursiveDo, TupleSections, TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Magus.Party where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Either
import Data.Eq
import Data.Function (const, id, flip, ($), (.))
import Data.Functor ((<$>), (<&>), ($>))
import Data.Int
import Data.Maybe
import Data.Map (Map, singleton)
import Data.Tuple (fst, uncurry)
import Discord (
    Snowflake, Gateway, ThreadIdType, RestChan
  , RestCallException, UserRequest(CreateDM, GetUser)
  , restCall
  )
import Prelude ((+))
import Reflex
import System.IO (IO)

import qualified Data.Map as M
import Magus.Types
import qualified Prelude as P

type DLogin = (RestChan, Gateway, [ThreadIdType])

newtype PartyT t m a = PartyT
  { runPartyT
  :: Behavior t Int
  -> Event t (Map Int (Snowflake, Either RestCallException Player))
  -> m (a, Event t (Map Int Snowflake))
  }
  -- deriving (Functor, Applicative, Monad, MonadFix, MonadIO) --, MonadException, MonadAsyncException)

runPartyD :: forall t m w a.
  ( Reflex t
  , Monad m
  , MonadFix m
  , MonadHold t m
  , PerformEvent t m
  , MonadIO (Performable m)
  ) => DLogin
    -> PartyT t m a
    -> m a
runPartyD dis w = mdo
  d_id <- count e_w

  performEvent $ e_w  <&> \x -> liftIO $ P.putStrLn $ P.show x
  performEvent $ e_kp <&> \x -> liftIO $ P.putStrLn $ P.show x

  (x, e_w) <- runPartyT w (current d_id) e_kp -- PartyT e w
  -- x <- runPartyT w b_id e_kp -- PartyT e w
  -- let e_w = never
  -- (x, e_w) <- runEventWriterT $ runPartyT w b_id e_kp -- PartyT e w

  -- (x, e_w) <- runEventWriterT $ runPartyT w b_id e_kp -- PartyT e w
  -- ((x, e), e_w) <- runPartyT w b_id e_kp -- PartyT e w
  -- (x, e_w) <- runPartyT w b_id e_kp -- PartyT e w
  -- let e :: Event t (Int, Either RestCallException (Snowflake, Player)) = e_w
  -- tag e_w
  -- (f_p, e_kp) <- fmap fanEither .
  e_kp :: Event t (Map Int (Snowflake, Either RestCallException Player)) <- performEvent $ e_w <&> \xs ->
    forM xs $ \k -> do
      ep <- liftIO $ fetchParticipant dis k
      pure $ (k, ep)

  -- e <- requestParticipantCache dis e_w
  pure x


mapPartyT :: (m (a, Event t (Map Int Snowflake)) -> n (b, Event t (Map Int Snowflake))) -> PartyT t m a -> PartyT t n b
-- mapPartyT :: (m a -> n b) -> PartyT t m a -> PartyT t n b
mapPartyT f m = PartyT $ \b e -> f $ runPartyT m b e
{-# INLINE mapPartyT #-}

liftPartyT :: (Reflex t, Monad m) => m a -> PartyT t m a
-- liftPartyT m = PartyT $ (const . const) m
-- liftPartyT m = PartyT . lift
liftPartyT m = PartyT $ \b e -> (, never) <$> m
{-# INLINE liftPartyT #-}

instance (Functor m) => Functor (PartyT t m) where
  fmap f = mapPartyT $ fmap $ \ ~(a, e) -> (f a, e)
  -- fmap f = mapPartyT $ fmap $ \ ~a -> f a
  {-# INLINE fmap #-}

instance (Monad m, Reflex t, Applicative m) => Applicative (PartyT t m) where
  pure = lift . pure
  {-# INLINE pure #-}
  f <*> v = PartyT $ \b e -> liftA2 k (runPartyT f b e) (runPartyT v b e)
    -- where k ~(a, e) ~(b, e') = (a b, leftmost [e, e'])
    where k ~(a, e) ~(b, e') = (a b, e `P.mappend` e')

-- | CHECK
instance (Monad m, Reflex t, Alternative m) => Alternative (PartyT t m) where
    empty = liftPartyT empty
    {-# INLINE empty #-}
    m <|> n = PartyT $ \b e -> runPartyT m b e <|> runPartyT n b e
    {-# INLINE (<|>) #-}

instance (Monad m, Reflex t) => Monad (PartyT t m) where
  return = lift . return
  {-# INLINE return #-}
  m >>= k  = PartyT $ \b e -> do
      (~a, e_w) <- runPartyT m b e
      -- ~a <- runPartyT m b e
      runPartyT (k a) b e
      -- P.undefined
      -- return b
  {-# INLINE (>>=) #-}
  fail msg = lift $ fail msg
  {-# INLINE fail #-}

instance (Reflex t, MonadPlus m) => MonadPlus (PartyT t m) where
  mzero       = lift mzero
  {-# INLINE mzero #-}
  m `mplus` n = PartyT $ \dis d_m -> runPartyT m dis d_m `mplus` runPartyT n dis d_m
  {-# INLINE mplus #-}

instance Reflex t => MonadTrans (PartyT t) where
  lift = liftPartyT
  -- -- lift = liftPartyT
  -- -- lift = PartyT . lift
  -- {-# INLINE lift #-}

instance (Reflex t, MonadIO m) => MonadIO (PartyT t m) where
  liftIO = lift . liftIO
  {-# INLINE liftIO #-}

instance (MonadSample t m, Reflex t) => MonadSample t (PartyT t m) where
  sample = lift . sample

instance (MonadHold t m, Reflex t) => MonadHold t (PartyT t m) where
  hold a0 = lift . hold a0
  holdDyn a0 = lift . holdDyn a0
  holdIncremental a0 = lift . holdIncremental a0
  buildDynamic a0 = lift . buildDynamic a0
  headE = lift . headE

instance (MonadFix m, Reflex t) => MonadFix (PartyT t m) where
    -- mfix f = PartyT $ \b e -> mfix $ \a -> runPartyT (f a) b e
    mfix f = PartyT $ \b e -> mfix $ \ ~(a, _) -> runPartyT (f a) b e
    {-# INLINE mfix #-}

instance (PerformEvent t m, Reflex t) => PerformEvent t (PartyT t m) where
  -- type Performable (PartyT t m) = PartyT t (Performable m)
  type Performable (PartyT t m) = Performable m
  performEvent_ = lift . performEvent_
  performEvent  = lift . performEvent

instance (Reflex t, TriggerEvent t m) => TriggerEvent t (PartyT t m) where
  newTriggerEvent = lift newTriggerEvent
  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

instance PostBuild t m => PostBuild t (PartyT t m) where
  getPostBuild = lift getPostBuild


-- | Party
class DiscordParty t m where
  -- TODO Accept multiple Snowflakes
  invite ::
       Event t Snowflake
    -- -> m (Event t (Snowflake, Either RestCallException Player))
    -> m (Event t (Map Snowflake (Either RestCallException Player)))

type FetchConstraints t m =
  ( MonadHold t m
  , MonadIO m
  , MonadIO (Performable m)
  , PerformEvent t m
  )

instance (FetchConstraints t m, MonadFix m) => DiscordParty t (PartyT t m) where
-- instance (FetchConstraints t m, MonadFix m, EventWriter t Snowflake (PartyT t m)) => DiscordParty t (PartyT t m) where
  invite e_k = do
    -- tellEvent e_k
    -- performEvent $ e_k <&> \x -> do
    --   liftIO $ P.putStrLn $ P.show x

    PartyT $ \b_id e_res -> do
      let e_i = attach b_id e_k
      b_k <- hold 0 (fst <$> traceEvent "ID" e_i)
      let e_r = attachWith (,) b_k e_res
      -- pure $ Reflex.mapMaybe (\(i, (k, s, p)) -> if i == k then Just (s, p) else Nothing) e_r
      -- pure $ (Reflex.mapMaybe (\(i, (k, s, p)) -> if i == k then Just (s, p) else Nothing) e_r, e_i)

      let x :: (Event t (Snowflake, Either RestCallException Player), Event t (Int, Snowflake))
            = (Reflex.mapMaybe (\(i, xs) -> M.lookup i xs) e_r, e_i)
      pure $ (Reflex.mapMaybe (\(i, xs) -> uncurry singleton <$> M.lookup i xs) e_r, traceEvent "MAP" (uncurry singleton <$> e_i))

fetchParticipant ::
       (RestChan, Gateway, [ThreadIdType])
    -> Snowflake
    -> IO (Either RestCallException Player)
fetchParticipant dis i = do
  eu <- restCall dis (GetUser i)
  ec <- restCall dis (CreateDM i)
  pure $ Player <$> eu <*> ec



-- fetchParticipantEvent ::
--   ( FetchConstraints t m
--   ) => (RestChan, Gateway, [ThreadIdType])
--     -> Event t Snowflake
--     -> m (Event t (Either RestCallException Player))
-- fetchParticipantEvent dis e = performEvent $ liftIO . fetchParticipant dis <$> e

-- requestParticipantCache :: forall t m.
--   ( FetchConstraints t m
--   , MonadFix m
--   ) => (RestChan, Gateway, [ThreadIdType])
--     -> Event t Snowflake
--     -> m (Event t (Snowflake, Player))
-- -- requestParticipantCache dis d_m e = do
-- requestParticipantCache dis e = mdo
--   let e_mp = attachWith (\m i -> (i, M.lookup i m)) (current d_m) e

--   (f_p, e_kp) <- fmap fanEither . performEvent $ e_mp <&> \(i, mp) -> case mp of
--     Nothing -> do
--       liftIO $ P.putStrLn "Nothing..."
--       ep <- liftIO $ fetchParticipant dis i
--       pure $ (i,) <$> ep
--     -- TODO Rid of unnecessary inserts
--     Just p  -> do
--       liftIO $ P.putStrLn "JUST!!!!"
--       pure $ pure (i, p)

--   performEvent $ e_kp <&> (liftIO . P.putStrLn . P.show)
--   performEvent $ f_p <&> (liftIO . P.putStrLn . P.show)

--   d_m <- accumDyn (\m (i, p) -> M.insert i p m) M.empty e_kp

--   pure e_kp