T.hs

{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wall -O2 -threaded -rtsopts "-with-rtsopts=-A64m -n2m -I0 -qg" #-}

module T where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.IORef

import System.Exit
import System.Process

pooledFoldMap :: Monoid m => Int -> (a -> IO m) -> [a] -> IO m
pooledFoldMap nprocs f jobs = do
  queue <- newIORef jobs
  rets <- forM [1 .. nprocs] $ \_ -> do
    cache <- newIORef mempty
    ret <- newEmptyMVar
    let w = join $ atomicModifyIORef' queue $ \case
          (x : xs) ->
            ( xs,
              do
                r <- f x
                modifyIORef' cache (r <>)
                w
            )
          [] -> ([], pure ())
    void $
      forkFinally
        w
        ( \case
            Left (SomeException err) -> putMVar ret (throw err)
            _ -> readIORef cache >>= putMVar ret
        )
    pure ret
  mconcat <$> forM rets takeMVar

testPkg :: String -> IO [String]
testPkg pkg = do
  (c,_,_) <- readProcessWithExitCode "ahc-cabal" ["v1-install", "--dry-run", "--package-db=clear", "--package-db=global", pkg] ""
  pure $ case c of
    ExitSuccess -> [pkg]
    _ -> []