{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Yesod.Trans.Class.Writer
  ( WriterSite (..)
  , runWriterSite

  , SiteWriter (..)
  ) where

import Yesod.Site.Class
import Yesod.Trans.Class
import Yesod.Trans.Class.Reader

import Data.Copointed
import Data.IORef
import Yesod.Core
  ( liftIO
  , RenderRoute (..)
  )

-- TODO: Decide if we want a lazy/strict distinction

-- | The class of sites which have some writing output
class (Monoid w) => SiteWriter w site | site -> w where
  {-# MINIMAL (writer | tell), listen, pass #-}

  -- | Write something to the output, returning a wrapped value
  writer :: (MonadSite m) => (a, w) -> m site a
  writer (a
a, w
w) = w -> m site ()
forall w site (m :: * -> * -> *).
(SiteWriter w site, MonadSite m) =>
w -> m site ()
tell w
w m site () -> m site a -> m site a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m site a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

  -- | Write something to the output
  tell :: (MonadSite m) => w -> m site ()
  tell w
w = ((), w) -> m site ()
forall w site (m :: * -> * -> *) a.
(SiteWriter w site, MonadSite m) =>
(a, w) -> m site a
writer ((), w
w)

  -- | Run a computation, returning the resulting contents of the output
  listen :: (MonadSite m) => m site a -> m site (a, w)

  -- | Run a computation which modifies the output
  pass :: MonadSite m => m site (a, w -> w) -> m site a

instance {-# OVERLAPPABLE #-}
  (SiteTrans t, SiteWriter w site) => SiteWriter w (t site) where
  writer :: (a, w) -> m (t site) a
writer = m site a -> m (t site) a
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift (m site a -> m (t site) a)
-> ((a, w) -> m site a) -> (a, w) -> m (t site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m site a
forall w site (m :: * -> * -> *) a.
(SiteWriter w site, MonadSite m) =>
(a, w) -> m site a
writer
  tell :: w -> m (t site) ()
tell = m site () -> m (t site) ()
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift (m site () -> m (t site) ())
-> (w -> m site ()) -> w -> m (t site) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m site ()
forall w site (m :: * -> * -> *).
(SiteWriter w site, MonadSite m) =>
w -> m site ()
tell

  listen :: m (t site) a -> m (t site) (a, w)
listen = (m site a -> m site (a, w)) -> m (t site) a -> m (t site) (a, w)
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT m site a -> m site (a, w)
forall w site (m :: * -> * -> *) a.
(SiteWriter w site, MonadSite m) =>
m site a -> m site (a, w)
listen
  pass :: m (t site) (a, w -> w) -> m (t site) a
pass = (m site (a, w -> w) -> m site a)
-> m (t site) (a, w -> w) -> m (t site) a
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT m site (a, w -> w) -> m site a
forall w site (m :: * -> * -> *) a.
(SiteWriter w site, MonadSite m) =>
m site (a, w -> w) -> m site a
pass

-- | A site transformation which extends a site with some writing output
newtype WriterSite w site = WriterSite
  { WriterSite w site -> ReaderSite (IORef w) site
unWriterSite :: ReaderSite (IORef w) site
    -- "Is an IORef safe in Yesod sites?"
    --
    -- Yes, because the Yesod code uses one to build its web pages.
  }

-- | Compute the effect of a 'WriterSite', getting back the output after having
-- run the computation
runWriterSite
  :: (MonadSite m, Monoid w)
  => m (WriterSite w site) a
  -> m site (a, w)
runWriterSite :: m (WriterSite w site) a -> m site (a, w)
runWriterSite m (WriterSite w site) a
inner = do
  IORef w
wRef <- IO (IORef w) -> m site (IORef w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (w -> IO (IORef w)
forall a. a -> IO (IORef a)
newIORef w
forall a. Monoid a => a
mempty)
  a
a <- IORef w -> m (ReaderSite (IORef w) site) a -> m site a
forall (m :: * -> * -> *) r site a.
MonadSite m =>
r -> m (ReaderSite r site) a -> m site a
runReaderSite IORef w
wRef (m (ReaderSite (IORef w) site) a -> m site a)
-> m (ReaderSite (IORef w) site) a -> m site a
forall a b. (a -> b) -> a -> b
$ (ReaderSite (IORef w) site -> WriterSite w site)
-> m (WriterSite w site) a -> m (ReaderSite (IORef w) site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (IORef w) site -> WriterSite w site
forall w site. ReaderSite (IORef w) site -> WriterSite w site
WriterSite (m (WriterSite w site) a -> m (ReaderSite (IORef w) site) a)
-> m (WriterSite w site) a -> m (ReaderSite (IORef w) site) a
forall a b. (a -> b) -> a -> b
$ m (WriterSite w site) a
inner
  w
w <- IO w -> m site w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO w -> m site w) -> IO w -> m site w
forall a b. (a -> b) -> a -> b
$ IORef w -> IO w
forall a. IORef a -> IO a
readIORef IORef w
wRef
  (a, w) -> m site (a, w)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, w
w)

instance Copointed (WriterSite w) where
  copoint :: WriterSite w a -> a
copoint = ReaderSite (IORef w) a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (ReaderSite (IORef w) a -> a)
-> (WriterSite w a -> ReaderSite (IORef w) a)
-> WriterSite w a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterSite w a -> ReaderSite (IORef w) a
forall w site. WriterSite w site -> ReaderSite (IORef w) site
unWriterSite

instance {-# OVERLAPPING #-} (Monoid w) => SiteWriter w (WriterSite w site) where
  tell :: w -> m (WriterSite w site) ()
tell w
v = (WriterSite w site -> ReaderSite (IORef w) site)
-> m (ReaderSite (IORef w) site) () -> m (WriterSite w site) ()
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT WriterSite w site -> ReaderSite (IORef w) site
forall w site. WriterSite w site -> ReaderSite (IORef w) site
unWriterSite do
    IORef w
wRef <- m (ReaderSite (IORef w) site) (IORef w)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
    IO () -> m (ReaderSite (IORef w) site) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m (ReaderSite (IORef w) site) ())
-> IO () -> m (ReaderSite (IORef w) site) ()
forall a b. (a -> b) -> a -> b
$ IORef w -> (w -> w) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef w
wRef (w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
v)

  listen :: m (WriterSite w site) a -> m (WriterSite w site) (a, w)
listen m (WriterSite w site) a
argM = do
    a
a <- m (WriterSite w site) a
argM
    (WriterSite w site -> ReaderSite (IORef w) site)
-> m (ReaderSite (IORef w) site) (a, w)
-> m (WriterSite w site) (a, w)
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT WriterSite w site -> ReaderSite (IORef w) site
forall w site. WriterSite w site -> ReaderSite (IORef w) site
unWriterSite do
      IORef w
wRef <- m (ReaderSite (IORef w) site) (IORef w)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
      w
w <- IO w -> m (ReaderSite (IORef w) site) w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO w -> m (ReaderSite (IORef w) site) w)
-> IO w -> m (ReaderSite (IORef w) site) w
forall a b. (a -> b) -> a -> b
$ IORef w -> IO w
forall a. IORef a -> IO a
readIORef IORef w
wRef
      (a, w) -> m (ReaderSite (IORef w) site) (a, w)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, w
w)

  pass :: m (WriterSite w site) (a, w -> w) -> m (WriterSite w site) a
pass m (WriterSite w site) (a, w -> w)
modM = do
    (a
a, w -> w
f) <- m (WriterSite w site) (a, w -> w)
modM
    (WriterSite w site -> ReaderSite (IORef w) site)
-> m (ReaderSite (IORef w) site) a -> m (WriterSite w site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT WriterSite w site -> ReaderSite (IORef w) site
forall w site. WriterSite w site -> ReaderSite (IORef w) site
unWriterSite do
      IORef w
wRef <- m (ReaderSite (IORef w) site) (IORef w)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
      IO () -> m (ReaderSite (IORef w) site) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m (ReaderSite (IORef w) site) ())
-> IO () -> m (ReaderSite (IORef w) site) ()
forall a b. (a -> b) -> a -> b
$ IORef w -> (w -> w) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef w
wRef w -> w
f
      a -> m (ReaderSite (IORef w) site) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

instance RenderRoute site => RenderRoute (WriterSite w site) where
  newtype Route (WriterSite w site) = WriterRoute (Route (ReaderSite (IORef w) site))
  renderRoute :: Route (WriterSite w site) -> ([Text], [(Text, Text)])
renderRoute (WriterRoute route) = Route (ReaderSite (IORef w) site) -> ([Text], [(Text, Text)])
forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
renderRoute Route (ReaderSite (IORef w) site)
route

deriving instance Eq (Route site) => Eq (Route (WriterSite w site))

instance SiteTrans (WriterSite w) where
  lift :: m site a -> m (WriterSite w site) a
lift = (WriterSite w site -> ReaderSite (IORef w) site)
-> m (ReaderSite (IORef w) site) a -> m (WriterSite w site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT WriterSite w site -> ReaderSite (IORef w) site
forall w site. WriterSite w site -> ReaderSite (IORef w) site
unWriterSite (m (ReaderSite (IORef w) site) a -> m (WriterSite w site) a)
-> (m site a -> m (ReaderSite (IORef w) site) a)
-> m site a
-> m (WriterSite w site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m site a -> m (ReaderSite (IORef w) site) a
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift

  mapSiteT :: (m site a -> n site' b)
-> m (WriterSite w site) a -> n (WriterSite w site') b
mapSiteT m site a -> n site' b
runner m (WriterSite w site) a
argM = do
    (WriterSite w site' -> ReaderSite (IORef w) site')
-> n (ReaderSite (IORef w) site') b -> n (WriterSite w site') b
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT WriterSite w site' -> ReaderSite (IORef w) site'
forall w site. WriterSite w site -> ReaderSite (IORef w) site
unWriterSite (n (ReaderSite (IORef w) site') b -> n (WriterSite w site') b)
-> n (ReaderSite (IORef w) site') b -> n (WriterSite w site') b
forall a b. (a -> b) -> a -> b
$ (m site a -> n site' b)
-> m (ReaderSite (IORef w) site) a
-> n (ReaderSite (IORef w) site') b
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT m site a -> n site' b
runner (m (ReaderSite (IORef w) site) a
 -> n (ReaderSite (IORef w) site') b)
-> m (ReaderSite (IORef w) site) a
-> n (ReaderSite (IORef w) site') b
forall a b. (a -> b) -> a -> b
$ (ReaderSite (IORef w) site -> WriterSite w site)
-> m (WriterSite w site) a -> m (ReaderSite (IORef w) site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (IORef w) site -> WriterSite w site
forall w site. ReaderSite (IORef w) site -> WriterSite w site
WriterSite m (WriterSite w site) a
argM