{-# LANGUAGE RankNTypes #-}
module Network.IRC.Client.Internal.Lens where
import Control.Applicative (Const(..))
import Control.Concurrent.STM (STM, TVar, atomically, readTVar,
readTVarIO, writeTVar)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Functor.Contravariant (Contravariant)
import Data.Functor.Identity (Identity(..))
import Data.Monoid (First(..))
import Data.Profunctor (Choice)
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type Lens' s a = Lens s s a a
type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s
type Getting r s a = (a -> Const r a) -> s -> Const r s
type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
type Prism' s a = Prism s s a a
{-# INLINE get #-}
get :: Getting a s a -> s -> a
get :: Getting a s a -> s -> a
get Getting a s a
lens = Const a s -> a
forall a k (b :: k). Const a b -> a
getConst (Const a s -> a) -> (s -> Const a s) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting a s a
lens a -> Const a a
forall k a (b :: k). a -> Const a b
Const
{-# INLINE set #-}
set :: Lens' s a -> a -> s -> s
set :: Lens' s a -> a -> s -> s
set Lens' s a
lens a
a = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> s -> Identity s
Lens' s a
lens (\a
_ -> a -> Identity a
forall a. a -> Identity a
Identity a
a)
{-# INLINE modify #-}
modify :: Lens' s a -> (a -> a) -> s -> s
modify :: Lens' s a -> (a -> a) -> s -> s
modify Lens' s a
lens a -> a
f s
s = let a :: a
a = Getting a s a -> s -> a
forall a s. Getting a s a -> s -> a
get Getting a s a
Lens' s a
lens s
s in Lens' s a -> a -> s -> s
forall s a. Lens' s a -> a -> s -> s
set Lens' s a
lens (a -> a
f a
a) s
s
{-# INLINE preview #-}
preview :: Prism' s a -> s -> Maybe a
preview :: Prism' s a -> s -> Maybe a
preview Prism' s a
lens = First a -> Maybe a
forall a. First a -> Maybe a
getFirst (First a -> Maybe a) -> (s -> First a) -> s -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (First a) s -> First a
forall a k (b :: k). Const a b -> a
getConst (Const (First a) s -> First a)
-> (s -> Const (First a) s) -> s -> First a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const (First a) a) -> s -> Const (First a) s
Prism' s a
lens (First a -> Const (First a) a
forall k a (b :: k). a -> Const a b
Const (First a -> Const (First a) a)
-> (a -> First a) -> a -> Const (First a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> (a -> Maybe a) -> a -> First a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
snapshot :: MonadIO m => Getting (TVar a) s (TVar a) -> s -> m a
snapshot :: Getting (TVar a) s (TVar a) -> s -> m a
snapshot Getting (TVar a) s (TVar a)
lens = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (s -> IO a) -> s -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> IO a
forall a. TVar a -> IO a
readTVarIO (TVar a -> IO a) -> (s -> TVar a) -> s -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TVar a) s (TVar a) -> s -> TVar a
forall a s. Getting a s a -> s -> a
get Getting (TVar a) s (TVar a)
lens
snapshotModify :: MonadIO m => Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b
snapshotModify :: Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b
snapshotModify Lens' s (TVar a)
lens a -> STM (a, b)
f s
s = IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (STM b -> IO b) -> STM b -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM b -> IO b
forall a. STM a -> IO a
atomically (STM b -> m b) -> STM b -> m b
forall a b. (a -> b) -> a -> b
$ do
let avar :: TVar a
avar = Getting (TVar a) s (TVar a) -> s -> TVar a
forall a s. Getting a s a -> s -> a
get Getting (TVar a) s (TVar a)
Lens' s (TVar a)
lens s
s
a
a <- TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
avar
(a
a', b
b) <- a -> STM (a, b)
f a
a
TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
avar a
a'
b -> STM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b