{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.StateVar
-- Copyright   :  (c) Sven Panne 2009
--                (c) HATTORI,HIROKI 2014
-- License     :  BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  HATTORI, HIROKI <seagull.kamome@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- Data.StateVarがIO専用なのが気にくわないので変換できるようにしただけ
-- 
--------------------------------------------------------------------------------

module Data.StateVar.Trans (
   -- * Readable State Variables
   HasGetter(..),
   GettableStateVar, makeGettableStateVar,
   -- * Writable State Variables
   HasSetter(..),
   SettableStateVar, makeSettableStateVar,
   -- * General State Variables
   StateVar, makeStateVar, makePtrVar,
   -- * Utility Functions
   ($~), ($=!), ($~!),
   (&),
   (^=), (^~), (^=!), (^~!), (^.),
   (@=)
) where

import Data.IORef (IORef, readIORef, writeIORef)
import GHC.Conc (STM, TVar, readTVar, writeTVar)
import Data.STRef (STRef, readSTRef, writeSTRef)
import Foreign.Ptr (Ptr)
import Foreign.Storable
import Control.Monad.ST.Safe (ST)
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader.Class (MonadReader(..))

--------------------------------------------------------------------------------

infixr 2 $=

--------------------------------------------------------------------------------

-- | The class of all readable state variables.
class HasGetter g m | g -> m where
   -- | Read the value of a state variable.
   get :: g a -> m a

instance HasGetter IORef IO where
  get :: forall a. IORef a -> IO a
get = IORef a -> IO a
forall a. IORef a -> IO a
readIORef
  {-# INLINE get #-}
instance HasGetter TVar STM where
  get :: forall a. TVar a -> STM a
get = TVar a -> STM a
forall a. TVar a -> STM a
readTVar
  {-# INLINE get #-}
instance HasGetter (STRef s) (ST s) where
  get :: forall a. STRef s a -> ST s a
get = STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef
  {-# INLINE get #-}

-- | A concrete implementation of a read-only state variable, carrying an IO
-- action to read the value.
newtype GettableStateVar m a = GettableStateVar (m a)

instance HasGetter (GettableStateVar m) m where
   get :: forall a. GettableStateVar m a -> m a
get (GettableStateVar m a
g) = m a
g
   {-# INLINE get #-}

-- | Construct a 'GettableStateVar' from an IO action.
makeGettableStateVar :: m a -> GettableStateVar m a
makeGettableStateVar :: forall (m :: * -> *) a. m a -> GettableStateVar m a
makeGettableStateVar = m a -> GettableStateVar m a
forall (m :: * -> *) a. m a -> GettableStateVar m a
GettableStateVar
{-# INLINE makeGettableStateVar #-}

--------------------------------------------------------------------------------

-- | The class of all writable state variables.
class HasSetter s m where
   -- | Write a new value into a state variable.
   ($=) :: s a -> a -> m ()

instance HasSetter IORef IO where
  $= :: forall a. IORef a -> a -> IO ()
($=) = IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef
  {-# INLINE ($=) #-}
instance HasSetter TVar STM where
  $= :: forall a. TVar a -> a -> STM ()
($=) = TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar
  {-# INLINE ($=) #-}
instance HasSetter (STRef s) (ST s) where
  $= :: forall a. STRef s a -> a -> ST s ()
($=) = STRef s a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef
  {-# INLINE ($=) #-}

-- | A concrete implementation of a write-only state variable, carrying an IO
-- action to write the new value.
newtype SettableStateVar m a = SettableStateVar (a -> m ())

instance HasSetter (SettableStateVar m) m where
  $= :: forall a. SettableStateVar m a -> a -> m ()
($=) (SettableStateVar a -> m ()
s) a
a = a -> m ()
s a
a
  {-# INLINE ($=) #-}

-- | Construct a 'SettableStateVar' from an IO action.
makeSettableStateVar :: (a -> m ()) -> SettableStateVar m a
makeSettableStateVar :: forall a (m :: * -> *). (a -> m ()) -> SettableStateVar m a
makeSettableStateVar = (a -> m ()) -> SettableStateVar m a
forall (m :: * -> *) a. (a -> m ()) -> SettableStateVar m a
SettableStateVar
{-# INLINE makeSettableStateVar #-}

--------------------------------------------------------------------------------

-- | A concrete implementation of a readable and writable state variable,
-- carrying one IO action to read the value and another IO action to write the
-- new value.
data StateVar m a =
  StateVar (GettableStateVar m a) (SettableStateVar m a)

instance HasGetter (StateVar m) m where
  get :: forall a. StateVar m a -> m a
get (StateVar GettableStateVar m a
g SettableStateVar m a
_) = GettableStateVar m a -> m a
forall a. GettableStateVar m a -> m a
forall (g :: * -> *) (m :: * -> *) a. HasGetter g m => g a -> m a
get GettableStateVar m a
g
  {-# INLINE get #-}
instance HasSetter (StateVar m) m where
  $= :: forall a. StateVar m a -> a -> m ()
($=) (StateVar GettableStateVar m a
_ SettableStateVar m a
s) a
a = SettableStateVar m a
s SettableStateVar m a -> a -> m ()
forall a. SettableStateVar m a -> a -> m ()
forall (s :: * -> *) (m :: * -> *) a.
HasSetter s m =>
s a -> a -> m ()
$= a
a
  {-# INLINE ($=) #-}

-- | Construct a 'StateVar' from two IO actions, one for reading and one for
-- writing.
makeStateVar :: m a -> (a -> m ()) -> StateVar m a
makeStateVar :: forall (m :: * -> *) a. m a -> (a -> m ()) -> StateVar m a
makeStateVar m a
g a -> m ()
s = GettableStateVar m a -> SettableStateVar m a -> StateVar m a
forall (m :: * -> *) a.
GettableStateVar m a -> SettableStateVar m a -> StateVar m a
StateVar (m a -> GettableStateVar m a
forall (m :: * -> *) a. m a -> GettableStateVar m a
makeGettableStateVar m a
g) ((a -> m ()) -> SettableStateVar m a
forall a (m :: * -> *). (a -> m ()) -> SettableStateVar m a
makeSettableStateVar a -> m ()
s)
{-# INLINE makeStateVar #-}

makePtrVar :: (MonadIO m, Storable a) => Ptr a -> StateVar m a
makePtrVar :: forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Ptr a -> StateVar m a
makePtrVar Ptr a
p = m a -> (a -> m ()) -> StateVar m a
forall (m :: * -> *) a. m a -> (a -> m ()) -> StateVar m a
makeStateVar (IO a -> m a
forall a. 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
$ Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
p) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
p)
{-# INLINE makePtrVar #-}

--------------------------------------------------------------------------------

-- | A modificator convenience function, transforming the contents of a state
-- variable with a given funtion.

($~) :: (Monad m, HasGetter v m, HasSetter v m) => v a -> (a -> a) -> m ()
v a
v $~ :: forall (m :: * -> *) (v :: * -> *) a.
(Monad m, HasGetter v m, HasSetter v m) =>
v a -> (a -> a) -> m ()
$~ a -> a
f = v a -> m a
forall a. v a -> m a
forall (g :: * -> *) (m :: * -> *) a. HasGetter g m => g a -> m a
get v a
v m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v a -> a -> m ()
forall a. v a -> a -> m ()
forall (s :: * -> *) (m :: * -> *) a.
HasSetter s m =>
s a -> a -> m ()
($=) v a
v (a -> m ()) -> (a -> a) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f
{-# INLINE ($~) #-}

-- | A variant of '$=' which is strict in the value to be set.
($=!) :: (Monad m, HasSetter s m) => s a -> a -> m ()
s a
v $=! :: forall (m :: * -> *) (s :: * -> *) a.
(Monad m, HasSetter s m) =>
s a -> a -> m ()
$=! a
x = a
x a -> m () -> m ()
forall a b. a -> b -> b
`seq` s a
v s a -> a -> m ()
forall a. s a -> a -> m ()
forall (s :: * -> *) (m :: * -> *) a.
HasSetter s m =>
s a -> a -> m ()
$= a
x
{-# INLINE ($=!) #-}

-- | A variant of '$~' which is strict in the transformed value.
($~!) :: (Monad m, HasGetter v m, HasSetter v m) => v a -> (a -> a) -> m ()
v a
v $~! :: forall (m :: * -> *) (v :: * -> *) a.
(Monad m, HasGetter v m, HasSetter v m) =>
v a -> (a -> a) -> m ()
$~! a -> a
f = v a -> m a
forall a. v a -> m a
forall (g :: * -> *) (m :: * -> *) a. HasGetter g m => g a -> m a
get v a
v m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v a -> a -> m ()
forall (m :: * -> *) (s :: * -> *) a.
(Monad m, HasSetter s m) =>
s a -> a -> m ()
($=!) v a
v (a -> m ()) -> (a -> a) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f
{-# INLINE ($~!) #-}

--------------------------------------------------------------------------------

(&) :: s -> (s -> t) -> t
s
s & :: forall s t. s -> (s -> t) -> t
& s -> t
t = s -> t
t s
s
{-# INLINE (&) #-}

infixl 8 ^=, ^~, ^=!, ^~!, ^.

(^=) :: HasSetter g m => (s -> g a) -> a -> s -> m ()
(s -> g a
fv ^= :: forall (g :: * -> *) (m :: * -> *) s a.
HasSetter g m =>
(s -> g a) -> a -> s -> m ()
^= a
v) s
s = s -> g a
fv s
s g a -> a -> m ()
forall a. g a -> a -> m ()
forall (s :: * -> *) (m :: * -> *) a.
HasSetter s m =>
s a -> a -> m ()
$= a
v
{-# INLINE (^=) #-}

(^~) :: (Monad m, HasGetter g m, HasSetter g m) => (s -> g a) -> (a -> a) -> s -> m ()
(s -> g a
fv ^~ :: forall (m :: * -> *) (g :: * -> *) s a.
(Monad m, HasGetter g m, HasSetter g m) =>
(s -> g a) -> (a -> a) -> s -> m ()
^~ a -> a
f) s
s = g a
v g a -> (a -> a) -> m ()
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, HasGetter v m, HasSetter v m) =>
v a -> (a -> a) -> m ()
$~ a -> a
f where v :: g a
v = s -> g a
fv s
s
{-# INLINE (^~) #-}

(^=!) :: (Monad m, HasSetter g m) => (s -> g a) -> a -> s -> m ()
(s -> g a
fv ^=! :: forall (m :: * -> *) (g :: * -> *) s a.
(Monad m, HasSetter g m) =>
(s -> g a) -> a -> s -> m ()
^=! a
x) s
s = g a
v g a -> a -> m ()
forall (m :: * -> *) (s :: * -> *) a.
(Monad m, HasSetter s m) =>
s a -> a -> m ()
$=! a
x where v :: g a
v = s -> g a
fv s
s
{-# INLINE (^=!) #-}

(^~!) :: (Monad m, HasGetter g m, HasSetter g m) => (s -> g a) -> (a ->a) -> s -> m ()
(s -> g a
fv ^~! :: forall (m :: * -> *) (g :: * -> *) s a.
(Monad m, HasGetter g m, HasSetter g m) =>
(s -> g a) -> (a -> a) -> s -> m ()
^~! a -> a
f) s
s = g a
v g a -> (a -> a) -> m ()
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, HasGetter v m, HasSetter v m) =>
v a -> (a -> a) -> m ()
$~! a -> a
f where v :: g a
v = s -> g a
fv s
s
{-# INLINE (^~!) #-}

(^.) :: (Monad m, HasGetter g m, HasGetter h m) => (s -> g a) -> (a -> h b) -> s -> GettableStateVar m b
(s -> g a
fg ^. :: forall (m :: * -> *) (g :: * -> *) (h :: * -> *) s a b.
(Monad m, HasGetter g m, HasGetter h m) =>
(s -> g a) -> (a -> h b) -> s -> GettableStateVar m b
^. a -> h b
fh) s
s = m b -> GettableStateVar m b
forall (m :: * -> *) a. m a -> GettableStateVar m a
makeGettableStateVar (m b -> GettableStateVar m b) -> m b -> GettableStateVar m b
forall a b. (a -> b) -> a -> b
$ g a -> m a
forall a. g a -> m a
forall (g :: * -> *) (m :: * -> *) a. HasGetter g m => g a -> m a
get (s -> g a
fg s
s) m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= h b -> m b
forall a. h a -> m a
forall (g :: * -> *) (m :: * -> *) a. HasGetter g m => g a -> m a
get (h b -> m b) -> (a -> h b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> h b
fh
{-# INLINE (^.) #-}

--------------------------------------------------------------------------------

(@=) :: (Monad m, MonadTrans n, MonadReader s (n m), HasSetter g m) => (s -> g a) -> a -> n m ()
s -> g a
fv @= :: forall (m :: * -> *) (n :: (* -> *) -> * -> *) s (g :: * -> *) a.
(Monad m, MonadTrans n, MonadReader s (n m), HasSetter g m) =>
(s -> g a) -> a -> n m ()
@= a
v = n m s
forall r (m :: * -> *). MonadReader r m => m r
ask n m s -> (s -> n m ()) -> n m ()
forall a b. n m a -> (a -> n m b) -> n m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> n m ()
forall (m :: * -> *) a. Monad m => m a -> n m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> n m ()) -> (s -> m ()) -> s -> n m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> g a
fv (s -> g a) -> a -> s -> m ()
forall (g :: * -> *) (m :: * -> *) s a.
HasSetter g m =>
(s -> g a) -> a -> s -> m ()
^= a
v)
{-# INLINE (@=) #-}