{-# 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 ()
class PushEvents e m where
pushEvents :: [e] -> m ()
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 _ = []
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
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 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
type LibUpdater lib = lib -> Eventless lib
resolveUpdates :: Monad m => lib -> [lib -> m lib] -> m lib
resolveUpdates = foldM (&)