content: {-# LANGUAGE LambdaCase #-}
  
  module General.Fence(
      Fence, newFence, signalFence, waitFence, testFence,
      exceptFence
      ) where
  
  import Control.Monad
  import Control.Monad.IO.Class
  import Control.Exception.Extra
  import Development.Shake.Internal.Errors
  import Data.Maybe
  import Data.Either.Extra
  import Data.IORef
  
  
  ---------------------------------------------------------------------
  -- FENCE
  
  -- | Like a barrier, but based on callbacks
  newtype Fence m a = Fence (IORef (Either (a -> m ()) a))
  instance Show (Fence m a) where show _ = "Fence"
  
  newFence :: MonadIO m => IO (Fence m a)
  newFence = Fence <$> newIORef (Left $ const $ pure ())
  
  signalFence :: (Partial, MonadIO m) => Fence m a -> a -> m ()
  signalFence (Fence ref) v = join $ liftIO $ atomicModifyIORef' ref $ \case
      Left queue -> (Right v, queue v)
      Right _ -> throwImpure $ errorInternal "signalFence called twice on one Fence"
  
  waitFence :: MonadIO m => Fence m a -> (a -> m ()) -> m ()
  waitFence (Fence ref) call = join $ liftIO $ atomicModifyIORef' ref $ \case
      Left queue -> (Left (\a -> queue a >> call a), pure ())
      Right v -> (Right v, call v)
  
  testFence :: Fence m a -> IO (Maybe a)
  testFence (Fence x) = eitherToMaybe <$> readIORef x
  
  
  ---------------------------------------------------------------------
  -- FENCE COMPOSITES
  
  exceptFence :: MonadIO m => [Fence m (Either e r)] -> m (Fence m (Either e [r]))
  exceptFence xs = do
      -- number of items still to complete, becomes negative after it has triggered
      todo <- liftIO $ newIORef $ length xs
      fence <- liftIO newFence
  
      forM_ xs $ \x -> waitFence x $ \res ->
          join $ liftIO $ atomicModifyIORef' todo $ \i -> case res of
              Left e | i >= 0 -> (-1, signalFence fence $ Left e)
              _ | i == 1 -> (-1, signalFence fence . Right =<< liftIO (mapM (fmap (fromRight' . fromJust) . testFence) xs))
                | otherwise -> (i-1, pure ())
      pure fence
  