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

module Yesod.Trans.Class.Reader
  ( ReaderSite (..)
  , runReaderSite

  , SiteReader (..)
  ) where

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

import Data.Copointed
import Yesod.Core
  ( RenderRoute (..)
  )

-- | The class of sites which can read some data
class SiteReader r site | site -> r where
  {-# MINIMAL (ask | reader), local #-}
  -- | Get the data value
  ask :: (MonadSite m) => m site r
  ask = (r -> r) -> m site r
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> a) -> m site a
reader r -> r
forall a. a -> a
id
  -- | Extract a value from the data
  reader :: (MonadSite m) => (r -> a) -> m site a
  reader r -> a
f = r -> a
f (r -> a) -> m site r -> m site a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m site r
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask

  -- | Run a computation with a transformed version of the current data
  -- value
  local :: (MonadSite m) => (r -> r) -> m site a -> m site a

instance {-# OVERLAPPABLE #-}
  (SiteTrans t, SiteReader r site) => SiteReader r (t site) where
  ask :: m (t site) r
ask = m site r -> m (t site) r
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift m site r
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
  reader :: (r -> a) -> m (t site) a
reader r -> a
f = 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) -> m site a -> m (t site) a
forall a b. (a -> b) -> a -> b
$ (r -> a) -> m site a
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> a) -> m site a
reader r -> a
f

  local :: (r -> r) -> m (t site) a -> m (t site) a
local r -> r
f = (m site a -> m site a) -> m (t site) a -> 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 ((r -> r) -> m site a -> m site a
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> r) -> m site a -> m site a
local r -> r
f)

-- | A site transformation which extends a site with some additional data
-- which can be read
data ReaderSite r site = ReaderSite
  { ReaderSite r site -> r
readVal :: r
  , ReaderSite r site -> site
unReaderSite :: site
  }

-- | Compute the effect of 'ReaderSite' by passing in the data value to be
-- used when reading
runReaderSite
  :: (MonadSite m)
  => r
  -> m (ReaderSite r site) a
  -> m site a
runReaderSite :: r -> m (ReaderSite r site) a -> m site a
runReaderSite r
r
  = (site -> ReaderSite r site) -> m (ReaderSite r site) a -> m site a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT (r -> site -> ReaderSite r site
forall r site. r -> site -> ReaderSite r site
ReaderSite r
r)

instance Copointed (ReaderSite r) where
  copoint :: ReaderSite r a -> a
copoint = ReaderSite r a -> a
forall r a. ReaderSite r a -> a
unReaderSite

instance {-# OVERLAPPING #-} SiteReader r (ReaderSite r site) where
  ask :: m (ReaderSite r site) r
ask = do
    ReaderSite r
r site
_ <- m (ReaderSite r site) (ReaderSite r site)
forall (m :: * -> * -> *) site. MonadSite m => m site site
askSite
    r -> m (ReaderSite r site) r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r

  local :: (r -> r) -> m (ReaderSite r site) a -> m (ReaderSite r site) a
local r -> r
f = (ReaderSite r site -> ReaderSite r site)
-> m (ReaderSite r site) a -> m (ReaderSite r site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT (\(ReaderSite r
r site
site) -> r -> site -> ReaderSite r site
forall r site. r -> site -> ReaderSite r site
ReaderSite (r -> r
f r
r) site
site)

instance RenderRoute site => RenderRoute (ReaderSite r site) where
  newtype Route (ReaderSite r site) = ReaderRoute (Route site)
  renderRoute :: Route (ReaderSite r site) -> ([Text], [(Text, Text)])
renderRoute (ReaderRoute route) = Route site -> ([Text], [(Text, Text)])
forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
renderRoute Route site
route

deriving instance Eq (Route site) => Eq (Route (ReaderSite r site))

instance SiteTrans (ReaderSite r) where
  lift :: m site a -> m (ReaderSite r site) a
lift = (ReaderSite r site -> site) -> m site a -> m (ReaderSite r site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite r site -> site
forall r a. ReaderSite r a -> a
unReaderSite

  mapSiteT :: (m site a -> n site' b)
-> m (ReaderSite r site) a -> n (ReaderSite r site') b
mapSiteT m site a -> n site' b
runner m (ReaderSite r site) a
argM = do
    ReaderSite r
r site'
_ <- n (ReaderSite r site') (ReaderSite r site')
forall (m :: * -> * -> *) site. MonadSite m => m site site
askSite
    (ReaderSite r site' -> site')
-> n site' b -> n (ReaderSite r site') b
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite r site' -> site'
forall r a. ReaderSite r a -> a
unReaderSite (n site' b -> n (ReaderSite r site') b)
-> n site' b -> n (ReaderSite r site') b
forall a b. (a -> b) -> a -> b
$ m site a -> n site' b
runner (m site a -> n site' b) -> m site a -> n site' b
forall a b. (a -> b) -> a -> b
$ (site -> ReaderSite r site) -> m (ReaderSite r site) a -> m site a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT (r -> site -> ReaderSite r site
forall r site. r -> site -> ReaderSite r site
ReaderSite r
r) m (ReaderSite r site) a
argM