{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
 Module      :  Control.Monad.Trans.HandleWriter
 Copyright   :  (C) 2021 Isaac Elliott
 License     :  BSD-3 (see the file LICENSE)
 Maintainer  :  Isaac Elliott <isaace71295@gmail.com>
-}
module Control.Monad.Trans.HandleWriter (
  HandleWriterT (..),
  runHandleWriterT,
  Env (..),
) where

import Control.Monad.Cont.Class (MonadCont)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.State.Class (MonadState)
import Control.Monad.Tell.Class (MonadTell (..))
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Reader (ReaderT (runReaderT))
import System.IO (Handle)

data Env w = Env !Handle !(Handle -> w -> IO ())

{- |

A monad that can write a monoidal summary to a 'Handle'.
-}
newtype HandleWriterT w m a = HandleWriterT {HandleWriterT w m a -> ReaderT (Env w) m a
unHandleWriterT :: ReaderT (Env w) m a}
  deriving
    ( a -> HandleWriterT w m b -> HandleWriterT w m a
(a -> b) -> HandleWriterT w m a -> HandleWriterT w m b
(forall a b.
 (a -> b) -> HandleWriterT w m a -> HandleWriterT w m b)
-> (forall a b. a -> HandleWriterT w m b -> HandleWriterT w m a)
-> Functor (HandleWriterT w m)
forall a b. a -> HandleWriterT w m b -> HandleWriterT w m a
forall a b. (a -> b) -> HandleWriterT w m a -> HandleWriterT w m b
forall w (m :: * -> *) a b.
Functor m =>
a -> HandleWriterT w m b -> HandleWriterT w m a
forall w (m :: * -> *) a b.
Functor m =>
(a -> b) -> HandleWriterT w m a -> HandleWriterT w m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> HandleWriterT w m b -> HandleWriterT w m a
$c<$ :: forall w (m :: * -> *) a b.
Functor m =>
a -> HandleWriterT w m b -> HandleWriterT w m a
fmap :: (a -> b) -> HandleWriterT w m a -> HandleWriterT w m b
$cfmap :: forall w (m :: * -> *) a b.
Functor m =>
(a -> b) -> HandleWriterT w m a -> HandleWriterT w m b
Functor
    , Functor (HandleWriterT w m)
a -> HandleWriterT w m a
Functor (HandleWriterT w m)
-> (forall a. a -> HandleWriterT w m a)
-> (forall a b.
    HandleWriterT w m (a -> b)
    -> HandleWriterT w m a -> HandleWriterT w m b)
-> (forall a b c.
    (a -> b -> c)
    -> HandleWriterT w m a
    -> HandleWriterT w m b
    -> HandleWriterT w m c)
-> (forall a b.
    HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b)
-> (forall a b.
    HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m a)
-> Applicative (HandleWriterT w m)
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m a
HandleWriterT w m (a -> b)
-> HandleWriterT w m a -> HandleWriterT w m b
(a -> b -> c)
-> HandleWriterT w m a
-> HandleWriterT w m b
-> HandleWriterT w m c
forall a. a -> HandleWriterT w m a
forall a b.
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m a
forall a b.
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
forall a b.
HandleWriterT w m (a -> b)
-> HandleWriterT w m a -> HandleWriterT w m b
forall a b c.
(a -> b -> c)
-> HandleWriterT w m a
-> HandleWriterT w m b
-> HandleWriterT w m c
forall w (m :: * -> *).
Applicative m =>
Functor (HandleWriterT w m)
forall w (m :: * -> *) a. Applicative m => a -> HandleWriterT w m a
forall w (m :: * -> *) a b.
Applicative m =>
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m a
forall w (m :: * -> *) a b.
Applicative m =>
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
forall w (m :: * -> *) a b.
Applicative m =>
HandleWriterT w m (a -> b)
-> HandleWriterT w m a -> HandleWriterT w m b
forall w (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> HandleWriterT w m a
-> HandleWriterT w m b
-> HandleWriterT w 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
<* :: HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m a
$c<* :: forall w (m :: * -> *) a b.
Applicative m =>
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m a
*> :: HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
$c*> :: forall w (m :: * -> *) a b.
Applicative m =>
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
liftA2 :: (a -> b -> c)
-> HandleWriterT w m a
-> HandleWriterT w m b
-> HandleWriterT w m c
$cliftA2 :: forall w (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> HandleWriterT w m a
-> HandleWriterT w m b
-> HandleWriterT w m c
<*> :: HandleWriterT w m (a -> b)
-> HandleWriterT w m a -> HandleWriterT w m b
$c<*> :: forall w (m :: * -> *) a b.
Applicative m =>
HandleWriterT w m (a -> b)
-> HandleWriterT w m a -> HandleWriterT w m b
pure :: a -> HandleWriterT w m a
$cpure :: forall w (m :: * -> *) a. Applicative m => a -> HandleWriterT w m a
$cp1Applicative :: forall w (m :: * -> *).
Applicative m =>
Functor (HandleWriterT w m)
Applicative
    , Applicative (HandleWriterT w m)
a -> HandleWriterT w m a
Applicative (HandleWriterT w m)
-> (forall a b.
    HandleWriterT w m a
    -> (a -> HandleWriterT w m b) -> HandleWriterT w m b)
-> (forall a b.
    HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b)
-> (forall a. a -> HandleWriterT w m a)
-> Monad (HandleWriterT w m)
HandleWriterT w m a
-> (a -> HandleWriterT w m b) -> HandleWriterT w m b
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
forall a. a -> HandleWriterT w m a
forall a b.
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
forall a b.
HandleWriterT w m a
-> (a -> HandleWriterT w m b) -> HandleWriterT w m b
forall w (m :: * -> *). Monad m => Applicative (HandleWriterT w m)
forall w (m :: * -> *) a. Monad m => a -> HandleWriterT w m a
forall w (m :: * -> *) a b.
Monad m =>
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
forall w (m :: * -> *) a b.
Monad m =>
HandleWriterT w m a
-> (a -> HandleWriterT w m b) -> HandleWriterT w 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 -> HandleWriterT w m a
$creturn :: forall w (m :: * -> *) a. Monad m => a -> HandleWriterT w m a
>> :: HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
$c>> :: forall w (m :: * -> *) a b.
Monad m =>
HandleWriterT w m a -> HandleWriterT w m b -> HandleWriterT w m b
>>= :: HandleWriterT w m a
-> (a -> HandleWriterT w m b) -> HandleWriterT w m b
$c>>= :: forall w (m :: * -> *) a b.
Monad m =>
HandleWriterT w m a
-> (a -> HandleWriterT w m b) -> HandleWriterT w m b
$cp1Monad :: forall w (m :: * -> *). Monad m => Applicative (HandleWriterT w m)
Monad
    , Monad (HandleWriterT w m)
Monad (HandleWriterT w m)
-> (forall a. IO a -> HandleWriterT w m a)
-> MonadIO (HandleWriterT w m)
IO a -> HandleWriterT w m a
forall a. IO a -> HandleWriterT w m a
forall w (m :: * -> *). MonadIO m => Monad (HandleWriterT w m)
forall w (m :: * -> *) a. MonadIO m => IO a -> HandleWriterT w m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> HandleWriterT w m a
$cliftIO :: forall w (m :: * -> *) a. MonadIO m => IO a -> HandleWriterT w m a
$cp1MonadIO :: forall w (m :: * -> *). MonadIO m => Monad (HandleWriterT w m)
MonadIO
    , m a -> HandleWriterT w m a
(forall (m :: * -> *) a. Monad m => m a -> HandleWriterT w m a)
-> MonadTrans (HandleWriterT w)
forall w (m :: * -> *) a. Monad m => m a -> HandleWriterT w m a
forall (m :: * -> *) a. Monad m => m a -> HandleWriterT w m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> HandleWriterT w m a
$clift :: forall w (m :: * -> *) a. Monad m => m a -> HandleWriterT w m a
MonadTrans
    , MonadState s
    , MonadError e
    , Monad (HandleWriterT w m)
Monad (HandleWriterT w m)
-> (forall a b.
    ((a -> HandleWriterT w m b) -> HandleWriterT w m a)
    -> HandleWriterT w m a)
-> MonadCont (HandleWriterT w m)
((a -> HandleWriterT w m b) -> HandleWriterT w m a)
-> HandleWriterT w m a
forall a b.
((a -> HandleWriterT w m b) -> HandleWriterT w m a)
-> HandleWriterT w m a
forall w (m :: * -> *). MonadCont m => Monad (HandleWriterT w m)
forall w (m :: * -> *) a b.
MonadCont m =>
((a -> HandleWriterT w m b) -> HandleWriterT w m a)
-> HandleWriterT w m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
callCC :: ((a -> HandleWriterT w m b) -> HandleWriterT w m a)
-> HandleWriterT w m a
$ccallCC :: forall w (m :: * -> *) a b.
MonadCont m =>
((a -> HandleWriterT w m b) -> HandleWriterT w m a)
-> HandleWriterT w m a
$cp1MonadCont :: forall w (m :: * -> *). MonadCont m => Monad (HandleWriterT w m)
MonadCont
    )

instance MonadReader r m => MonadReader r (HandleWriterT w m) where
  ask :: HandleWriterT w m r
ask = ReaderT (Env w) m r -> HandleWriterT w m r
forall w (m :: * -> *) a.
ReaderT (Env w) m a -> HandleWriterT w m a
HandleWriterT (ReaderT (Env w) m r -> HandleWriterT w m r)
-> ReaderT (Env w) m r -> HandleWriterT w m r
forall a b. (a -> b) -> a -> b
$ m r -> ReaderT (Env w) m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> HandleWriterT w m a -> HandleWriterT w m a
local r -> r
f (HandleWriterT ReaderT (Env w) m a
ma) =
    ReaderT (Env w) m a -> HandleWriterT w m a
forall w (m :: * -> *) a.
ReaderT (Env w) m a -> HandleWriterT w m a
HandleWriterT (ReaderT (Env w) m a -> HandleWriterT w m a)
-> ReaderT (Env w) m a -> HandleWriterT w m a
forall a b. (a -> b) -> a -> b
$ ReaderT (Env w) m (Env w)
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT (Env w) m (Env w)
-> (Env w -> ReaderT (Env w) m a) -> ReaderT (Env w) m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> ReaderT (Env w) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT (Env w) m a)
-> (Env w -> m a) -> Env w -> ReaderT (Env w) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (m a -> m a) -> (Env w -> m a) -> Env w -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (Env w) m a -> Env w -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Env w) m a
ma

