1{-# LANGUAGE LambdaCase #-}
2
3module General.Fence(
4    Fence, newFence, signalFence, waitFence, testFence,
5    exceptFence
6    ) where
7
8import Control.Monad
9import Control.Monad.IO.Class
10import Control.Exception.Extra
11import Development.Shake.Internal.Errors
12import Data.Maybe
13import Data.Either.Extra
14import Data.IORef
15
16
17---------------------------------------------------------------------
18-- FENCE
19
20-- | Like a barrier, but based on callbacks
21newtype Fence m a = Fence (IORef (Either (a -> m ()) a))
22instance Show (Fence m a) where show _ = "Fence"
23
24newFence :: MonadIO m => IO (Fence m a)
25newFence = Fence <$> newIORef (Left $ const $ pure ())
26
27signalFence :: (Partial, MonadIO m) => Fence m a -> a -> m ()
28signalFence (Fence ref) v = join $ liftIO $ atomicModifyIORef' ref $ \case
29    Left queue -> (Right v, queue v)
30    Right _ -> throwImpure $ errorInternal "signalFence called twice on one Fence"
31
32waitFence :: MonadIO m => Fence m a -> (a -> m ()) -> m ()
33waitFence (Fence ref) call = join $ liftIO $ atomicModifyIORef' ref $ \case
34    Left queue -> (Left (\a -> queue a >> call a), pure ())
35    Right v -> (Right v, call v)
36
37testFence :: Fence m a -> IO (Maybe a)
38testFence (Fence x) = eitherToMaybe <$> readIORef x
39
40
41---------------------------------------------------------------------
42-- FENCE COMPOSITES
43
44exceptFence :: MonadIO m => [Fence m (Either e r)] -> m (Fence m (Either e [r]))
45exceptFence xs = do
46    -- number of items still to complete, becomes negative after it has triggered
47    todo <- liftIO $ newIORef $ length xs
48    fence <- liftIO newFence
49
50    forM_ xs $ \x -> waitFence x $ \res ->
51        join $ liftIO $ atomicModifyIORef' todo $ \i -> case res of
52            Left e | i >= 0 -> (-1, signalFence fence $ Left e)
53            _ | i == 1 -> (-1, signalFence fence . Right =<< liftIO (mapM (fmap (fromRight' . fromJust) . testFence) xs))
54              | otherwise -> (i-1, pure ())
55    pure fence
56