{-# 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 :: 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

-- | Set a value in a lens.
{-# 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)

-- | Modify a value in a lens.
{-# 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

-- | Read a value from a prism.
{-# 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)


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

-- | Atomically snapshot some shared state.
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

-- | Atomically snapshot and modify some shared state.
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