{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}

-- | Defines discouraged instances of writer monad capabilities.

module Capability.Writer.Discouraged
  ( ) where

import Capability.Accessors
import Capability.Writer
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Unlift (MonadTransUnlift, Unlift(..), askUnlift)
import Data.Coerce (coerce)
import GHC.Exts (Proxy#)

-- | Lift one layer in a monad transformer stack.
--
-- Note, that if the 'HasWriter' instance is based on 'HasState', then it is
-- more efficient to apply 'Lift' to the underlying state capability. E.g.
-- you should favour
--
-- > deriving (HasWriter tag w) via
-- >   WriterLog (Lift (SomeTrans (MonadState SomeStateMonad)))
--
-- over
--
-- > deriving (HasWriter tag w) via
-- >   Lift (SomeTrans (WriterLog (MonadState SomeStateMonad)))
instance
  -- MonadTransUnlift constraint requires -Wno-simplifiable-class-constraints
  (HasWriter tag w m, MonadTransUnlift t, Monad (t m))
  => HasWriter tag w (Lift (t m))
  where
    writer_ :: forall a. Proxy# tag -> (a, w) -> Lift (t m) a
    writer_ :: Proxy# tag -> (a, w) -> Lift (t m) a
writer_ Proxy# tag
_ = forall b. Coercible ((a, w) -> t m a) b => ((a, w) -> t m a) -> b
coerce @((a, w) -> t m a) (((a, w) -> t m a) -> (a, w) -> Lift (t m) a)
-> ((a, w) -> t m a) -> (a, w) -> Lift (t m) a
forall a b. (a -> b) -> a -> b
$ m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> ((a, w) -> m a) -> (a, w) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (tag :: k) w (m :: * -> *) a.
HasWriter tag w m =>
(a, w) -> m a
forall w (m :: * -> *) a. HasWriter tag w m => (a, w) -> m a
writer @tag
    {-# INLINE writer_ #-}
    listen_ :: forall a. Proxy# tag -> Lift (t m) a -> Lift (t m) (a, w)
    listen_ :: Proxy# tag -> Lift (t m) a -> Lift (t m) (a, w)
listen_ Proxy# tag
_ = forall b.
Coercible (t m a -> t m (a, w)) b =>
(t m a -> t m (a, w)) -> b
coerce @(t m a -> t m (a, w)) ((t m a -> t m (a, w)) -> Lift (t m) a -> Lift (t m) (a, w))
-> (t m a -> t m (a, w)) -> Lift (t m) a -> Lift (t m) (a, w)
forall a b. (a -> b) -> a -> b
$ \t m a
m -> do
      Unlift t
u <- t m (Unlift t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTransUnlift t, Monad m) =>
t m (Unlift t)
askUnlift
      m (a, w) -> t m (a, w)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> t m (a, w)) -> m (a, w) -> t m (a, w)
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) w (m :: * -> *) a.
HasWriter tag w m =>
m a -> m (a, w)
forall w (m :: * -> *) a. HasWriter tag w m => m a -> m (a, w)
listen @tag (m a -> m (a, w)) -> m a -> m (a, w)
forall a b. (a -> b) -> a -> b
$ Unlift t -> t m a -> m a
forall (t :: (* -> *) -> * -> *).
Unlift t -> forall a (n :: * -> *). Monad n => t n a -> n a
unlift Unlift t
u t m a
m
    {-# INLINE listen_ #-}
    pass_ :: forall a. Proxy# tag -> Lift (t m) (a, w -> w) -> Lift (t m) a
    pass_ :: Proxy# tag -> Lift (t m) (a, w -> w) -> Lift (t m) a
pass_ Proxy# tag
_ = forall b.
Coercible (t m (a, w -> w) -> t m a) b =>
(t m (a, w -> w) -> t m a) -> b
coerce @(t m (a, w -> w) -> t m a) ((t m (a, w -> w) -> t m a)
 -> Lift (t m) (a, w -> w) -> Lift (t m) a)
-> (t m (a, w -> w) -> t m a)
-> Lift (t m) (a, w -> w)
-> Lift (t m) a
forall a b. (a -> b) -> a -> b
$ \t m (a, w -> w)
m -> do
      Unlift t
u <- t m (Unlift t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTransUnlift t, Monad m) =>
t m (Unlift t)
askUnlift
      m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> m a -> t m a
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) w (m :: * -> *) a.
HasWriter tag w m =>
m (a, w -> w) -> m a
forall w (m :: * -> *) a. HasWriter tag w m => m (a, w -> w) -> m a
pass @tag (m (a, w -> w) -> m a) -> m (a, w -> w) -> m a
forall a b. (a -> b) -> a -> b
$ Unlift t -> t m (a, w -> w) -> m (a, w -> w)
forall (t :: (* -> *) -> * -> *).
Unlift t -> forall a (n :: * -> *). Monad n => t n a -> n a
unlift Unlift t
u t m (a, w -> w)
m
    {-# INLINE pass_ #-}