Implement fromSetA for IntMap and Map (#1163)

* Implement `fromSetA`.

* Add strictness property tests.

* Verify evaluation order of applicative actions in tests.

* Use `Fun` instead of lists of pairs for `fromSet` tests.

* Add useful instances for `Bot` so it can be used elsewhere.

* Add benchmarks for `fromSet` and `fromSetA`.

* Add to gitignore.

* Add benchmark script.

* Bump bounds.

Author: L0neGamer

.gitignore

@@ -10,10 +10,12 @@
 **/dist-newstyle/*
 GNUmakefile
 dist-install
+dist-mcabal
 ghc.mk
 .stack-work
 .cabal-sandbox/
 cabal.sandbox.config
+cabal.project.local
 /benchmarks/bench-Map
 /benchmarks/bench-Set
 /benchmarks/bench-IntSet
@@ -22,3 +24,5 @@ cabal.sandbox.config
 /benchmarks/SetOperations/bench-*
 /result
 /TAGS
+
+benchmark_tmp

CONTRIBUTING.md

@@ -59,6 +59,17 @@ To do so on Windows 10 or higher, follow these steps:
 2. Enable git symlinks: `git config --global core.symlinks true`.
 3. Clone the repository again once git is properly configured.
 
+### Benchmarking script
+
+To run the all benchmarks of your branch against master, you can run the script
+`./bench.sh` while on your feature branch.
+
+This first builds and benchmarks against the master branch, and then builds and
+benchmarks on your branch, and compares between them.
+
+You can also fiddle with the script as long as the changes are reflected in your
+local master branch and run less than the full suite of benchmarks.
+
 ## Sending Pull Requests
 
 When you send a pull request, please:

bench.sh

@@ -0,0 +1,72 @@
+#! /bin/bash
+
+# convenience script to run all benchmarks for the master branch and for the
+# starting branch, and compare the before and after in the output file
+# bench-$CURR_BRANCH_NAME.out, in `benchmark_tmp/`
+
+exitWith () {
+  echo "$1"
+  exit $(($2))
+}
+
+if [ -n "$(git status --porcelain)" ]; then
+  echo "there are changes, exiting benchmark script";
+  exit 1
+fi
+
+CURR=`git rev-parse --abbrev-ref HEAD`
+
+if [ "$CURR" == "master" ]
+then
+  exitWith "current branch is master, ending benchmarking" -1
+fi
+
+BENCHMARKS=(
+  intmap-benchmarks
+  intset-benchmarks
+  map-benchmarks
+  tree-benchmarks
+  sequence-benchmarks
+  set-benchmarks
+  graph-benchmarks
+  set-operations-intmap
+  set-operations-intset
+  set-operations-map
+  set-operations-set
+  lookupge-intmap
+  lookupge-map
+)
+
+BENCHMARK_TMP="benchmark_tmp"
+
+mkdir -p $BENCHMARK_TMP
+
+git checkout master
+
+cabal build all || exitWith "master build errored" 2
+
+MASTER_BENCH_LOG="$BENCHMARK_TMP/bench-master.log"
+echo -n > $MASTER_BENCH_LOG
+
+for BENCHMARK in "${BENCHMARKS[@]}"
+do
+  echo "running $BENCHMARK on master"
+  (cabal bench $BENCHMARK --benchmark-options="--csv $BENCHMARK.csv" >> $MASTER_BENCH_LOG 2>&1) ||
+    exitWith "benchmark $BENCHMARK failed to run on master, exiting" 3
+done
+
+git checkout $CURR
+
+cabal build all || exitWith "$CURR build errored" 4
+
+CURR_BENCH_LOG="$BENCHMARK_TMP/bench-$CURR.log"
+echo -n > $CURR_BENCH_LOG
+
+for BENCHMARK in "${BENCHMARKS[@]}"
+do
+  echo "running $BENCHMARK on $CURR"
+  (cabal bench $BENCHMARK --benchmark-options="--csv $BENCHMARK-$CURR.csv --baseline $BENCHMARK.csv" >> $CURR_BENCH_LOG 2>&1) ||
+    exitWith "benchmark $BENCHMARK failed to run on $CURR, exiting" 5
+done
+
+mv containers-tests/*.csv $BENCHMARK_TMP/

containers-tests/benchmarks/IntMap.hs

@@ -9,6 +9,7 @@ import qualified Data.IntMap as M
 import qualified Data.IntMap.Strict as MS
 import qualified Data.IntSet as S
 import Data.Maybe (fromMaybe)
+import Data.Tuple.Solo (Solo (MkSolo), getSolo)
 import Data.Word (Word8)
 import System.Random (StdGen, mkStdGen, random, randoms)
 import Prelude hiding (lookup)
@@ -80,6 +81,11 @@ main = do
             whnf (\n -> M.fromAscList (unitValues [1..n])) bound
         , bench "minView" $ whnf (maybe 0 (\((k,v), m) -> k+v+M.size m) . M.minViewWithKey)
                     (M.fromList $ zip [1..10] [1..10])
+        , bench "fromSet" $ whnf (M.fromSet pred) s_random2
+        , bench "Lazy.fromSetA outer" $ whnf (M.fromSetA (MkSolo . pred)) s_random2
+        , bench "Strict.fromSetA outer" $ whnf (MS.fromSetA (MkSolo . pred)) s_random2
+        , bench "Lazy.fromSetA inner" $ whnf (getSolo . M.fromSetA (MkSolo . pred)) s_random2
+        , bench "Strict.fromSetA inner" $ whnf (getSolo . MS.fromSetA (MkSolo . pred)) s_random2
         , bench "spanAntitone" $ whnf (M.spanAntitone (<key_mid)) m
         , bench "split" $ whnf (M.split key_mid) m
         , bench "splitLookup" $ whnf (M.splitLookup key_mid) m
@@ -123,7 +129,7 @@ main = do
         ]
 
     --------------------------------------------------------
-    !bound = 2^12
+    !bound = 2^14
     keys = [1..bound]
     keys' = fmap (+ 1000000) keys
     keys'' = fmap (* 2) [1..bound]

containers-tests/benchmarks/Map.hs

@@ -10,10 +10,13 @@ import Data.Functor.Identity (Identity(..))
 import Data.List (foldl')
 import qualified Data.Map as M
 import qualified Data.Map.Strict as MS
+import qualified Data.Set as Set
 import Data.Map (alterF)
 import Data.Maybe (fromMaybe)
 import Data.Functor ((<$))
 import Data.Coerce
+import Data.Tuple.Solo (Solo (MkSolo), getSolo)
+import System.Random (StdGen, mkStdGen, random, randoms)
 import Prelude hiding (lookup)
 
 import Utils.Fold (foldBenchmarks, foldWithKeyBenchmarks)
@@ -23,9 +26,12 @@ main = do
     let m = M.fromList elems :: M.Map Int Int
         m_even = M.fromList elems_even :: M.Map Int Int
         m_odd = M.fromList elems_odd :: M.Map Int Int
+        s_random = Set.fromList keys_random :: Set.Set Int
     evaluate $ rnf [m, m_even, m_odd]
+    evaluate $ rnf [s_random]
     evaluate $ rnf
       [elems_distinct_asc, elems_distinct_desc, elems_asc, elems_desc]
+    evaluate $ rnf [keys_random]
     defaultMain
         [ bench "lookup absent" $ whnf (lookup evens) m_odd
         , bench "lookup present" $ whnf (lookup evens) m_even
@@ -124,6 +130,11 @@ main = do
         , bench "fromDistinctAscList:fusion" $ whnf (\n -> M.fromDistinctAscList [(i,i) | i <- [1..n]]) bound
         , bench "fromDistinctDescList" $ whnf M.fromDistinctDescList elems_distinct_desc
         , bench "fromDistinctDescList:fusion" $ whnf (\n -> M.fromDistinctDescList [(i,i) | i <- [n,n-1..1]]) bound
+        , bench "fromSet" $ whnf (M.fromSet pred) s_random
+        , bench "Lazy.fromSetA outer" $ whnf (M.fromSetA (MkSolo . pred)) s_random
+        , bench "Strict.fromSetA outer" $ whnf (MS.fromSetA (MkSolo . pred)) s_random
+        , bench "Lazy.fromSetA inner" $ whnf (getSolo . M.fromSetA (MkSolo . pred)) s_random
+        , bench "Strict.fromSetA inner" $ whnf (getSolo . MS.fromSetA (MkSolo . pred)) s_random
         , bench "minView" $ whnf (\m' -> case M.minViewWithKey m' of {Nothing -> 0; Just ((k,v),m'') -> k+v+M.size m''}) (M.fromAscList $ zip [1..10::Int] [100..110::Int])
         , bench "eq" $ whnf (\m' -> m' == m') m -- worst case, compares everything
         , bench "compare" $ whnf (\m' -> compare m' m') m -- worst case, compares everything
@@ -136,7 +147,7 @@ main = do
         , bench "mapKeysWith:desc" $ whnf (M.mapKeysWith (+) (negate . (`div` 2))) m
         ]
   where
-    bound = 2^12
+    bound = 2^14
     elems = shuffle elems_distinct_asc
     elems_even = zip evens evens
     elems_odd = zip odds odds
@@ -152,6 +163,7 @@ main = do
     values = [1..bound]
     sumkv k v1 v2 = k + v1 + v2
     consPair k v xs = (k, v) : xs
+    keys_random = take bound (randoms gen)
 
 add3 :: Int -> Int -> Int -> Int
 add3 x y z = x + y + z
@@ -239,3 +251,6 @@ atAltNoRules f xs m = foldl' (\m k -> runIdent (alterF (Ident . f) k m)) m xs
 maybeDel :: Int -> Maybe Int
 maybeDel n | n `mod` 3 == 0 = Nothing
            | otherwise      = Just n
+
+gen :: StdGen
+gen = mkStdGen 90

containers-tests/containers-tests.cabal

@@ -47,6 +47,7 @@ common test-deps
   import: deps
   build-depends:
       containers-tests
+    , OneTuple
     , QuickCheck                  >=2.7.1
     , tasty
     , tasty-hunit
@@ -58,6 +59,7 @@ common benchmark-deps
   build-depends:
       containers-tests
     , deepseq           >=1.1.0.0 && <1.6
+    , OneTuple
     , tasty-bench       >=0.3.1   && <0.5
 
   -- Flags recommended by tasty-bench

containers-tests/tests/Utils/Strictness.hs

@@ -27,6 +27,12 @@ instance Arbitrary a => Arbitrary (Bot a) where
     , (4, Bot <$> arbitrary)
     ]
 
+instance CoArbitrary a => CoArbitrary (Bot a) where
+  coarbitrary (Bot x) = coarbitrary x
+
+instance Function a => Function (Bot a) where
+  function = functionMap (\(Bot x) -> x) Bot
+
 {--------------------------------------------------------------------
   Lazy functions
 --------------------------------------------------------------------}

containers-tests/tests/intmap-properties.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
 
 #ifdef STRICT
 import Data.IntMap.Strict as Data.IntMap
@@ -14,7 +15,9 @@ import Data.IntSet.Internal.IntTreeCommons (Prefix(..), nomatch)
 import IntMapValidity (hasPrefix, hasPrefixSimple, valid)
 
 import Control.Applicative (Applicative(..))
+import Control.Arrow ((&&&))
 import Control.Monad ((<=<))
+import Control.Monad.Trans.Writer.Lazy
 import qualified Data.Either as Either
 import qualified Data.Foldable as Foldable
 import Data.Monoid
@@ -23,6 +26,7 @@ import qualified Data.Maybe as Maybe (mapMaybe)
 import Data.Ord
 import Data.Foldable (foldMap)
 import Data.Function
+import Data.Functor
 import Data.Traversable (Traversable(traverse), foldMapDefault)
 import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl')
 import qualified Prelude (map, filter)
@@ -212,6 +216,7 @@ main = defaultMain $ testGroup "intmap-properties"
                  prop_FoldableTraversableCompat
              , testProperty "keysSet"              prop_keysSet
              , testProperty "fromSet"              prop_fromSet
+             , testProperty "fromSetA eval order"  prop_fromSetA_action_order
              , testProperty "restrictKeys"         prop_restrictKeys
              , testProperty "withoutKeys"          prop_withoutKeys
              , testProperty "traverseWithKey identity"              prop_traverseWithKey_identity
@@ -1689,14 +1694,23 @@ prop_FoldableTraversableCompat :: Fun A [B] -> IntMap A -> Property
 prop_FoldableTraversableCompat fun m = foldMap f m === foldMapDefault f m
   where f = apply fun
 
-prop_keysSet :: [(Int, Int)] -> Bool
-prop_keysSet xs =
-  keysSet (fromList xs) == IntSet.fromList (List.map fst xs)
-
-prop_fromSet :: [(Int, Int)] -> Bool
-prop_fromSet ys =
-  let xs = List.nubBy ((==) `on` fst) ys
-  in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs
+prop_keysSet :: [Int] -> Property
+prop_keysSet keys =
+  keysSet (fromList (fmap (, ()) keys)) === IntSet.fromList keys
+
+prop_fromSet :: [Int] -> Fun Int A -> Property
+prop_fromSet keys funF =
+  let f = apply funF
+  in fromSet f (IntSet.fromList keys) === fromList (fmap (id &&& f) keys)
+
+prop_fromSetA_action_order :: [Int] -> Fun Int A -> Property
+prop_fromSetA_action_order keys funF =
+  let iSet = IntSet.fromList keys
+      f = apply funF
+      action = \k ->
+        let v = f k
+        in tell [v] $> v
+  in execWriter (fromSetA action iSet) === List.map f (IntSet.toList iSet)
 
 newtype Identity a = Identity a
     deriving (Eq, Show)

containers-tests/tests/intmap-strictness.hs

@@ -8,15 +8,17 @@ import Data.Bifunctor (bimap)
 import Data.Coerce (coerce)
 import Data.Either (partitionEithers)
 import qualified Data.Foldable as F
-import Data.Functor.Identity (Identity(..))
 import Data.Function (on)
+import Data.Functor.Compose
+import Data.Functor.Identity (Identity(..))
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe (catMaybes, mapMaybe)
 import Data.Ord (comparing)
 import Test.ChasingBottoms.IsBottom
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
+import Data.Tuple.Solo (Solo (MkSolo), getSolo)
 import Test.QuickCheck
 import Test.QuickCheck.Poly (A, B, C)
 import Test.QuickCheck.Function (apply)
@@ -68,12 +70,35 @@ prop_strictFromSet :: Func Key (Bot A) -> IntSet -> Property
 prop_strictFromSet fun set =
   isBottom (M.fromSet f set) === any (isBottom . f) (IntSet.toList set)
   where
-    f = coerce (applyFunc fun) :: Key -> A
+    f = applyFunc fun
+
+prop_strictFromSetA :: Func Key (Bot A) -> IntSet -> Property
+prop_strictFromSetA fun set =
+  isBottom (getSolo (M.fromSetA (MkSolo . f) set)) === any (isBottom . f) (IntSet.toList set)
+  where
+    f = applyFunc fun
 
 prop_lazyFromSet :: Func Key (Bot A) -> IntSet -> Property
 prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set)
   where
-    f = coerce (applyFunc fun) :: Key -> A
+    f = applyFunc fun
+
+prop_lazyFromSetA :: Func Key (Bot A) -> IntSet -> Property
+prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set))
+  where
+  f = MkSolo . applyFunc fun
+
+prop_fromSetA_equiv_strictness :: Func Int (Bot A) -> IntSet -> Property
+prop_fromSetA_equiv_strictness fun set =
+  -- strict fromSetA is the same as lazy and then forcing
+  bottomOn (M.fromSetA f set) (fmap forceValues (L.fromSetA f set)) .&&.
+  -- strict fromSetA is the same as lazy fromSetA composed with strictly applied
+  -- wrapper
+  bottomOn (M.fromSetA f set) (fmap getSolo . getCompose $ L.fromSetA (Compose . fmap (MkSolo $!) . f) set)
+  where
+  forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs
+  bottomOn = (===) `on` isBottom . getSolo
+  f = MkSolo . applyFunc fun
 
 prop_strictFromList :: [(Key, Bot A)] -> Property
 prop_strictFromList kvs =
@@ -1015,6 +1040,8 @@ tests =
     , testGroup "Construction"
       [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton
       , testPropStrictLazy "fromSet" prop_strictFromSet prop_lazyFromSet
+      , testPropStrictLazy "fromSetA" prop_strictFromSetA prop_lazyFromSetA
+      , testProperty       "fromSetA equivalences" prop_fromSetA_equiv_strictness
       , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList
       , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith
       , testPropStrictLazy "fromListWithKey" prop_strictFromListWithKey prop_lazyFromListWithKey