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