-- | Multi-element channels, for the Haskell interpretation of
--   'Language.Embedded.Concurrent'.
module Control.Chan where
import Control.Concurrent.STM

data ChanState = Open | Closed
  deriving ChanState -> ChanState -> Bool
(ChanState -> ChanState -> Bool)
-> (ChanState -> ChanState -> Bool) -> Eq ChanState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChanState -> ChanState -> Bool
$c/= :: ChanState -> ChanState -> Bool
== :: ChanState -> ChanState -> Bool
$c== :: ChanState -> ChanState -> Bool
Eq

newtype Chan a = Chan {Chan a -> TVar (ChanGuts a)
unChan :: TVar (ChanGuts a)}

data ChanGuts a = ChanGuts
  { ChanGuts a -> [a]
chanBuf        :: [a]
  , ChanGuts a -> Int
chanBufLen     :: Int
  , ChanGuts a -> Int
chanBound      :: Int
  , ChanGuts a -> ChanState
chanState      :: ChanState
  , ChanGuts a -> Bool
chanLastReadOK :: Bool
  }

newChan :: Int -> IO (Chan a)
newChan :: Int -> IO (Chan a)
newChan Int
len = (TVar (ChanGuts a) -> Chan a)
-> IO (TVar (ChanGuts a)) -> IO (Chan a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TVar (ChanGuts a) -> Chan a
forall a. TVar (ChanGuts a) -> Chan a
Chan (IO (TVar (ChanGuts a)) -> IO (Chan a))
-> (ChanGuts a -> IO (TVar (ChanGuts a)))
-> ChanGuts a
-> IO (Chan a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TVar (ChanGuts a)) -> IO (TVar (ChanGuts a))
forall a. STM a -> IO a
atomically (STM (TVar (ChanGuts a)) -> IO (TVar (ChanGuts a)))
-> (ChanGuts a -> STM (TVar (ChanGuts a)))
-> ChanGuts a
-> IO (TVar (ChanGuts a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChanGuts a -> STM (TVar (ChanGuts a))
forall a. a -> STM (TVar a)
newTVar (ChanGuts a -> IO (Chan a)) -> ChanGuts a -> IO (Chan a)
forall a b. (a -> b) -> a -> b
$ ChanGuts :: forall a. [a] -> Int -> Int -> ChanState -> Bool -> ChanGuts a
ChanGuts
  { chanBuf :: [a]
chanBuf = []
  , chanBufLen :: Int
chanBufLen = Int
0
  , chanBound :: Int
chanBound = Int
len
  , chanState :: ChanState
chanState = ChanState
Open
  , chanLastReadOK :: Bool
chanLastReadOK = Bool
True
  }

readChan :: Chan a -> Int -> IO [a]
readChan :: Chan a -> Int -> IO [a]
readChan (Chan TVar (ChanGuts a)
chan) Int
len = STM [a] -> IO [a]
forall a. STM a -> IO a
atomically (STM [a] -> IO [a]) -> STM [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ do
  ChanGuts a
ch <- TVar (ChanGuts a) -> STM (ChanGuts a)
forall a. TVar a -> STM a
readTVar TVar (ChanGuts a)
chan
  case ChanGuts a -> ChanState
forall a. ChanGuts a -> ChanState
chanState ChanGuts a
ch of
    ChanState
Open -> do
      Bool -> STM ()
check (ChanGuts a -> Int
forall a. ChanGuts a -> Int
chanBufLen ChanGuts a
ch Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len)
      ChanGuts a -> Bool -> STM [a]
readAndUpdate ChanGuts a
ch Bool
True
    ChanState
Closed
      | ChanGuts a -> Int
forall a. ChanGuts a -> Int
chanBufLen ChanGuts a
ch Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len -> do
        [a] -> STM [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      | Bool
otherwise -> do
        ChanGuts a -> Bool -> STM [a]
readAndUpdate ChanGuts a
ch Bool
False
  where
    readAndUpdate :: ChanGuts a -> Bool -> STM [a]
readAndUpdate ChanGuts a
ch Bool
success = do
      let ([a]
out, [a]
rest) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len (ChanGuts a -> [a]
forall a. ChanGuts a -> [a]
chanBuf ChanGuts a
ch)
      TVar (ChanGuts a) -> ChanGuts a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ChanGuts a)
chan (ChanGuts a -> STM ()) -> ChanGuts a -> STM ()
forall a b. (a -> b) -> a -> b
$ ChanGuts a
ch
        { chanBuf :: [a]
chanBuf = [a]
rest
        , chanBufLen :: Int
chanBufLen = ChanGuts a -> Int
forall a. ChanGuts a -> Int
chanBufLen ChanGuts a
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len
        , chanLastReadOK :: Bool
chanLastReadOK = Bool
success
        }
      [a] -> STM [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
out

writeChan :: Chan a -> [a] -> IO Bool
writeChan :: Chan a -> [a] -> IO Bool
writeChan (Chan TVar (ChanGuts a)
chan) [a]
xs = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  ChanGuts a
ch <- TVar (ChanGuts a) -> STM (ChanGuts a)
forall a. TVar a -> STM a
readTVar TVar (ChanGuts a)
chan
  case ChanGuts a -> ChanState
forall a. ChanGuts a -> ChanState
chanState ChanGuts a
ch of
    ChanState
Open -> do
      Bool -> STM ()
check (ChanGuts a -> Int
forall a. ChanGuts a -> Int
chanBound ChanGuts a
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- ChanGuts a -> Int
forall a. ChanGuts a -> Int
chanBufLen ChanGuts a
ch Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len)
      TVar (ChanGuts a) -> ChanGuts a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ChanGuts a)
chan (ChanGuts a -> STM ()) -> ChanGuts a -> STM ()
forall a b. (a -> b) -> a -> b
$ ChanGuts a
ch
        { chanBuf :: [a]
chanBuf = ChanGuts a -> [a]
forall a. ChanGuts a -> [a]
chanBuf ChanGuts a
ch [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs
        , chanBufLen :: Int
chanBufLen = ChanGuts a -> Int
forall a. ChanGuts a -> Int
chanBufLen ChanGuts a
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
        }
      Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ChanState
Closed -> do
      Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

closeChan :: Chan a -> IO ()
closeChan :: Chan a -> IO ()
closeChan (Chan TVar (ChanGuts a)
chan) = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  TVar (ChanGuts a) -> (ChanGuts a -> ChanGuts a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (ChanGuts a)
chan (\ChanGuts a
c -> ChanGuts a
c {chanState :: ChanState
chanState = ChanState
Closed})

lastReadOK :: Chan a -> IO Bool
lastReadOK :: Chan a -> IO Bool
lastReadOK = (ChanGuts a -> Bool) -> IO (ChanGuts a) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChanGuts a -> Bool
forall a. ChanGuts a -> Bool
chanLastReadOK (IO (ChanGuts a) -> IO Bool)
-> (Chan a -> IO (ChanGuts a)) -> Chan a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (ChanGuts a) -> IO (ChanGuts a)
forall a. STM a -> IO a
atomically (STM (ChanGuts a) -> IO (ChanGuts a))
-> (Chan a -> STM (ChanGuts a)) -> Chan a -> IO (ChanGuts a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (ChanGuts a) -> STM (ChanGuts a)
forall a. TVar a -> STM a
readTVar (TVar (ChanGuts a) -> STM (ChanGuts a))
-> (Chan a -> TVar (ChanGuts a)) -> Chan a -> STM (ChanGuts a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan a -> TVar (ChanGuts a)
forall a. Chan a -> TVar (ChanGuts a)
unChan