{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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 TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
module Capability.Stream
(
HasStream(..)
, yield
, StreamStack(..)
, StreamDList(..)
, module Capability.Accessors
) where
import Capability.Accessors
import Capability.State
import Capability.Writer
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Primitive (PrimMonad)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Data.Coerce (Coercible, coerce)
import Data.DList (DList)
import qualified Data.DList as DList
import GHC.Exts (Proxy#, proxy#)
import Streaming
import qualified Streaming.Prelude as S
class Monad m
=> HasStream (tag :: k) (a :: *) (m :: * -> *) | tag m -> a
where
yield_ :: Proxy# tag -> a -> m ()
yield :: forall tag a m. HasStream tag a m => a -> m ()
yield = yield_ (proxy# @_ @tag)
{-# INLINE yield #-}
newtype StreamStack m (a :: *) = StreamStack (m a)
deriving (Functor, Applicative, Monad, MonadIO, PrimMonad)
instance HasState tag [a] m => HasStream tag a (StreamStack m) where
yield_ _ a = coerce @(m ()) $ modify' @tag (a:)
{-# INLINE yield_ #-}
newtype StreamDList m (a :: *) = StreamDList (m a)
deriving (Functor, Applicative, Monad, MonadIO, PrimMonad)
instance HasWriter tag (DList a) m => HasStream tag a (StreamDList m) where
yield_ _ = coerce @(a -> m ()) $ tell @tag . DList.singleton
{-# INLINE yield_ #-}
instance Monad m => HasStream tag a (S.Stream (Of a) m) where
yield_ _ = S.yield
{-# INLINE yield_ #-}
instance (HasStream tag a m, MonadTrans t, Monad (t m))
=> HasStream tag a (Lift (t m))
where
yield_ _ = coerce @(a -> t m ()) $ lift . yield @tag
{-# INLINE yield_ #-}
deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m))
instance
( forall x. Coercible (m x) (t2 (t1 m) x)
, Monad m, HasStream tag a (t2 (t1 m)) )
=> HasStream tag a ((t2 :.: t1) m)