{-# LANGUAGE GADTs #-}

module Control.Concurrent.STM.MultiTVar (
    MultiTVar(..)
  , loosenTVar
  , makeMultiTVar
  , zoomMultiTVar
  , newMultiTVar, newMultiTVarIO
  , readMultiTVar, readMultiTVarIO
  , readMultiTVarList, readMultiTVarListIO
  , readMultiTVarHead, readMultiTVarHeadIO
  , modifyMultiTVar, modifyMultiTVar'
  , writeMultiTVar
) where

import Control.Concurrent.STM.TVar.Zoom

import Control.Lens 

data MultiTVar a where
   MultiTVar :: TVar x -> ATraversal' x a -> MultiTVar a

loosenTVar :: TVar a -> MultiTVar a
loosenTVar v = MultiTVar v id

makeMultiTVar :: ATraversal' x a -> TVar x -> MultiTVar a
makeMultiTVar = flip MultiTVar

zoomMultiTVar :: ATraversal' a b -> MultiTVar a -> MultiTVar b
zoomMultiTVar t1 (MultiTVar v t2) = MultiTVar v . confusing $ cloneTraversal t2 . cloneTraversal t1

newMultiTVar :: a -> STM (MultiTVar a)
newMultiTVar a = MultiTVar <$> newTVar a <*> pure id

newMultiTVarIO :: a -> IO (MultiTVar a)
newMultiTVarIO a = MultiTVar <$> newTVarIO a <*> pure id

readMultiTVar :: Monoid a => MultiTVar a -> STM a
readMultiTVar (MultiTVar v t) = (^. cloneTraversal t) <$> readTVar v 

readMultiTVarIO :: Monoid a => MultiTVar a -> IO a
readMultiTVarIO (MultiTVar v t) = (^. cloneTraversal t) <$> readTVarIO v 

readMultiTVarList :: MultiTVar a -> STM [a]
readMultiTVarList (MultiTVar v t) = (^.. cloneTraversal t) <$> readTVar v

readMultiTVarListIO :: MultiTVar a -> IO [a]
readMultiTVarListIO (MultiTVar v t) = (^.. cloneTraversal t) <$> readTVarIO v

readMultiTVarHead :: MultiTVar a -> STM (Maybe a)
readMultiTVarHead (MultiTVar v t) = (^? cloneTraversal t) <$> readTVar v

readMultiTVarHeadIO :: MultiTVar a -> IO (Maybe a)
readMultiTVarHeadIO (MultiTVar v t) = (^? cloneTraversal t) <$> readTVarIO v

modifyMultiTVar :: MultiTVar a -> (a -> a) -> STM ()
modifyMultiTVar (MultiTVar v t) f = modifyTVar v $ cloneTraversal t %~ f

modifyMultiTVar' :: MultiTVar a -> (a -> a) -> STM ()
modifyMultiTVar' (MultiTVar v t) f = modifyTVar' v $ cloneTraversal t %~ f

writeMultiTVar :: MultiTVar a -> a -> STM ()
writeMultiTVar (MultiTVar v t) a = modifyTVar' v $ cloneTraversal t .~ a