{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms #-}

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

{-# OPTIONS_HADDOCK hide #-}

module Capability.Reader.Internal.Strategies
  ( MonadReader(..)
  , ReadStatePure(..)
  , ReadState(..)
  ) where

import Capability.Accessors
import Capability.Reader.Internal.Class
import Capability.State.Internal.Class
import Capability.Source.Internal.Strategies
import Control.Lens (over, view)
import Control.Monad.Catch (MonadMask, bracket)
import qualified Control.Monad.Reader.Class as Reader
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Control (MonadTransControl(..))
import Data.Coerce (Coercible, coerce)
import qualified Data.Generics.Product.Fields as Generic
import qualified Data.Generics.Product.Positions as Generic
import Data.Kind (Type)
import GHC.Exts (Proxy#)

instance Reader.MonadReader r m => HasReader tag r (MonadReader m) where
  local_
    :: forall a. Proxy# tag -> (r -> r) -> MonadReader m a -> MonadReader m a
  local_ :: Proxy# tag -> (r -> r) -> MonadReader m a -> MonadReader m a
local_ Proxy# tag
_ = ((r -> r) -> m a -> m a)
-> (r -> r) -> MonadReader m a -> MonadReader m a
coerce @((r -> r) -> m a -> m a) (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
Reader.local
  {-# INLINE local_ #-}
  reader_ :: forall a. Proxy# tag -> (r -> a) -> MonadReader m a
  reader_ :: Proxy# tag -> (r -> a) -> MonadReader m a
reader_ Proxy# tag
_ = ((r -> a) -> m a) -> (r -> a) -> MonadReader m a
coerce @((r -> a) -> m a) (r -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.reader
  {-# INLINE reader_ #-}

instance HasState tag r m => HasReader tag r (ReadStatePure m) where
  local_ :: forall a.
    Proxy# tag -> (r -> r) -> ReadStatePure m a -> ReadStatePure m a
  local_ :: Proxy# tag -> (r -> r) -> ReadStatePure m a -> ReadStatePure m a
local_ Proxy# tag
_ r -> r
f = forall b. Coercible (m a -> m a) b => (m a -> m a) -> b
coerce @(m a -> m a) ((m a -> m a) -> ReadStatePure m a -> ReadStatePure m a)
-> (m a -> m a) -> ReadStatePure m a -> ReadStatePure m a
forall a b. (a -> b) -> a -> b
$ \m a
m -> do
    r
r <- forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall s (m :: * -> *) a. HasState tag s m => (s -> (a, s)) -> m a
state @tag ((r -> (r, r)) -> m r) -> (r -> (r, r)) -> m r
forall a b. (a -> b) -> a -> b
$ \r
r -> (r
r, r -> r
f r
r)
    m a
m m a -> m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* r -> m ()
forall k (tag :: k) s (m :: * -> *). HasState tag s m => s -> m ()
put @tag r
r
  {-# INLINE local_ #-}
  reader_ :: forall a. Proxy# tag -> (r -> a) -> ReadStatePure m a
  reader_ :: Proxy# tag -> (r -> a) -> ReadStatePure m a
reader_ Proxy# tag
_ = forall b. Coercible ((r -> a) -> m a) b => ((r -> a) -> m a) -> b
coerce @((r -> a) -> m a) (((r -> a) -> m a) -> (r -> a) -> ReadStatePure m a)
-> ((r -> a) -> m a) -> (r -> a) -> ReadStatePure m a
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> a) -> m a
forall s (m :: * -> *) a. HasState tag s m => (s -> a) -> m a
gets @tag
  {-# INLINE reader_ #-}

instance
  (HasState tag r m, MonadMask m)
  => HasReader tag r (ReadState m)
  where
    local_ :: forall a.
      Proxy# tag -> (r -> r) -> ReadState m a -> ReadState m a
    local_ :: Proxy# tag -> (r -> r) -> ReadState m a -> ReadState m a
local_ Proxy# tag
_ r -> r
f = forall b. Coercible (m a -> m a) b => (m a -> m a) -> b
coerce @(m a -> m a) ((m a -> m a) -> ReadState m a -> ReadState m a)
-> (m a -> m a) -> ReadState m a -> ReadState m a
forall a b. (a -> b) -> a -> b
$ \m a
action ->
      let
        setAndSave :: m r
setAndSave = forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall s (m :: * -> *) a. HasState tag s m => (s -> (a, s)) -> m a
state @tag ((r -> (r, r)) -> m r) -> (r -> (r, r)) -> m r
forall a b. (a -> b) -> a -> b
$ \r
r -> (r
r, r -> r
f r
r)
        restore :: r -> m ()
restore r
r = r -> m ()
forall k (tag :: k) s (m :: * -> *). HasState tag s m => s -> m ()
put @tag r
r
      in
      m r -> (r -> m ()) -> (r -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m r
setAndSave r -> m ()
restore ((r -> m a) -> m a) -> (r -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \r
_ -> m a
action
    {-# INLINE local_ #-}
    reader_ :: forall a. Proxy# tag -> (r -> a) -> ReadState m a
    reader_ :: Proxy# tag -> (r -> a) -> ReadState m a
reader_ Proxy# tag
_ = forall b. Coercible ((r -> a) -> m a) b => ((r -> a) -> m a) -> b
coerce @((r -> a) -> m a) (((r -> a) -> m a) -> (r -> a) -> ReadState m a)
-> ((r -> a) -> m a) -> (r -> a) -> ReadState m a
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> a) -> m a
forall s (m :: * -> *) a. HasState tag s m => (s -> a) -> m a
gets @tag
    {-# INLINE reader_ #-}

-- | Convert the environment using safe coercion.
instance
  ( Coercible from to, HasReader tag from m
  , forall x y. Coercible x y => Coercible (m x) (m y) )
  => HasReader tag to (Coerce to m)
  where
    local_
      :: forall a. Proxy# tag -> (to -> to) -> Coerce to m a -> Coerce to m a
    local_ :: Proxy# tag -> (to -> to) -> Coerce to m a -> Coerce to m a
local_ Proxy# tag
tag = forall b.
Coercible ((from -> from) -> m a -> m a) b =>
((from -> from) -> m a -> m a) -> b
coerce @((from -> from) -> m a -> m a) (((from -> from) -> m a -> m a)
 -> (to -> to) -> Coerce to m a -> Coerce to m a)
-> ((from -> from) -> m a -> m a)
-> (to -> to)
-> Coerce to m a
-> Coerce to m a
forall a b. (a -> b) -> a -> b
$ Proxy# tag -> (from -> from) -> m a -> m a
forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
Proxy# tag -> (r -> r) -> m a -> m a
local_ Proxy# tag
tag
    {-# INLINE local_ #-}
    reader_ :: forall a. Proxy# tag -> (to -> a) -> Coerce to m a
    reader_ :: Proxy# tag -> (to -> a) -> Coerce to m a
reader_ Proxy# tag
tag = forall b.
Coercible ((from -> a) -> m a) b =>
((from -> a) -> m a) -> b
coerce @((from -> a) -> m a) (((from -> a) -> m a) -> (to -> a) -> Coerce to m a)
-> ((from -> a) -> m a) -> (to -> a) -> Coerce to m a
forall a b. (a -> b) -> a -> b
$ Proxy# tag -> (from -> a) -> m a
forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
Proxy# tag -> (r -> a) -> m a
reader_ Proxy# tag
tag
    {-# INLINE reader_ #-}

-- | Rename the tag.
instance HasReader oldtag r m => HasReader newtag r (Rename oldtag m) where
  local_ :: forall a.
    Proxy# newtag -> (r -> r) -> Rename oldtag m a -> Rename oldtag m a
  local_ :: Proxy# newtag -> (r -> r) -> Rename oldtag m a -> Rename oldtag m a
local_ Proxy# newtag
_ = forall b.
Coercible ((r -> r) -> m a -> m a) b =>
((r -> r) -> m a -> m a) -> b
coerce @((r -> r) -> m a -> m a) (((r -> r) -> m a -> m a)
 -> (r -> r) -> Rename oldtag m a -> Rename oldtag m a)
-> ((r -> r) -> m a -> m a)
-> (r -> r)
-> Rename oldtag m a
-> Rename oldtag m a
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> r) -> m a -> m a
forall r (m :: * -> *) a.
HasReader oldtag r m =>
(r -> r) -> m a -> m a
local @oldtag
  {-# INLINE local_ #-}
  reader_ :: forall a. Proxy# newtag -> (r -> a) -> Rename oldtag m a
  reader_ :: Proxy# newtag -> (r -> a) -> Rename oldtag m a
reader_ Proxy# newtag
_ = forall b. Coercible ((r -> a) -> m a) b => ((r -> a) -> m a) -> b
coerce @((r -> a) -> m a) (((r -> a) -> m a) -> (r -> a) -> Rename oldtag m a)
-> ((r -> a) -> m a) -> (r -> a) -> Rename oldtag m a
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> a) -> m a
forall r (m :: * -> *) a. HasReader oldtag r m => (r -> a) -> m a
reader @oldtag
  {-# INLINE reader_ #-}

-- | Zoom in on the record field @field@ of type @v@
-- in the environment @record@.
instance
  -- The constraint raises @-Wsimplifiable-class-constraints@.
  -- This could be avoided by instead placing @HasField'@s constraints here.
  -- Unfortunately, it uses non-exported symbols from @generic-lens@.
  ( tag ~ field, Generic.HasField' field record v, HasReader oldtag record m )
  => HasReader tag v (Field field oldtag m)
  where
    local_ :: forall a.
      Proxy# tag
      -> (v -> v)
      -> Field field oldtag m a
      -> Field field oldtag m a
    local_ :: Proxy# tag
-> (v -> v) -> Field field oldtag m a -> Field field oldtag m a
local_ Proxy# tag
_ = forall b.
Coercible ((v -> v) -> m a -> m a) b =>
((v -> v) -> m a -> m a) -> b
coerce @((v -> v) -> m a -> m a) (((v -> v) -> m a -> m a)
 -> (v -> v) -> Field field oldtag m a -> Field field oldtag m a)
-> ((v -> v) -> m a -> m a)
-> (v -> v)
-> Field field oldtag m a
-> Field field oldtag m a
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> r) -> m a -> m a
forall r (m :: * -> *) a.
HasReader oldtag r m =>
(r -> r) -> m a -> m a
local @oldtag ((record -> record) -> m a -> m a)
-> ((v -> v) -> record -> record) -> (v -> v) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter record record v v -> (v -> v) -> record -> record
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s a. HasField' field s a => Lens s s a a
forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
Generic.field' @field)
    {-# INLINE local_ #-}
    reader_ :: forall a.
      Proxy# tag
      -> (v -> a)
      -> Field field oldtag m a
    reader_ :: Proxy# tag -> (v -> a) -> Field field oldtag m a
reader_ Proxy# tag
_ v -> a
f = forall b. Coercible (m a) b => m a -> b
coerce @(m a) (m a -> Field field oldtag m a) -> m a -> Field field oldtag m a
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> a) -> m a
forall r (m :: * -> *) a. HasReader oldtag r m => (r -> a) -> m a
reader @oldtag ((record -> a) -> m a) -> (record -> a) -> m a
forall a b. (a -> b) -> a -> b
$ v -> a
f (v -> a) -> (record -> v) -> record -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting v record v -> record -> v
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s a. HasField' field s a => Lens s s a a
forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
Generic.field' @field)
    {-# INLINE reader_ #-}

-- | Zoom in on the field at position @pos@ of type @v@
-- in the environment @struct@.
instance
  -- The constraint raises @-Wsimplifiable-class-constraints@.
  -- This could be avoided by instead placing @HasPosition'@s constraints here.
  -- Unfortunately, it uses non-exported symbols from @generic-lens@.
  ( tag ~ pos, Generic.HasPosition' pos struct v, HasReader oldtag struct m )
  => HasReader tag v (Pos pos oldtag m)
  where
    local_ :: forall a.
      Proxy# tag
      -> (v -> v)
      -> Pos pos oldtag m a
      -> Pos pos oldtag m a
    local_ :: Proxy# tag -> (v -> v) -> Pos pos oldtag m a -> Pos pos oldtag m a
local_ Proxy# tag
_ = forall b.
Coercible ((v -> v) -> m a -> m a) b =>
((v -> v) -> m a -> m a) -> b
coerce @((v -> v) -> m a -> m a) (((v -> v) -> m a -> m a)
 -> (v -> v) -> Pos pos oldtag m a -> Pos pos oldtag m a)
-> ((v -> v) -> m a -> m a)
-> (v -> v)
-> Pos pos oldtag m a
-> Pos pos oldtag m a
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> r) -> m a -> m a
forall r (m :: * -> *) a.
HasReader oldtag r m =>
(r -> r) -> m a -> m a
local @oldtag ((struct -> struct) -> m a -> m a)
-> ((v -> v) -> struct -> struct) -> (v -> v) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter struct struct v v -> (v -> v) -> struct -> struct
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s a. HasPosition' pos s a => Lens s s a a
forall (i :: Nat) s a. HasPosition' i s a => Lens s s a a
Generic.position' @pos)
    {-# INLINE local_ #-}
    reader_ :: forall a.
      Proxy# tag
      -> (v -> a)
      -> Pos pos oldtag m a
    reader_ :: Proxy# tag -> (v -> a) -> Pos pos oldtag m a
reader_ Proxy# tag
_ v -> a
f = forall b. Coercible (m a) b => m a -> b
coerce @(m a) (m a -> Pos pos oldtag m a) -> m a -> Pos pos oldtag m a
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> a) -> m a
forall r (m :: * -> *) a. HasReader oldtag r m => (r -> a) -> m a
reader @oldtag ((struct -> a) -> m a) -> (struct -> a) -> m a
forall a b. (a -> b) -> a -> b
$ v -> a
f (v -> a) -> (struct -> v) -> struct -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting v struct v -> struct -> v
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s a. HasPosition' pos s a => Lens s s a a
forall (i :: Nat) s a. HasPosition' i s a => Lens s s a a
Generic.position' @pos)
    {-# INLINE reader_ #-}

-- | Lift one layer in a monad transformer stack.
instance (HasReader tag r m, MonadTransControl t, Monad (t m))
  => HasReader tag r (Lift (t m))
  where
    local_
      :: forall a. Proxy# tag -> (r -> r) -> Lift (t m) a -> Lift (t m) a
    local_ :: Proxy# tag -> (r -> r) -> Lift (t m) a -> Lift (t m) a
local_ Proxy# tag
_ r -> r
f = forall b. Coercible (t m a -> t m a) b => (t m a -> t m a) -> b
coerce @(t m a -> t m a) ((t m a -> t m a) -> Lift (t m) a -> Lift (t m) a)
-> (t m a -> t m a) -> Lift (t m) a -> Lift (t m) a
forall a b. (a -> b) -> a -> b
$
      \t m a
m -> (Run t -> m (StT t a)) -> t m (StT t a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith (\Run t
run -> (r -> r) -> m (StT t a) -> m (StT t a)
forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> r) -> m a -> m a
local @tag r -> r
f (m (StT t a) -> m (StT t a)) -> m (StT t a) -> m (StT t a)
forall a b. (a -> b) -> a -> b
$ t m a -> m (StT t a)
Run t
run t m a
m) t m (StT t a) -> (StT t a -> t m a) -> t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (StT t a) -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t a) -> t m a)
-> (StT t a -> m (StT t a)) -> StT t a -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StT t a -> m (StT t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE local_ #-}
    reader_ :: forall a. Proxy# tag -> (r -> a) -> Lift (t m) a
    reader_ :: Proxy# tag -> (r -> a) -> Lift (t m) a
reader_ Proxy# tag
_ = forall b.
Coercible ((r -> a) -> t m a) b =>
((r -> a) -> t m a) -> b
coerce @((r -> a) -> t m a) (((r -> a) -> t m a) -> (r -> a) -> Lift (t m) a)
-> ((r -> a) -> t m a) -> (r -> a) -> 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) -> ((r -> a) -> m a) -> (r -> a) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> a) -> m a
forall r (m :: * -> *) a. HasReader tag r m => (r -> a) -> m a
reader @tag
    {-# INLINE reader_ #-}

-- | Compose two accessors.
deriving via ((t2 :: (Type -> Type) -> Type -> Type) ((t1 :: (Type -> Type) -> Type -> Type) m))
  instance
  ( forall x. Coercible (m x) (t2 (t1 m) x)
  , Monad m, HasReader tag r (t2 (t1 m)) )
  => HasReader tag r ((t2 :.: t1) m)