{- | The 'MonadTell' law @tell (a <> b) ≡ tell a *> tell b@ is only obeyed when
 the 'Handle' is written to by a single thread.
-}
instance (Monoid w, MonadIO m) => MonadTell w (HandleWriterT w m) where
  tell :: w -> HandleWriterT w m ()
tell w
w =
    ReaderT (Env w) m () -> HandleWriterT w m ()
forall w (m :: * -> *) a.
ReaderT (Env w) m a -> HandleWriterT w m a
HandleWriterT (ReaderT (Env w) m () -> HandleWriterT w m ())
-> ReaderT (Env w) m () -> HandleWriterT w m ()
forall a b. (a -> b) -> a -> b
$ do
      Env Handle
handle Handle -> w -> IO ()
f <- ReaderT (Env w) m (Env w)
forall r (m :: * -> *). MonadReader r m => m r
ask
      IO () -> ReaderT (Env w) m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (Env w) m ()) -> IO () -> ReaderT (Env w) m ()
forall a b. (a -> b) -> a -> b
$ Handle -> w -> IO ()
f Handle
handle w
w

runHandleWriterT ::
  -- | Target file handle
  Handle ->
  -- | The function that will write to the file handle
  (Handle -> w -> IO ()) ->
  HandleWriterT w m a ->
  m a
runHandleWriterT :: Handle -> (Handle -> w -> IO ()) -> HandleWriterT w m a -> m a
runHandleWriterT Handle
handle Handle -> w -> IO ()
f = (ReaderT (Env w) m a -> Env w -> m a)
-> Env w -> ReaderT (Env w) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Env w) m a -> Env w -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Handle -> (Handle -> w -> IO ()) -> Env w
forall w. Handle -> (Handle -> w -> IO ()) -> Env w
Env Handle
handle Handle -> w -> IO ()
f) (ReaderT (Env w) m a -> m a)
-> (HandleWriterT w m a -> ReaderT (Env w) m a)
-> HandleWriterT w m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleWriterT w m a -> ReaderT (Env w) m a
forall w (m :: * -> *) a.
HandleWriterT w m a -> ReaderT (Env w) m a
unHandleWriterT