{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Network.IRC.Client.Internal.Lens
-- Copyright   : (c) 2017 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : experimental
-- Portability : CPP, ImpredicativeTypes
--
-- Types and functions for dealing with optics without depending on
-- the lens library.
--
-- This module is NOT considered to form part of the public interface
-- of this library.
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)


-------------------------------------------------------------------------------
-- * Internal lens synonyms

-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@.
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'.
type Lens' s a = Lens s s a a

-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getter Control.Lens.Getter.Getter>@.
type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s

-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getting Control.Lens.Getter.Getting>@.
type Getting r s a = (a -> Const r a) -> s -> Const r s

-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@.
type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Prism'.
type Prism' s a = Prism s s a a


-------------------------------------------------------------------------------
-- * Utilities

-- | Get a value from a lens.
{-# INLINE get #-}
get :: Getting a s a -> s -> a
get :: forall a s. Getting a s a -> s -> a
get Getting a s a
lens = forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting a s a
lens forall {k} a (b :: k). a -> Const a b
Const

-- | Set a value in a lens.
{-# INLINE set #-}
set :: Lens' s a -> a -> s -> s
set :: forall s a. Lens' s a -> a -> s -> s
set Lens' s a
lens a
a = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' s a
lens (\a
_ -> forall a. a -> Identity a
Identity a
a)

-- | Modify a value in a lens.
{-# INLINE modify #-}
modify :: Lens' s a -> (a -> a) -> s -> s
modify :: forall s a. Lens' s a -> (a -> a) -> s -> s
modify Lens' s a
lens a -> a
f s
s = let a :: a
a = forall a s. Getting a s a -> s -> a
get Lens' s a
lens s
s in forall s a. Lens' s a -> a -> s -> s
set Lens' s a
lens (a -> a
f a
a) s
s

-- | Read a value from a prism.
{-# INLINE preview #-}
preview :: Prism' s a -> s -> Maybe a
preview :: forall s a. Prism' s a -> s -> Maybe a
preview Prism' s a
lens = forall a. First a -> Maybe a
getFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' s a
lens (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)


-------------------------------------------------------------------------------
-- ** STM

-- | Atomically snapshot some shared state.
snapshot :: MonadIO m => Getting (TVar a) s (TVar a) -> s -> m a
snapshot :: forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot Getting (TVar a) s (TVar a)
lens = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> IO a
readTVarIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
get Getting (TVar a) s (TVar a)
lens

-- | Atomically snapshot and modify some shared state.
snapshotModify :: MonadIO m => Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b
snapshotModify :: forall (m :: * -> *) s a b.
MonadIO m =>
Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b
snapshotModify Lens' s (TVar a)
lens a -> STM (a, b)
f s
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
  let avar :: TVar a
avar = forall a s. Getting a s a -> s -> a
get Lens' s (TVar a)
lens s
s
  a
a <- forall a. TVar a -> STM a
readTVar TVar a
avar
  (a
a', b
b) <- a -> STM (a, b)
f a
a
  forall a. TVar a -> a -> STM ()
writeTVar TVar a
avar a
a'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b