{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Morpheus.Types.Internal.Resolving.Core
  ( Eventless,
    Result (..),
    Failure (..),
    ResultT (..),
    unpackEvents,
    LibUpdater,
    resolveUpdates,
    mapEvent,
    cleanEvents,
    Event (..),
    Channel (..),
    GQLChannel (..),
    PushEvents (..),
    statelessToResultT,
    resultOr,
  )
where

import Control.Applicative (liftA2)
import Control.Monad (foldM)
import Control.Monad.Trans.Class (MonadTrans (..))
import Data.Function ((&))
import Data.Morpheus.Internal.Utils
  ( Failure (..),
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( GQLError (..),
    GQLErrors,
    Message,
  )
import Data.Semigroup ((<>))

type Eventless = Result ()

-- EVENTS
class PushEvents e m where
  pushEvents :: [e] -> m ()

-- Channel
newtype Channel event = Channel
  { _unChannel :: StreamChannel event
  }

instance (Eq (StreamChannel event)) => Eq (Channel event) where
  Channel x == Channel y = x == y

class GQLChannel a where
  type StreamChannel a :: *
  streamChannels :: a -> [Channel a]

instance GQLChannel () where
  type StreamChannel () = ()
  streamChannels _ = []

instance GQLChannel (Event channel content) where
  type StreamChannel (Event channel content) = channel
  streamChannels Event {channels} = map Channel channels

data Event e c = Event
  {channels :: [e], content :: c}

unpackEvents :: Result event a -> [event]
unpackEvents Success {events} = events
unpackEvents _ = []

--
-- Result
--
--
data Result events a
  = Success {result :: a, warnings :: GQLErrors, events :: [events]}
  | Failure {errors :: GQLErrors}
  deriving (Functor)

instance Applicative (Result e) where
  pure x = Success x [] []
  Success f w1 e1 <*> Success x w2 e2 = Success (f x) (w1 <> w2) (e1 <> e2)
  Failure e1 <*> Failure e2 = Failure (e1 <> e2)
  Failure e <*> Success _ w _ = Failure (e <> w)
  Success _ w _ <*> Failure e = Failure (e <> w)

instance Monad (Result e) where
  return = pure
  Success v w1 e1 >>= fm = case fm v of
    (Success x w2 e2) -> Success x (w1 <> w2) (e1 <> e2)
    (Failure e) -> Failure (e <> w1)
  Failure e >>= _ = Failure e

instance Failure [GQLError] (Result ev) where
  failure = Failure

instance Failure Message (Result e) where
  failure text =
    Failure [GQLError {message = "INTERNAL: " <> text, locations = []}]

instance PushEvents events (Result events) where
  pushEvents events = Success {result = (), warnings = [], events}

resultOr :: (GQLErrors -> a') -> (a -> a') -> Result e a -> a'
resultOr _ f (Success x _ _) = f x
resultOr f _ (Failure e) = f e

-- ResultT
newtype ResultT event (m :: * -> *) a = ResultT
  { runResultT :: m (Result event a)
  }
  deriving (Functor)

statelessToResultT ::
  Applicative m =>
  Eventless a ->
  ResultT e m a
statelessToResultT =
  cleanEvents
    . ResultT
    . pure

instance Applicative m => Applicative (ResultT event m) where
  pure = ResultT . pure . pure
  ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2

instance Monad m => Monad (ResultT event m) where
  return = pure
  (ResultT m1) >>= mFunc = ResultT $ do
    result1 <- m1
    case result1 of
      Failure errors -> pure $ Failure errors
      Success value1 w1 e1 -> do
        result2 <- runResultT (mFunc value1)
        case result2 of
          Failure errors -> pure $ Failure (errors <> w1)
          Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2)

instance MonadTrans (ResultT event) where
  lift = ResultT . fmap pure

-- instance Applicative m => Failure String (ResultT event m) where
--   failure x =
--     ResultT $ pure $ Failure [GQLError {message = pack x, locations = []}]

instance Monad m => Failure GQLErrors (ResultT event m) where
  failure = ResultT . pure . failure

instance Applicative m => Failure Message (ResultT event m) where
  failure = ResultT . pure . failure

instance Applicative m => PushEvents event (ResultT event m) where
  pushEvents = ResultT . pure . pushEvents

cleanEvents ::
  Functor m =>
  ResultT e m a ->
  ResultT e' m a
cleanEvents resT = ResultT $ replace <$> runResultT resT
  where
    replace (Success v w _) = Success v w []
    replace (Failure e) = Failure e

mapEvent ::
  Monad m =>
  (e -> e') ->
  ResultT e m value ->
  ResultT e' m value
mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma
  where
    mapEv Success {result, warnings, events} =
      Success {result, warnings, events = map func events}
    mapEv (Failure err) = Failure err

-- Helper Functions
type LibUpdater lib = lib -> Eventless lib

resolveUpdates :: Monad m => lib -> [lib -> m lib] -> m lib
resolveUpdates = foldM (&)