cmf (empty) → 0.1

raw patch · 5 files changed

+234/−0 lines, 5 filesdep +basedep +cmfdep +containers

Dependencies added: base, cmf, containers, hedgehog

Files

• CHANGELOG.md +5/−0
• LICENSE +7/−0
• cmf.cabal +61/−0
• src/Cmf.hs +121/−0
• test/Main.hs +40/−0

@@ -0,0 +1,5 @@+# Revision history for cmf++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,7 @@+Copyright 2019 chessai++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,61 @@+cabal-version: 2.2+name:+  cmf+version:+  0.1+synopsis:+  (C)oncurrent (M)onoidal (F)olds+description:+  This package provides concurrent monoidal folds over various structures.+  Because the folds are concurrent, the monoids are assumed to be commutative.+bug-reports:+  https://github.com/chessai/cmf#issues+license:+  MIT+license-file:+  LICENSE+author:+  chessai+maintainer:+  chessai <chessai1996@gmail.com>+copyright:+  2019 (c) chessai+category:+  Data+build-type:+  Simple+extra-source-files:+  CHANGELOG.md++library+  exposed-modules:+    Cmf+  build-depends:+    , base >= 4.10 && < 4.14+    , containers >= 0.5.4 && < 0.7+  hs-source-dirs:+    src+  default-language:+    Haskell2010++test-suite test+  type:+    exitcode-stdio-1.0+  main-is:+    Main.hs+  build-depends:+    , base+    , containers+    , cmf+    , hedgehog+  hs-source-dirs:+    test+  default-language:+    Haskell2010++source-repository head+  type:+    git+  location:+    git://github.com/chessai/cmf.git+

@@ -0,0 +1,121 @@+{-# language+    BangPatterns+  , DeriveAnyClass+  , DeriveGeneric+  , DerivingStrategies+  , LambdaCase+  , MagicHash+  , ScopedTypeVariables+  , UnboxedTuples+  #-}++-- | This module provides many concurrent monoidal folds+--   for commutative monoids.+--+--   Some notes (applies to all folds):+--+--     1. This module is intended to be imported qualified+--        to avoid name clashing.+--+--     2. Accumulation is strict.+--+--     3. Exceptions that occur will accumulate into a 'CmfException'+--        and be re-thrown.+module Cmf+  ( -- * Folds+    foldMap+  , foldMapWithKey++    -- * Exception Type+  , CmfException(..)+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad (void)+import Data.Foldable (foldlM)+import Data.Monoid (Sum(..))+import GHC.Conc (ThreadId(..))+import GHC.Exts (fork#)+import GHC.Generics (Generic)+import GHC.IO (IO(..))++import qualified Data.Map as Map++import Prelude hiding (foldMap)++-- | An exception to be re-thrown by a fold in this+--   module. It is just an accumulation of all the+--   exceptions that occurred among the running+--   threads.+newtype CmfException = CmfException [SomeException]+  deriving stock (Show, Generic)+  deriving anyclass (Exception)++-- | A concurrent monoidal fold over some 'Foldable'.+--+-- This operation may fail with:+--+--   * 'CmfException' if any of the threads throws an exception.+foldMap :: forall t m a. (Foldable t, Monoid m)+  => (a -> IO m)+  -> t a+  -> IO m+foldMap f xs = do+  var <- newEmptyMVar+  total <- foldlM+    (\ !n a -> do+      void $ fork $ try (f a) >>= putMVar var+      pure (n + 1)+    ) 0 xs+  internal total var+{-# inlineable foldMap #-}++-- | A concurrent monoidal fold (with keys) over a 'Map.Map'.+--+-- This operation may fail with:+--+--   * 'CmfException' if any of the threads throws an exception.++foldMapWithKey :: (Monoid m)+  => (k -> a -> IO m)+  -> Map.Map k a+  -> IO m+foldMapWithKey f mp = do+  var <- newEmptyMVar+  Sum total <- Map.foldMapWithKey+    (\k a -> do+      void $ fork $ try (f k a) >>= putMVar var+      pure (Sum 1)+    ) mp+  internal total var+{-# inlineable foldMapWithKey #-}++-- fork, but don't catch exceptions+-- avoids nested catch#+fork :: IO () -> IO ()+fork action = IO $ \s -> case fork# action s of+  (# s1, _ #) -> (# s1, () #)++-- worker+internal :: forall m. (Monoid m)+  => Int -- total number of threads to spawn+  -> MVar (Either SomeException m)+  -> IO m+internal total var = do+  let go2 :: Int -> [SomeException] -> IO (Either [SomeException] m)+      go2 !n !es = if n < total+        then takeMVar var >>= \case+          Left e  -> go2 (n + 1) (e:es)+          Right _ -> go2 (n + 1) es+        else pure (Left es)+  let go :: Int -> m -> IO (Either [SomeException] m)+      go !n !m = if n < total+        then takeMVar var >>= \case+          Left r -> go2 (n + 1) [r]+          Right m' -> go (n + 1) (m <> m')+        else pure (Right m)+  r <- go 0 mempty+  case r of+    Left errs -> throwIO $ CmfException errs+    Right m -> pure m

@@ -0,0 +1,40 @@+{-# language TemplateHaskell #-}++module Main (main) where++import Control.Applicative (liftA2)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Monoid (Sum(..))++import qualified Cmf+import qualified Data.Map as Map++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Prelude+import qualified Prelude++main :: IO Bool+main = checkParallel $$(discover)++prop_foldMapWithKey :: Property+prop_foldMapWithKey = property $ do+  let genKey = Gen.int Range.constantBounded+  let genVal = Gen.list (Range.linear 5 25) genKey+  m <- forAll $ Gen.map (Range.linear 50 200) ((,) <$> genKey <*> genVal)+  let f k v = pure $ Sum $ k * sum v+  lhs <- liftIO $ Map.foldMapWithKey f m+  rhs <- liftIO $ Cmf.foldMapWithKey f m+  lhs === rhs++prop_foldMap :: Property+prop_foldMap = property $ do+  let genKey = Gen.int Range.constantBounded+  let genVal = Gen.list (Range.linear 5 25) genKey+  l <- forAll $ Gen.list (Range.linear 50 200) ((,) <$> genKey <*> genVal)+  let f k v = pure $ Sum $ k * sum v+  lhs <- liftIO $ Prelude.foldMap (uncurry f) l+  rhs <- liftIO $ Cmf.foldMap (uncurry f) l+  lhs === rhs