{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Morpheus.Types.Internal.Resolving.Core
( Eventless
, Result(..)
, Failure(..)
, ResultT(..)
, unpackEvents
, LibUpdater
, resolveUpdates
, mapEvent
, cleanEvents
, Event(..)
, Channel(..)
, GQLChannel(..)
, PushEvents(..)
, statelessToResultT
)
where
import Control.Monad ( foldM )
import Data.Function ( (&) )
import Control.Monad.Trans.Class ( MonadTrans(..) )
import Control.Applicative ( liftA2 )
import Data.Morpheus.Types.Internal.Operation
(
Failure(..)
)
import Data.Morpheus.Types.Internal.AST.Base
( GQLErrors
, GQLError(..)
)
import Data.Text ( Text
, pack
)
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 Text Eventless where
failure text =
Failure [GQLError { message = "INTERNAL: " <> text, locations = [] }]
instance PushEvents events (Result events) where
pushEvents events = Success { result = (), warnings = [], events }
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 => 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 :: lib -> [LibUpdater lib] -> Eventless lib
resolveUpdates = foldM (&)