{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-# OPTIONS_HADDOCK hide #-}

module Capability.Sink.Internal.Strategies
  ( SinkStack(..)
  , SinkDList(..)
  , SinkLog(..)
  ) where

import Capability.Accessors
import Capability.Source.Internal.Class
import Capability.Sink.Internal.Class
import Capability.State.Internal.Class
import Capability.State.Internal.Strategies.Common
import Control.Lens (set)
import qualified Control.Monad.State.Class as State
import Data.Coerce (Coercible, coerce)
import Data.DList (DList)
import qualified Data.DList as DList
import qualified Data.Generics.Product.Fields as Generic
import qualified Data.Generics.Product.Positions as Generic
import Data.IORef
import Data.Kind (Type)
import Data.Mutable
import Streaming
import qualified Streaming.Prelude as S

-- | Accumulate sunk values in a reverse order list.
newtype SinkStack m (a :: Type) = SinkStack (m a)
  deriving (a -> SinkStack m b -> SinkStack m a
(a -> b) -> SinkStack m a -> SinkStack m b
(forall a b. (a -> b) -> SinkStack m a -> SinkStack m b)
-> (forall a b. a -> SinkStack m b -> SinkStack m a)
-> Functor (SinkStack m)
forall a b. a -> SinkStack m b -> SinkStack m a
forall a b. (a -> b) -> SinkStack m a -> SinkStack m b
forall (m :: * -> *) a b.
Functor m =>
a -> SinkStack m b -> SinkStack m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SinkStack m a -> SinkStack m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SinkStack m b -> SinkStack m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SinkStack m b -> SinkStack m a
fmap :: (a -> b) -> SinkStack m a -> SinkStack m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SinkStack m a -> SinkStack m b
Functor, Functor (SinkStack m)
a -> SinkStack m a
Functor (SinkStack m)
-> (forall a. a -> SinkStack m a)
-> (forall a b.
    SinkStack m (a -> b) -> SinkStack m a -> SinkStack m b)
-> (forall a b c.
    (a -> b -> c) -> SinkStack m a -> SinkStack m b -> SinkStack m c)
-> (forall a b. SinkStack m a -> SinkStack m b -> SinkStack m b)
-> (forall a b. SinkStack m a -> SinkStack m b -> SinkStack m a)
-> Applicative (SinkStack m)
SinkStack m a -> SinkStack m b -> SinkStack m b
SinkStack m a -> SinkStack m b -> SinkStack m a
SinkStack m (a -> b) -> SinkStack m a -> SinkStack m b
(a -> b -> c) -> SinkStack m a -> SinkStack m b -> SinkStack m c
forall a. a -> SinkStack m a
forall a b. SinkStack m a -> SinkStack m b -> SinkStack m a
forall a b. SinkStack m a -> SinkStack m b -> SinkStack m b
forall a b. SinkStack m (a -> b) -> SinkStack m a -> SinkStack m b
forall a b c.
(a -> b -> c) -> SinkStack m a -> SinkStack m b -> SinkStack m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (SinkStack m)
forall (m :: * -> *) a. Applicative m => a -> SinkStack m a
forall (m :: * -> *) a b.
Applicative m =>
SinkStack m a -> SinkStack m b -> SinkStack m a
forall (m :: * -> *) a b.
Applicative m =>
SinkStack m a -> SinkStack m b -> SinkStack m b
forall (m :: * -> *) a b.
Applicative m =>
SinkStack m (a -> b) -> SinkStack m a -> SinkStack m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SinkStack m a -> SinkStack m b -> SinkStack m c
<* :: SinkStack m a -> SinkStack m b -> SinkStack m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SinkStack m a -> SinkStack m b -> SinkStack m a
*> :: SinkStack m a -> SinkStack m b -> SinkStack m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SinkStack m a -> SinkStack m b -> SinkStack m b
liftA2 :: (a -> b -> c) -> SinkStack m a -> SinkStack m b -> SinkStack m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SinkStack m a -> SinkStack m b -> SinkStack m c
<*> :: SinkStack m (a -> b) -> SinkStack m a -> SinkStack m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SinkStack m (a -> b) -> SinkStack m a -> SinkStack m b
pure :: a -> SinkStack m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SinkStack m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (SinkStack m)
Applicative, Applicative (SinkStack m)
a -> SinkStack m a
Applicative (SinkStack m)
-> (forall a b.
    SinkStack m a -> (a -> SinkStack m b) -> SinkStack m b)
-> (forall a b. SinkStack m a -> SinkStack m b -> SinkStack m b)
-> (forall a. a -> SinkStack m a)
-> Monad (SinkStack m)
SinkStack m a -> (a -> SinkStack m b) -> SinkStack m b
SinkStack m a -> SinkStack m b -> SinkStack m b
forall a. a -> SinkStack m a
forall a b. SinkStack m a -> SinkStack m b -> SinkStack m b
forall a b. SinkStack m a -> (a -> SinkStack m b) -> SinkStack m b
forall (m :: * -> *). Monad m => Applicative (SinkStack m)
forall (m :: * -> *) a. Monad m => a -> SinkStack m a
forall (m :: * -> *) a b.
Monad m =>
SinkStack m a -> SinkStack m b -> SinkStack m b
forall (m :: * -> *) a b.
Monad m =>
SinkStack m a -> (a -> SinkStack m b) -> SinkStack m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SinkStack m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SinkStack m a
>> :: SinkStack m a -> SinkStack m b -> SinkStack m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SinkStack m a -> SinkStack m b -> SinkStack m b
>>= :: SinkStack m a -> (a -> SinkStack m b) -> SinkStack m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SinkStack m a -> (a -> SinkStack m b) -> SinkStack m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (SinkStack m)
Monad, Monad (SinkStack m)
Monad (SinkStack m)
-> (forall a. IO a -> SinkStack m a) -> MonadIO (SinkStack m)
IO a -> SinkStack m a
forall a. IO a -> SinkStack m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (SinkStack m)
forall (m :: * -> *) a. MonadIO m => IO a -> SinkStack m a
liftIO :: IO a -> SinkStack m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SinkStack m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (SinkStack m)
MonadIO, Monad (SinkStack m)
Monad (SinkStack m)
-> (forall a.
    (State# (PrimState (SinkStack m))
     -> (# State# (PrimState (SinkStack m)), a #))
    -> SinkStack m a)
-> PrimMonad (SinkStack m)
(State# (PrimState (SinkStack m))
 -> (# State# (PrimState (SinkStack m)), a #))
-> SinkStack m a
forall a.
(State# (PrimState (SinkStack m))
 -> (# State# (PrimState (SinkStack m)), a #))
-> SinkStack m a
forall (m :: * -> *).
Monad m
-> (forall a.
    (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> PrimMonad m
forall (m :: * -> *). PrimMonad m => Monad (SinkStack m)
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (SinkStack m))
 -> (# State# (PrimState (SinkStack m)), a #))
-> SinkStack m a
primitive :: (State# (PrimState (SinkStack m))
 -> (# State# (PrimState (SinkStack m)), a #))
-> SinkStack m a
$cprimitive :: forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (SinkStack m))
 -> (# State# (PrimState (SinkStack m)), a #))
-> SinkStack m a
$cp1PrimMonad :: forall (m :: * -> *). PrimMonad m => Monad (SinkStack m)
PrimMonad)
instance HasState tag [a] m => HasSink tag a (SinkStack m) where
  yield_ :: Proxy# tag -> a -> SinkStack m ()
yield_ Proxy# tag
_ a
a = forall b. Coercible (m ()) b => m () -> b
coerce @(m ()) (m () -> SinkStack m ()) -> m () -> SinkStack m ()
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> m ()
forall k (tag :: k) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
modify' @tag (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
  {-# INLINE yield_ #-}

-- | Accumulate sunk values in forward order in a difference list.
newtype SinkDList m (a :: Type) = SinkDList (m a)
  deriving (a -> SinkDList m b -> SinkDList m a
(a -> b) -> SinkDList m a -> SinkDList m b
(forall a b. (a -> b) -> SinkDList m a -> SinkDList m b)
-> (forall a b. a -> SinkDList m b -> SinkDList m a)
-> Functor (SinkDList m)
forall a b. a -> SinkDList m b -> SinkDList m a
forall a b. (a -> b) -> SinkDList m a -> SinkDList m b
forall (m :: * -> *) a b.
Functor m =>
a -> SinkDList m b -> SinkDList m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SinkDList m a -> SinkDList m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SinkDList m b -> SinkDList m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SinkDList m b -> SinkDList m a
fmap :: (a -> b) -> SinkDList m a -> SinkDList m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SinkDList m a -> SinkDList m b
Functor, Functor (SinkDList m)
a -> SinkDList m a
Functor (SinkDList m)
-> (forall a. a -> SinkDList m a)
-> (forall a b.
    SinkDList m (a -> b) -> SinkDList m a -> SinkDList m b)
-> (forall a b c.
    (a -> b -> c) -> SinkDList m a -> SinkDList m b -> SinkDList m c)
-> (forall a b. SinkDList m a -> SinkDList m b -> SinkDList m b)
-> (forall a b. SinkDList m a -> SinkDList m b -> SinkDList m a)
-> Applicative (SinkDList m)
SinkDList m a -> SinkDList m b -> SinkDList m b
SinkDList m a -> SinkDList m b -> SinkDList m a
SinkDList m (a -> b) -> SinkDList m a -> SinkDList m b
(a -> b -> c) -> SinkDList m a -> SinkDList m b -> SinkDList m c
forall a. a -> SinkDList m a
forall a b. SinkDList m a -> SinkDList m b -> SinkDList m a
forall a b. SinkDList m a -> SinkDList m b -> SinkDList m b
forall a b. SinkDList m (a -> b) -> SinkDList m a -> SinkDList m b
forall a b c.
(a -> b -> c) -> SinkDList m a -> SinkDList m b -> SinkDList m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (SinkDList m)
forall (m :: * -> *) a. Applicative m => a -> SinkDList m a
forall (m :: * -> *) a b.
Applicative m =>
SinkDList m a -> SinkDList m b -> SinkDList m a
forall (m :: * -> *) a b.
Applicative m =>
SinkDList m a -> SinkDList m b -> SinkDList m b
forall (m :: * -> *) a b.
Applicative m =>
SinkDList m (a -> b) -> SinkDList m a -> SinkDList m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SinkDList m a -> SinkDList m b -> SinkDList m c
<* :: SinkDList m a -> SinkDList m b -> SinkDList m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SinkDList m a -> SinkDList m b -> SinkDList m a
*> :: SinkDList m a -> SinkDList m b -> SinkDList m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SinkDList m a -> SinkDList m b -> SinkDList m b
liftA2 :: (a -> b -> c) -> SinkDList m a -> SinkDList m b -> SinkDList m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SinkDList m a -> SinkDList m b -> SinkDList m c
<*> :: SinkDList m (a -> b) -> SinkDList m a -> SinkDList m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SinkDList m (a -> b) -> SinkDList m a -> SinkDList m b
pure :: a -> SinkDList m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SinkDList m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (SinkDList m)
Applicative, Applicative (SinkDList m)
a -> SinkDList m a
Applicative (SinkDList m)
-> (forall a b.
    SinkDList m a -> (a -> SinkDList m b) -> SinkDList m b)
-> (forall a b. SinkDList m a -> SinkDList m b -> SinkDList m b)
-> (forall a. a -> SinkDList m a)
-> Monad (SinkDList m)
SinkDList m a -> (a -> SinkDList m b) -> SinkDList m b
SinkDList m a -> SinkDList m b -> SinkDList m b
forall a. a -> SinkDList m a
forall a b. SinkDList m a -> SinkDList m b -> SinkDList m b
forall a b. SinkDList m a -> (a -> SinkDList m b) -> SinkDList m b
forall (m :: * -> *). Monad m => Applicative (SinkDList m)
forall (m :: * -> *) a. Monad m => a -> SinkDList m a
forall (m :: * -> *) a b.
Monad m =>
SinkDList m a -> SinkDList m b -> SinkDList m b
forall (m :: * -> *) a b.
Monad m =>
SinkDList m a -> (a -> SinkDList m b) -> SinkDList m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SinkDList m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SinkDList m a
>> :: SinkDList m a -> SinkDList m b -> SinkDList m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SinkDList m a -> SinkDList m b -> SinkDList m b
>>= :: SinkDList m a -> (a -> SinkDList m b) -> SinkDList m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SinkDList m a -> (a -> SinkDList m b) -> SinkDList m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (SinkDList m)
Monad, Monad (SinkDList m)
Monad (SinkDList m)
-> (forall a. IO a -> SinkDList m a) -> MonadIO (SinkDList m)
IO a -> SinkDList m a
forall a. IO a -> SinkDList m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (SinkDList m)
forall (m :: * -> *) a. MonadIO m => IO a -> SinkDList m a
liftIO :: IO a -> SinkDList m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SinkDList m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (SinkDList m)
MonadIO, Monad (SinkDList m)
Monad (SinkDList m)
-> (forall a.
    (State# (PrimState (SinkDList m))
     -> (# State# (PrimState (SinkDList m)), a #))
    -> SinkDList m a)
-> PrimMonad (SinkDList m)
(State# (PrimState (SinkDList m))
 -> (# State# (PrimState (SinkDList m)), a #))
-> SinkDList m a
forall a.
(State# (PrimState (SinkDList m))
 -> (# State# (PrimState (SinkDList m)), a #))
-> SinkDList m a
forall (m :: * -> *).
Monad m
-> (forall a.
    (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> PrimMonad m
forall (m :: * -> *). PrimMonad m => Monad (SinkDList m)
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (SinkDList m))
 -> (# State# (PrimState (SinkDList m)), a #))
-> SinkDList m a
primitive :: (State# (PrimState (SinkDList m))
 -> (# State# (PrimState (SinkDList m)), a #))
-> SinkDList m a
$cprimitive :: forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (SinkDList m))
 -> (# State# (PrimState (SinkDList m)), a #))
-> SinkDList m a
$cp1PrimMonad :: forall (m :: * -> *). PrimMonad m => Monad (SinkDList m)
PrimMonad)
-- | This instance may seem a bit odd at first. All it does is wrap each
-- 'yield'ed value in a single element difference list. How does re-yielding
-- something else constitute a strategy for implementing 'HasSink' in the
-- first place? The answer is that difference lists form a monoid, which allows
-- a second stragegy to be used which accumulates all 'yield's in a single
-- value, actually eliminating the 'HasSink' constraint this time.
--
-- 'SinkLog' below in fact does this, so the easiest way to fully eliminate
-- the 'HasSink' constraint as described above is:
--
-- > deriving (HasSink tag w) via
-- >   SinkDList (SinkLog (MonadState SomeStateMonad))
instance HasSink tag (DList a) m => HasSink tag a (SinkDList m) where
  yield_ :: Proxy# tag -> a -> SinkDList m ()
yield_ Proxy# tag
_ = forall b. Coercible (a -> m ()) b => (a -> m ()) -> b
coerce @(a -> m ()) ((a -> m ()) -> a -> SinkDList m ())
-> (a -> m ()) -> a -> SinkDList m ()
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) a (m :: * -> *). HasSink tag a m => a -> m ()
forall a (m :: * -> *). HasSink tag a m => a -> m ()
yield @tag (DList a -> m ()) -> (a -> DList a) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DList a
forall a. a -> DList a
DList.singleton
  {-# INLINE yield_ #-}

-- | Accumulate sunk values with their own monoid.
newtype SinkLog m (a :: Type) = SinkLog (m a)
  deriving (a -> SinkLog m b -> SinkLog m a
(a -> b) -> SinkLog m a -> SinkLog m b
(forall a b. (a -> b) -> SinkLog m a -> SinkLog m b)
-> (forall a b. a -> SinkLog m b -> SinkLog m a)
-> Functor (SinkLog m)
forall a b. a -> SinkLog m b -> SinkLog m a
forall a b. (a -> b) -> SinkLog m a -> SinkLog m b
forall (m :: * -> *) a b.
Functor m =>
a -> SinkLog m b -> SinkLog m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SinkLog m a -> SinkLog m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SinkLog m b -> SinkLog m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SinkLog m b -> SinkLog m a
fmap :: (a -> b) -> SinkLog m a -> SinkLog m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SinkLog m a -> SinkLog m b
Functor, Functor (SinkLog m)
a -> SinkLog m a
Functor (SinkLog m)
-> (forall a. a -> SinkLog m a)
-> (forall a b. SinkLog m (a -> b) -> SinkLog m a -> SinkLog m b)
-> (forall a b c.
    (a -> b -> c) -> SinkLog m a -> SinkLog m b -> SinkLog m c)
-> (forall a b. SinkLog m a -> SinkLog m b -> SinkLog m b)
-> (forall a b. SinkLog m a -> SinkLog m b -> SinkLog m a)
-> Applicative (SinkLog m)
SinkLog m a -> SinkLog m b -> SinkLog m b
SinkLog m a -> SinkLog m b -> SinkLog m a
SinkLog m (a -> b) -> SinkLog m a -> SinkLog m b
(a -> b -> c) -> SinkLog m a -> SinkLog m b -> SinkLog m c
forall a. a -> SinkLog m a
forall a b. SinkLog m a -> SinkLog m b -> SinkLog m a
forall a b. SinkLog m a -> SinkLog m b -> SinkLog m b
forall a b. SinkLog m (a -> b) -> SinkLog m a -> SinkLog m b
forall a b c.
(a -> b -> c) -> SinkLog m a -> SinkLog m b -> SinkLog m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (SinkLog m)
forall (m :: * -> *) a. Applicative m => a -> SinkLog m a
forall (m :: * -> *) a b.
Applicative m =>
SinkLog m a -> SinkLog m b -> SinkLog m a
forall (m :: * -> *) a b.
Applicative m =>
SinkLog m a -> SinkLog m b -> SinkLog m b
forall (m :: * -> *) a b.
Applicative m =>
SinkLog m (a -> b) -> SinkLog m a -> SinkLog m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SinkLog m a -> SinkLog m b -> SinkLog m c
<* :: SinkLog m a -> SinkLog m b -> SinkLog m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SinkLog m a -> SinkLog m b -> SinkLog m a
*> :: SinkLog m a -> SinkLog m b -> SinkLog m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SinkLog m a -> SinkLog m b -> SinkLog m b
liftA2 :: (a -> b -> c) -> SinkLog m a -> SinkLog m b -> SinkLog m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SinkLog m a -> SinkLog m b -> SinkLog m c
<*> :: SinkLog m (a -> b) -> SinkLog m a -> SinkLog m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SinkLog m (a -> b) -> SinkLog m a -> SinkLog m b
pure :: a -> SinkLog m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SinkLog m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (SinkLog m)
Applicative, Applicative (SinkLog m)
a -> SinkLog m a
Applicative (SinkLog m)
-> (forall a b. SinkLog m a -> (a -> SinkLog m b) -> SinkLog m b)
-> (forall a b. SinkLog m a -> SinkLog m b -> SinkLog m b)
-> (forall a. a -> SinkLog m a)
-> Monad (SinkLog m)
SinkLog m a -> (a -> SinkLog m b) -> SinkLog m b
SinkLog m a -> SinkLog m b -> SinkLog m b
forall a. a -> SinkLog m a
forall a b. SinkLog m a -> SinkLog m b -> SinkLog m b
forall a b. SinkLog m a -> (a -> SinkLog m b) -> SinkLog m b
forall (m :: * -> *). Monad m => Applicative (SinkLog m)
forall (m :: * -> *) a. Monad m => a -> SinkLog m a
forall (m :: * -> *) a b.
Monad m =>
SinkLog m a -> SinkLog m b -> SinkLog m b
forall (m :: * -> *) a b.
Monad m =>
SinkLog m a -> (a -> SinkLog m b) -> SinkLog m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SinkLog m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SinkLog m a
>> :: SinkLog m a -> SinkLog m b -> SinkLog m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SinkLog m a -> SinkLog m b -> SinkLog m b
>>= :: SinkLog m a -> (a -> SinkLog m b) -> SinkLog m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SinkLog m a -> (a -> SinkLog m b) -> SinkLog m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (SinkLog m)
Monad, Monad (SinkLog m)
Monad (SinkLog m)
-> (forall a. IO a -> SinkLog m a) -> MonadIO (SinkLog m)
IO a -> SinkLog m a
forall a. IO a -> SinkLog m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (SinkLog m)
forall (m :: * -> *) a. MonadIO m => IO a -> SinkLog m a
liftIO :: IO a -> SinkLog m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SinkLog m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (SinkLog m)
MonadIO, Monad (SinkLog m)
Monad (SinkLog m)
-> (forall a.
    (State# (PrimState (SinkLog m))
     -> (# State# (PrimState (SinkLog m)), a #))
    -> SinkLog m a)
-> PrimMonad (SinkLog m)
(State# (PrimState (SinkLog m))
 -> (# State# (PrimState (SinkLog m)), a #))
-> SinkLog m a
forall a.
(State# (PrimState (SinkLog m))
 -> (# State# (PrimState (SinkLog m)), a #))
-> SinkLog m a
forall (m :: * -> *).
Monad m
-> (forall a.
    (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> PrimMonad m
forall (m :: * -> *). PrimMonad m => Monad (SinkLog m)
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (SinkLog m))
 -> (# State# (PrimState (SinkLog m)), a #))
-> SinkLog m a
primitive :: (State# (PrimState (SinkLog m))
 -> (# State# (PrimState (SinkLog m)), a #))
-> SinkLog m a
$cprimitive :: forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (SinkLog m))
 -> (# State# (PrimState (SinkLog m)), a #))
-> SinkLog m a
$cp1PrimMonad :: forall (m :: * -> *). PrimMonad m => Monad (SinkLog m)
PrimMonad)
instance (Monoid w, HasState tag w m) => HasSink tag w (SinkLog m) where
    yield_ :: Proxy# tag -> w -> SinkLog m ()
yield_ Proxy# tag
_ w
w = forall b. Coercible (m ()) b => m () -> b
coerce @(m ()) (m () -> SinkLog m ()) -> m () -> SinkLog m ()
forall a b. (a -> b) -> a -> b
$ (w -> w) -> m ()
forall k (tag :: k) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
modify' @tag (w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w)
    {-# INLINE yield_ #-}

instance Monad m => HasSink tag a (S.Stream (Of a) m) where
  yield_ :: Proxy# tag -> a -> Stream (Of a) m ()
yield_ Proxy# tag
_ = a -> Stream (Of a) m ()
forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield
  {-# INLINE yield_ #-}

-- | Lift one layer in a monad transformer stack.
--
-- Note, that if the 'HasSink' instance is based on 'HasState', then it is
-- more efficient to apply 'Lift' to the underlying state capability. E.g.
-- you should favour
--
-- > deriving (HasSink tag w) via
-- >   SinkLog (Lift (SomeTrans (MonadState SomeStateMonad)))
--
-- over
--
-- > deriving (HasSink tag w) via
-- >   Lift (SomeTrans (SinkLog (MonadState SomeStateMonad)))
instance (HasSink tag a m, MonadTrans t, Monad (t m))
  => HasSink tag a (Lift (t m))
  where
    yield_ :: Proxy# tag -> a -> Lift (t m) ()
yield_ Proxy# tag
_ = forall b. Coercible (a -> t m ()) b => (a -> t m ()) -> b
coerce @(a -> t m ()) ((a -> t m ()) -> a -> Lift (t m) ())
-> (a -> t m ()) -> a -> Lift (t m) ()
forall a b. (a -> b) -> a -> b
$ m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> (a -> m ()) -> a -> t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (tag :: k) a (m :: * -> *). HasSink tag a m => a -> m ()
forall a (m :: * -> *). HasSink tag a m => a -> m ()
yield @tag
    {-# INLINE yield_ #-}

-- | Compose two accessors.
deriving via ((t2 :: (Type -> Type) -> Type -> Type) ((t1 :: (Type -> Type) -> Type -> Type) m))
  instance
  ( forall x. Coercible (m x) (t2 (t1 m) x)
  , Monad m, HasSink tag a (t2 (t1 m)) )
  => HasSink tag a ((t2 :.: t1) m)

-- | Convert the state using safe coercion.
instance
  ( Coercible from to, HasSink tag from m )
  => HasSink tag to (Coerce to m)
  where
    yield_ :: Proxy# tag -> to -> Coerce to m ()
yield_ Proxy# tag
tag = forall b. Coercible (from -> m ()) b => (from -> m ()) -> b
coerce @(from -> m ()) ((from -> m ()) -> to -> Coerce to m ())
-> (from -> m ()) -> to -> Coerce to m ()
forall a b. (a -> b) -> a -> b
$ Proxy# tag -> from -> m ()
forall k (tag :: k) a (m :: * -> *).
HasSink tag a m =>
Proxy# tag -> a -> m ()
yield_ Proxy# tag
tag
    {-# INLINE yield_ #-}

-- | Rename the tag.
instance HasSink oldtag s m => HasSink newtag s (Rename oldtag m) where
  yield_ :: Proxy# newtag -> s -> Rename oldtag m ()
yield_ Proxy# newtag
_ = forall b. Coercible (s -> m ()) b => (s -> m ()) -> b
coerce @(s -> m ()) ((s -> m ()) -> s -> Rename oldtag m ())
-> (s -> m ()) -> s -> Rename oldtag m ()
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) a (m :: * -> *). HasSink tag a m => a -> m ()
forall a (m :: * -> *). HasSink oldtag a m => a -> m ()
yield @oldtag
  {-# INLINE yield_ #-}

-- | Zoom in on the record field @field@ of type @v@ in the state @record@.
instance
  -- The constraint raises @-Wsimplifiable-class-constraints@.
  -- This could be avoided by instead placing @HasField'@s constraints here.
  -- Unfortunately, it uses non-exported symbols from @generic-lens@.
  ( tag ~ field, Generic.HasField' field record v, HasState oldtag record m )
  => HasSink tag v (Field field oldtag m)
  where
    yield_ :: Proxy# tag -> v -> Field field oldtag m ()
yield_ Proxy# tag
_ = forall b. Coercible (v -> m ()) b => (v -> m ()) -> b
coerce @(v -> m ()) ((v -> m ()) -> v -> Field field oldtag m ())
-> (v -> m ()) -> v -> Field field oldtag m ()
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
forall s (m :: * -> *). HasState oldtag s m => (s -> s) -> m ()
modify @oldtag ((record -> record) -> m ())
-> (v -> record -> record) -> v -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter record record v v -> v -> record -> record
forall s t a b. ASetter s t a b -> b -> s -> t
set (forall a. HasField' field record a => Lens record record a a
forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
Generic.field' @field @record)
    {-# INLINE yield_ #-}

-- | Zoom in on the field at position @pos@ of type @v@ in the state @struct@.
instance
  -- The constraint raises @-Wsimplifiable-class-constraints@.
  -- This could be avoided by instead placing @HasPosition'@s constraints here.
  -- Unfortunately, it uses non-exported symbols from @generic-lens@.
  ( tag ~ pos, Generic.HasPosition' pos struct v, HasState oldtag struct m )
  => HasSink tag v (Pos pos oldtag m)
  where
    yield_ :: Proxy# tag -> v -> Pos pos oldtag m ()
yield_ Proxy# tag
_ = forall b. Coercible (v -> m ()) b => (v -> m ()) -> b
coerce @(v -> m ()) ((v -> m ()) -> v -> Pos pos oldtag m ())
-> (v -> m ()) -> v -> Pos pos oldtag m ()
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
forall s (m :: * -> *). HasState oldtag s m => (s -> s) -> m ()
modify @oldtag ((struct -> struct) -> m ())
-> (v -> struct -> struct) -> v -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter struct struct v v -> v -> struct -> struct
forall s t a b. ASetter s t a b -> b -> s -> t
set (forall a. HasPosition' pos struct a => Lens struct struct a a
forall (i :: Nat) s a. HasPosition' i s a => Lens s s a a
Generic.position' @pos @struct)
    {-# INLINE yield_ #-}

--------------------------------------------------------------------------------

instance State.MonadState s m => HasSink tag s (MonadState m) where
  yield_ :: Proxy# tag -> s -> MonadState m ()
yield_ Proxy# tag
_ = (s -> m ()) -> s -> MonadState m ()
coerce @(s -> m ()) s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put
  {-# INLINE yield_ #-}

instance
  (HasSource tag (IORef s) m, MonadIO m)
  => HasSink tag s (ReaderIORef m)
  where
    yield_ :: Proxy# tag -> s -> ReaderIORef m ()
yield_ Proxy# tag
_ s
v = m () -> ReaderIORef m ()
forall k (m :: k -> *) (a :: k). m a -> ReaderIORef m a
ReaderIORef (m () -> ReaderIORef m ()) -> m () -> ReaderIORef m ()
forall a b. (a -> b) -> a -> b
$ do
      IORef s
ref <- forall k (tag :: k) a (m :: * -> *). HasSource tag a m => m a
forall a (m :: * -> *). HasSource tag a m => m a
await @tag
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef s -> s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef s
ref s
v
    {-# INLINE yield_ #-}

instance
  ( MutableRef ref, RefElement ref ~ s
  , HasSource tag ref m, PrimMonad m, PrimState m ~ MCState ref )
  => HasSink tag s (ReaderRef m)
  where
    yield_ :: Proxy# tag -> s -> ReaderRef m ()
yield_ Proxy# tag
_ s
v = m () -> ReaderRef m ()
forall (m :: * -> *) a. m a -> ReaderRef m a
ReaderRef (m () -> ReaderRef m ()) -> m () -> ReaderRef m ()
forall a b. (a -> b) -> a -> b
$ do
      ref
ref <- forall k (tag :: k) a (m :: * -> *). HasSource tag a m => m a
forall a (m :: * -> *). HasSource tag a m => m a
await @tag
      ref -> RefElement ref -> m ()
forall c (m :: * -> *).
(MutableRef c, PrimMonad m, PrimState m ~ MCState c) =>
c -> RefElement c -> m ()
writeRef ref
ref s
RefElement ref
v
    {-# INLINE yield_ #-}