{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE QuantifiedConstraints #-}

module Yesod.Site.Class
  ( MonadSite (..)
  ) where

import Yesod.Site.Util

import Control.Monad.Reader
import Yesod.Core.Types

-- | A unified class instance for Yesod's site-using monads
--
-- This is used for functions which work for both 'WidgetFor' and 'HandlerFor'.
class (forall site. MonadIO (m site)) => MonadSite (m :: * -> * -> *) where
  -- | Get the site itself in a computation
  askSite :: m site site

  -- | Run a computation under a given site transformation
  --
  -- This is the main entry point for site transformations - note that the
  -- site parameter is contravariant.
  withSiteT
    :: SiteCompatible site site'
    => (site -> site')
    -> m site' a
    -> m site a

instance MonadSite HandlerFor where
  askSite :: HandlerFor site site
askSite = do
    HandlerData site site
hd <- HandlerFor site (HandlerData site site)
forall r (m :: * -> *). MonadReader r m => m r
ask
    site -> HandlerFor site site
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HandlerData site site -> site
forall child site. HandlerData child site -> site
getSite HandlerData site site
hd)

  withSiteT :: (site -> site') -> HandlerFor site' a -> HandlerFor site a
withSiteT site -> site'
siteT (HandlerFor HandlerData site' site' -> IO a
innerHandler)
    = (HandlerData site site -> IO a) -> HandlerFor site a
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor (HandlerData site' site' -> IO a
innerHandler (HandlerData site' site' -> IO a)
-> (HandlerData site site -> HandlerData site' site')
-> HandlerData site site
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (site -> site') -> HandlerData site site -> HandlerData site' site'
forall site site'.
SiteCompatible site site' =>
(site -> site') -> HandlerData site site -> HandlerData site' site'
withSite site -> site'
siteT)

instance MonadSite WidgetFor where
  askSite :: WidgetFor site site
askSite = do
    WidgetData site
wd <- WidgetFor site (WidgetData site)
forall r (m :: * -> *). MonadReader r m => m r
ask
    site -> WidgetFor site site
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WidgetData site -> site
forall site. WidgetData site -> site
getWidgetSite WidgetData site
wd)

  withSiteT :: (site -> site') -> WidgetFor site' a -> WidgetFor site a
withSiteT site -> site'
siteT (WidgetFor WidgetData site' -> IO a
innerWidget)
    = (WidgetData site -> IO a) -> WidgetFor site a
forall site a. (WidgetData site -> IO a) -> WidgetFor site a
WidgetFor (WidgetData site' -> IO a
innerWidget (WidgetData site' -> IO a)
-> (WidgetData site -> WidgetData site') -> WidgetData site -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (site -> site') -> WidgetData site -> WidgetData site'
forall site site'.
SiteCompatible site site' =>
(site -> site') -> WidgetData site -> WidgetData site'
withWidgetSite site -> site'
siteT)