{-# 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 TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

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

{-# OPTIONS_HADDOCK hide #-}

module Capability.State.Internal.Strategies
  ( MonadState(..)
  , ReaderIORef(..)
  , ReaderRef(..)
  ) where

import Capability.Accessors
import Capability.Reader.Internal.Class
import Capability.State.Internal.Class
import Capability.State.Internal.Strategies.Common
import Capability.Source.Internal.Strategies ()
import Capability.Sink.Internal.Strategies ()
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.State.Class as State
import Control.Monad.Trans.Class (MonadTrans, lift)
import Data.Coerce (Coercible, coerce)
import qualified Data.Generics.Product.Fields as Generic
import qualified Data.Generics.Product.Positions as Generic
import Data.IORef
import Data.Kind (Type)
import Data.Mutable
import GHC.Exts (Proxy#)

instance State.MonadState s m => HasState tag s (MonadState m) where
  state_ :: forall a. Proxy# tag -> (s -> (a, s)) -> MonadState m a
  state_ :: Proxy# tag -> (s -> (a, s)) -> MonadState m a
state_ Proxy# tag
_ = ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> MonadState m a
coerce @((s -> (a, s)) -> m a) (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state
  {-# INLINE state_ #-}

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

-- | Rename the tag.
instance HasState oldtag s m => HasState newtag s (Rename oldtag m) where
  state_ :: forall a. Proxy# newtag -> (s -> (a, s)) -> Rename oldtag m a
  state_ :: Proxy# newtag -> (s -> (a, s)) -> Rename oldtag m a
state_ Proxy# newtag
_ = forall b.
Coercible ((s -> (a, s)) -> m a) b =>
((s -> (a, s)) -> m a) -> b
coerce @((s -> (a, s)) -> m a) (((s -> (a, s)) -> m a) -> (s -> (a, s)) -> Rename oldtag m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> Rename oldtag m a
forall a b. (a -> b) -> a -> b
$ forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall s (m :: * -> *) a.
HasState oldtag s m =>
(s -> (a, s)) -> m a
state @oldtag
  {-# INLINE state_ #-}

-- | Zoom in on the record field @field@ of type @v@ in the state @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, HasState oldtag record m )
  => HasState tag v (Field field oldtag m)
  where
    state_ :: forall a.
      Proxy# tag
      -> (v -> (a, v))
      -> Field field oldtag m a
    state_ :: Proxy# tag -> (v -> (a, v)) -> Field field oldtag m a
state_ Proxy# tag
_ = forall b.
Coercible ((v -> (a, v)) -> m a) b =>
((v -> (a, v)) -> m a) -> b
coerce @((v -> (a, v)) -> m a) (((v -> (a, v)) -> m a) -> (v -> (a, v)) -> Field field oldtag m a)
-> ((v -> (a, v)) -> m a)
-> (v -> (a, v))
-> Field field oldtag m a
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall s (m :: * -> *) a.
HasState oldtag s m =>
(s -> (a, s)) -> m a
state @oldtag ((record -> (a, record)) -> m a)
-> ((v -> (a, v)) -> record -> (a, record)) -> (v -> (a, v)) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Functor ((,) a) => (v -> (a, v)) -> record -> (a, record)
forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
Generic.field' @field @_ @_ @((,) a)
    {-# INLINE state_ #-}

-- | Zoom in on the field at position @pos@ of type @v@ in the state @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, HasState oldtag struct m )
  => HasState tag v (Pos pos oldtag m)
  where
    state_ :: forall a.
      Proxy# tag
      -> (v -> (a, v))
      -> Pos pos oldtag m a
    state_ :: Proxy# tag -> (v -> (a, v)) -> Pos pos oldtag m a
state_ Proxy# tag
_ = forall b.
Coercible ((v -> (a, v)) -> m a) b =>
((v -> (a, v)) -> m a) -> b
coerce @((v -> (a, v)) -> m a) (((v -> (a, v)) -> m a) -> (v -> (a, v)) -> Pos pos oldtag m a)
-> ((v -> (a, v)) -> m a) -> (v -> (a, v)) -> Pos pos oldtag m a
forall a b. (a -> b) -> a -> b
$
      forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall s (m :: * -> *) a.
HasState oldtag s m =>
(s -> (a, s)) -> m a
state @oldtag ((struct -> (a, struct)) -> m a)
-> ((v -> (a, v)) -> struct -> (a, struct)) -> (v -> (a, v)) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Functor ((,) a) => (v -> (a, v)) -> struct -> (a, struct)
forall (i :: Nat) s a. HasPosition' i s a => Lens s s a a
Generic.position' @pos @_ @_ @((,) a)
    {-# INLINE state_ #-}

-- | Lift one layer in a monad transformer stack.
instance (HasState tag s m, MonadTrans t, Monad (t m))
  => HasState tag s (Lift (t m))
  where
    state_ :: forall a. Proxy# tag -> (s -> (a, s)) -> Lift (t m) a
    state_ :: Proxy# tag -> (s -> (a, s)) -> Lift (t m) a
state_ Proxy# tag
_ = ((s -> (a, s)) -> t m a) -> (s -> (a, s)) -> Lift (t m) a
coerce (((s -> (a, s)) -> t m a) -> (s -> (a, s)) -> Lift (t m) a)
-> ((s -> (a, s)) -> t m a) -> (s -> (a, s)) -> Lift (t m) a
forall a b. (a -> b) -> a -> b
$ forall a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift @t @m (m a -> t m a) -> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasState tag s m => (s -> (a, s)) -> m a
forall k (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
state @tag @s @m @a
    {-# INLINE state_ #-}

-- | 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, HasState tag s (t2 (t1 m)) )
  => HasState tag s ((t2 :.: t1) m)

instance
  (HasReader tag (IORef s) m, MonadIO m)
  => HasState tag s (ReaderIORef m)
  where
    state_ :: Proxy# tag -> (s -> (a, s)) -> ReaderIORef m a
state_ Proxy# tag
_ s -> (a, s)
f = m a -> ReaderIORef m a
forall k (m :: k -> *) (a :: k). m a -> ReaderIORef m a
ReaderIORef (m a -> ReaderIORef m a) -> m a -> ReaderIORef m a
forall a b. (a -> b) -> a -> b
$ do
      IORef s
ref <- forall k (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall r (m :: * -> *). HasReader tag r m => m r
ask @tag
      IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IORef s -> (s -> (s, a)) -> IO a
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef s
ref ((a, s) -> (s, a)
forall b a. (b, a) -> (a, b)
swap ((a, s) -> (s, a)) -> (s -> (a, s)) -> s -> (s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (a, s)
f)
      where
        swap :: (b, a) -> (a, b)
swap (b
a, a
b) = (a
b, b
a)
    {-# INLINE state_ #-}

instance
  ( MutableRef ref, RefElement ref ~ s
  , HasReader tag ref m, PrimMonad m, PrimState m ~ MCState ref )
  => HasState tag s (ReaderRef m)
  where
    state_ :: Proxy# tag -> (s -> (a, s)) -> ReaderRef m a
state_ Proxy# tag
_ s -> (a, s)
f = m a -> ReaderRef m a
forall (m :: * -> *) a. m a -> ReaderRef m a
ReaderRef (m a -> ReaderRef m a) -> m a -> ReaderRef m a
forall a b. (a -> b) -> a -> b
$ do
      ref
ref <- forall k (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall r (m :: * -> *). HasReader tag r m => m r
ask @tag
      s
s <- ref -> m (RefElement ref)
forall c (m :: * -> *).
(MutableRef c, PrimMonad m, PrimState m ~ MCState c) =>
c -> m (RefElement c)
readRef ref
ref
      let (a
a, s
s') = s -> (a, s)
f s
s
      ref -> RefElement ref -> m ()
forall c (m :: * -> *).
(MutableRef c, PrimMonad m, PrimState m ~ MCState c) =>
c -> RefElement c -> m ()
writeRef ref
ref s
RefElement ref
s'
      a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    {-# INLINE state_ #-}