Skip to content

Instantly share code, notes, and snippets.

@TerrorJack

TerrorJack/T.hs

Created Jan 30, 2020
Embed
What would you like to do?
{-# 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]
_ -> []
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.