{-# LANGUAGE UndecidableSuperClasses, MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE Trustworthy, TypeFamilies, FlexibleContexts, PatternSynonyms #-}
module Data.Field
(
Field (..), sfield,
GetterFor, SetterFor, ModifierFor, ModifierMFor,
IsMVar (..), MonadVar (..)
)
where
import Prelude hiding ( (.), id )
import Data.Property
import Data.Typeable
import Data.Functor
import Data.IORef
import Data.STRef
import Data.Kind
import GHC.Conc
import Control.Concurrent.MVar
import Control.Category
import Control.Monad.ST
import Control.Monad
default ()
data Field m record a = Field
{
Field m record a -> GetterFor m record a
getField :: !(GetterFor m record a),
Field m record a -> SetterFor m record a
setField :: !(SetterFor m record a),
Field m record a -> ModifierFor m record a
modifyField :: !(ModifierFor m record a),
Field m record a -> ModifierMFor m record a
modifyFieldM :: !(ModifierMFor m record a)
} deriving ( Typeable )
type GetterFor m record a = record -> m a
type SetterFor m record a = record -> a -> m ()
type ModifierFor m record a = record -> (a -> a) -> m a
type ModifierMFor m record a = record -> (a -> m a) -> m a
sfield :: (Monad m) => GetterFor m record a -> SetterFor m record a -> Field m record a
sfield :: GetterFor m record a -> SetterFor m record a -> Field m record a
sfield GetterFor m record a
g SetterFor m record a
s = GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field GetterFor m record a
g SetterFor m record a
s (\ record
record a -> a
f -> do a
res <- a -> a
f (a -> a) -> m a -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetterFor m record a
g record
record; SetterFor m record a
s record
record a
res; a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res)
(\ record
record a -> m a
go -> do a
res <- a -> m a
go (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GetterFor m record a
g record
record; SetterFor m record a
s record
record a
res; a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res)
instance (Monad m) => Category (Field m)
where
Field GetterFor m b c
g1 SetterFor m b c
s1 ModifierFor m b c
m1 ModifierMFor m b c
mm1 . :: Field m b c -> Field m a b -> Field m a c
. Field GetterFor m a b
g2 SetterFor m a b
_ ModifierFor m a b
_ ModifierMFor m a b
_ = GetterFor m a c
-> SetterFor m a c
-> ModifierFor m a c
-> ModifierMFor m a c
-> Field m a c
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field (GetterFor m b c
g1 GetterFor m b c -> GetterFor m a b -> GetterFor m a c
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< GetterFor m a b
g2) SetterFor m a c
s3 ModifierFor m a c
m3 ModifierMFor m a c
mm3
where
mm3 :: ModifierMFor m a c
mm3 a
record c -> m c
go = ModifierMFor m b c -> (c -> m c) -> GetterFor m b c
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModifierMFor m b c
mm1 c -> m c
go GetterFor m b c -> m b -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GetterFor m a b
g2 a
record
m3 :: ModifierFor m a c
m3 a
record c -> c
f = ModifierFor m b c -> (c -> c) -> GetterFor m b c
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModifierFor m b c
m1 c -> c
f GetterFor m b c -> m b -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GetterFor m a b
g2 a
record
s3 :: SetterFor m a c
s3 a
record c
value = SetterFor m b c -> c -> b -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SetterFor m b c
s1 c
value (b -> m ()) -> m b -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GetterFor m a b
g2 a
record
id :: Field m a a
id = GetterFor m a a
-> SetterFor m a a
-> ModifierFor m a a
-> ModifierMFor m a a
-> Field m a a
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field GetterFor m a a
forall (m :: * -> *) a. Monad m => a -> m a
return (\ a
_ a
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\ a
x a -> a
f -> GetterFor m a a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
f a
x)) ((GetterFor m a a -> GetterFor m a a) -> ModifierMFor m a a
forall a b c. (a -> b -> c) -> b -> a -> c
flip GetterFor m a a -> GetterFor m a a
forall a b. (a -> b) -> a -> b
($))
instance FieldGet Field where getRecord :: Field m record a -> record -> m a
getRecord = Field m record a -> record -> m a
forall (m :: * -> *) record a.
Field m record a -> GetterFor m record a
getField
instance FieldSet Field where setRecord :: Field m record a -> record -> a -> m ()
setRecord = Field m record a -> record -> a -> m ()
forall (m :: * -> *) record a.
Field m record a -> SetterFor m record a
setField
instance FieldModify Field where modifyRecord :: Field m record a -> record -> (a -> a) -> m a
modifyRecord = Field m record a -> record -> (a -> a) -> m a
forall (m :: * -> *) record a.
Field m record a -> ModifierFor m record a
modifyField
instance FieldSwitch Field
where
switchRecord :: Field m record a -> record -> Int -> m ()
switchRecord Field m record a
field record
record = m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m a -> m ()) -> (Int -> m a) -> Int -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Field m record a -> record -> (a -> a) -> m a
forall (field :: (* -> *) -> * -> * -> *) (m :: * -> *) record a.
(FieldModify field, Monad m) =>
field m record a -> record -> (a -> a) -> m a
modifyRecord Field m record a
field record
record ((a -> a) -> m a) -> (Int -> a -> a) -> Int -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> a -> a
forall switch. IsSwitch switch => Int -> switch -> switch
toggle
class (Monad m, MonadVar m) => IsMVar m var
where
this :: Field m (var a) a
var :: a -> m (var a)
instance IsMVar (ST s) (STRef s)
where
var :: a -> ST s (STRef s a)
var = a -> ST s (STRef s a)
forall a s. a -> ST s (STRef s a)
newSTRef
this :: Field (ST s) (STRef s a) a
this = GetterFor (ST s) (STRef s a) a
-> SetterFor (ST s) (STRef s a) a
-> ModifierFor (ST s) (STRef s a) a
-> ModifierMFor (ST s) (STRef s a) a
-> Field (ST s) (STRef s a) a
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field GetterFor (ST s) (STRef s a) a
forall s a. STRef s a -> ST s a
readSTRef SetterFor (ST s) (STRef s a) a
forall s a. STRef s a -> a -> ST s ()
writeSTRef ModifierFor (ST s) (STRef s a) a
forall s b. STRef s b -> (b -> b) -> ST s b
modify' ModifierMFor (ST s) (STRef s a) a
forall s b. STRef s b -> (b -> ST s b) -> ST s b
modifyM'
where
modifyM' :: STRef s b -> (b -> ST s b) -> ST s b
modifyM' STRef s b
ref b -> ST s b
f = do b
res <- b -> ST s b
f (b -> ST s b) -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STRef s b -> ST s b
forall s a. STRef s a -> ST s a
readSTRef STRef s b
ref; b
res b -> ST s () -> ST s b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STRef s b -> b -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s b
ref b
res
modify' :: STRef s b -> (b -> b) -> ST s b
modify' STRef s b
ref b -> b
f = do b
res <- b -> b
f (b -> b) -> ST s b -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STRef s b -> ST s b
forall s a. STRef s a -> ST s a
readSTRef STRef s b
ref; b
res b -> ST s () -> ST s b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STRef s b -> b -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s b
ref b
res
instance IsMVar IO IORef
where
var :: a -> IO (IORef a)
var = a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef
this :: Field IO (IORef a) a
this = GetterFor IO (IORef a) a
-> SetterFor IO (IORef a) a
-> ModifierFor IO (IORef a) a
-> ModifierMFor IO (IORef a) a
-> Field IO (IORef a) a
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field GetterFor IO (IORef a) a
forall a. IORef a -> IO a
readIORef SetterFor IO (IORef a) a
forall a. IORef a -> a -> IO ()
writeIORef ModifierFor IO (IORef a) a
forall b. IORef b -> (b -> b) -> IO b
modify' ModifierMFor IO (IORef a) a
forall b. IORef b -> (b -> IO b) -> IO b
modifyM'
where
modifyM' :: IORef b -> (b -> IO b) -> IO b
modifyM' IORef b
ref b -> IO b
f = do b
val <- b -> IO b
f (b -> IO b) -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef b -> IO b
forall a. IORef a -> IO a
readIORef IORef b
ref; IORef b -> b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef b
ref b
val; b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
val
modify' :: IORef b -> (b -> b) -> IO b
modify' IORef b
ref b -> b
f = IORef b -> (b -> (b, b)) -> IO b
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef b
ref (\ b
a -> let b :: b
b = b -> b
f b
a in (b
b, b
b))
instance IsMVar IO MVar
where
var :: a -> IO (MVar a)
var = a -> IO (MVar a)
forall a. a -> IO (MVar a)
newMVar
this :: Field IO (MVar a) a
this = GetterFor IO (MVar a) a
-> SetterFor IO (MVar a) a
-> ModifierFor IO (MVar a) a
-> ModifierMFor IO (MVar a) a
-> Field IO (MVar a) a
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field GetterFor IO (MVar a) a
forall a. MVar a -> IO a
readMVar SetterFor IO (MVar a) a
forall a. MVar a -> a -> IO ()
putMVar ModifierFor IO (MVar a) a
forall b. MVar b -> (b -> b) -> IO b
modify' ModifierMFor IO (MVar a) a
forall b. MVar b -> (b -> IO b) -> IO b
modifyM'
where
modifyM' :: MVar b -> (b -> IO b) -> IO b
modifyM' MVar b
mvar b -> IO b
f = MVar b
mvar MVar b -> (b -> IO (b, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
`modifyMVarMasked` \ b
a -> do b
b <- b -> IO b
f b
a; (b, b) -> IO (b, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, b
b)
modify' :: MVar b -> (b -> b) -> IO b
modify' MVar b
mvar b -> b
f = MVar b
mvar MVar b -> (b -> IO (b, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
`modifyMVar` \ b
a -> let b :: b
b = b -> b
f b
a in (b, b) -> IO (b, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, b
b)
instance IsMVar STM TVar
where
var :: a -> STM (TVar a)
var = a -> STM (TVar a)
forall a. a -> STM (TVar a)
newTVar
this :: Field STM (TVar a) a
this = GetterFor STM (TVar a) a
-> SetterFor STM (TVar a) a
-> ModifierFor STM (TVar a) a
-> ModifierMFor STM (TVar a) a
-> Field STM (TVar a) a
forall (m :: * -> *) record a.
GetterFor m record a
-> SetterFor m record a
-> ModifierFor m record a
-> ModifierMFor m record a
-> Field m record a
Field GetterFor STM (TVar a) a
forall a. TVar a -> STM a
readTVar SetterFor STM (TVar a) a
forall a. TVar a -> a -> STM ()
writeTVar ModifierFor STM (TVar a) a
forall b. TVar b -> (b -> b) -> STM b
modifyTVar ModifierMFor STM (TVar a) a
forall b. TVar b -> (b -> STM b) -> STM b
modifyMTVar
where
modifyMTVar :: TVar b -> (b -> STM b) -> STM b
modifyMTVar TVar b
tvar b -> STM b
f = do b
res <- b -> STM b
f (b -> STM b) -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar b -> STM b
forall a. TVar a -> STM a
readTVar TVar b
tvar; b
res b -> STM () -> STM b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar b -> b -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar b
tvar b
res
modifyTVar :: TVar b -> (b -> b) -> STM b
modifyTVar TVar b
tvar b -> b
f = do b
res <- b -> b
f (b -> b) -> STM b -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar b -> STM b
forall a. TVar a -> STM a
readTVar TVar b
tvar; b
res b -> STM () -> STM b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar b -> b -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar b
tvar b
res
class (Monad m, IsMVar m (Var m)) => MonadVar m
where
type Var m :: Type -> Type
instance MonadVar (ST s) where type Var (ST s) = STRef s
instance MonadVar IO where type Var IO = IORef
instance MonadVar STM where type Var STM = TVar