diff --git a/.gitignore b/.gitignore index 1cf3c3857..c835d32de 100644 --- a/.gitignore +++ b/.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 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index c8dd3df7b..230936aad 100644 --- a/CONTRIBUTING.md +++ b/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: diff --git a/bench.sh b/bench.sh new file mode 100755 index 000000000..b2fcf1eda --- /dev/null +++ b/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/ diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index c3f5522f0..81ac3e1ba 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/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 ( 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 diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index 02d64b3a1..72fd3c72a 100644 --- a/containers-tests/containers-tests.cabal +++ b/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 diff --git a/containers-tests/tests/Utils/Strictness.hs b/containers-tests/tests/Utils/Strictness.hs index 755745170..eead2666b 100644 --- a/containers-tests/tests/Utils/Strictness.hs +++ b/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 --------------------------------------------------------------------} diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 613ed1eb2..561c3bd4c 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/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) diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index 90a189c8e..e09bcad41 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -8,8 +8,9 @@ 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) @@ -17,6 +18,7 @@ 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 diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index a585391c4..d1e5a8e1e 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} #ifdef STRICT import Data.Map.Strict as Data.Map @@ -11,6 +12,7 @@ import Data.Map.Internal (Map, link2, link) import Data.Map.Internal.Debug (showTree, showTreeWith, balanced) import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), (<|>)) +import Control.Arrow ((&&&)) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class import Control.Monad.Trans.Writer.Lazy @@ -23,6 +25,7 @@ import qualified Data.Maybe as Maybe (mapMaybe) import Data.Ord import Data.Semigroup (Arg(..)) import Data.Function +import Data.Functor import qualified Data.Foldable as Foldable import qualified Data.Bifoldable as Bifoldable import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl', take, drop, splitAt) @@ -256,6 +259,7 @@ main = defaultMain $ testGroup "map-properties" , testProperty "keysSet" prop_keysSet , testProperty "argSet" prop_argSet , testProperty "fromSet" prop_fromSet + , testProperty "fromSetA eval order" prop_fromSetA_action_order , testProperty "fromArgSet" prop_fromArgSet , testProperty "takeWhileAntitone" prop_takeWhileAntitone , testProperty "dropWhileAntitone" prop_dropWhileAntitone @@ -1708,23 +1712,31 @@ prop_bifoldl' ck cv n m = Bifoldable.bifoldl' ck' cv' n m === Foldable.foldl' c' cv' = curry (apply cv) acc `c'` (k,v) = (acc `ck'` k) `cv'` v -prop_keysSet :: [(Int, Int)] -> Bool -prop_keysSet xs = - keysSet (fromList xs) == Set.fromList (List.map fst xs) +prop_keysSet :: [OrdA] -> Property +prop_keysSet keys = + keysSet (fromList (fmap (, ()) keys)) === Set.fromList keys -prop_argSet :: [(Int, Int)] -> Bool +prop_argSet :: [(OrdA, B)] -> Property prop_argSet xs = - argSet (fromList xs) == Set.fromList (List.map (uncurry Arg) xs) - -prop_fromSet :: [(Int, Int)] -> Bool -prop_fromSet ys = - let xs = List.nubBy ((==) `on` fst) ys - in fromSet (\k -> fromJust $ List.lookup k xs) (Set.fromList $ List.map fst xs) == fromList xs - -prop_fromArgSet :: [(Int, Int)] -> Bool + argSet (fromList xs) === Set.fromList (List.map (uncurry Arg) xs) + +prop_fromSet :: [OrdA] -> Fun OrdA B -> Property +prop_fromSet keys funF = + let f = apply funF + in fromSet f (Set.fromList keys) === fromList (fmap (id &&& f) keys) + +prop_fromSetA_action_order :: [OrdA] -> Fun OrdA B -> Property +prop_fromSetA_action_order keys funF = + let iSet = Set.fromList keys + f = apply funF + action = \k -> + let v = f k + in tell [v] $> v + in execWriter (fromSetA action iSet) === List.map f (Set.toList iSet) + +prop_fromArgSet :: [(OrdA, B)] -> Property prop_fromArgSet ys = - let xs = List.nubBy ((==) `on` fst) ys - in fromArgSet (Set.fromList $ List.map (uncurry Arg) xs) == fromList xs + fromArgSet (Set.fromList $ List.map (uncurry Arg) ys) === fromList ys prop_eq :: Map Int A -> Map Int A -> Property prop_eq m1 m2 = (m1 == m2) === (toList m1 == toList m2) diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index f6e4630c8..6cce8ccdd 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -9,12 +9,14 @@ import Data.Coerce (coerce) import Data.Either (partitionEithers) import Data.Foldable as F import Data.Function (on) +import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity(..)) import qualified Data.List as List import qualified Data.List.NonEmpty as NE import Data.Ord (Down(..), comparing) import Data.Maybe (catMaybes, mapMaybe) import Data.Semigroup (Arg(..)) +import Data.Tuple.Solo (Solo (MkSolo), getSolo) import Test.ChasingBottoms.IsBottom (bottom, isBottom) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -132,12 +134,35 @@ prop_strictFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromSet fun set = isBottom (M.fromSet f set) === any (isBottom . f) (Set.toList set) where - f = coerce (applyFunc fun) :: OrdA -> A + f = applyFunc fun + +prop_strictFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_strictFromSetA fun set = + isBottom (getSolo (M.fromSetA (MkSolo . f) set)) === any (isBottom . f) (Set.toList set) + where + f = applyFunc fun prop_lazyFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) where - f = coerce (applyFunc fun) :: OrdA -> A + f = applyFunc fun + +prop_lazyFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) + where + f = MkSolo . applyFunc fun + +prop_fromSetA_equiv_strictness :: Func OrdA (Bot A) -> Set OrdA -> 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 fromSet is the same as lazy fromSetA with a strict function, + -- and unwrapping the container + 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_strictFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromArgSet fun set = @@ -1153,6 +1178,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 "fromArgSet" prop_strictFromArgSet prop_lazyFromArgSet , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith diff --git a/containers/changelog.md b/containers/changelog.md index 8f53bbbce..21560b8a3 100644 --- a/containers/changelog.md +++ b/containers/changelog.md @@ -8,7 +8,10 @@ ([#1135](https://github.com/haskell/containers/pull/1135)) * Add `mapMaybe` for `Seq`, `Set` and `IntSet`. (Phil Hazelden) - ([#1159](https://github.com/haskell/containers/pull/1159) + ([#1159](https://github.com/haskell/containers/pull/1159)) + +* Add `fromSetA` for `Map` and `IntMap`. (L0neGamer) + ([#1163](https://github.com/haskell/containers/pull/1163)) ### Performance improvements diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6cd047625..6535f5f85 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -109,6 +109,8 @@ module Data.IntMap.Internal ( -- * Construction , empty , singleton + , fromSet + , fromSetA -- ** Insertion , insert @@ -221,7 +223,6 @@ module Data.IntMap.Internal ( , keys , assocs , keysSet - , fromSet -- ** Lists , toList @@ -3309,9 +3310,24 @@ keysSet (Bin p l r) -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet -> IntMap a -fromSet _ IntSet.Nil = Nil -fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r) -fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else +fromSet f = runIdentity . fromSetA (pure . f) +#endif + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value, while within an 'Applicative' context. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.IntSet.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.IntSet.empty == pure empty + +fromSetA :: Applicative f => (Key -> f a) -> IntSet -> f (IntMap a) +fromSetA _ IntSet.Nil = pure Nil +fromSetA f (IntSet.Bin p l r) + | signBranch p = liftA2 (flip (Bin p)) (fromSetA f r) (fromSetA f l) + | otherwise = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) +fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) where -- This is slightly complicated, as we to convert the dense -- representation of IntSet into tree representation of IntMap. @@ -3322,7 +3338,7 @@ fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) -- create a Bin node, otherwise exactly one of them is nonempty -- and we construct the IntMap from that half. buildTree g !prefix !bmask bits = case bits of - 0 -> Tip prefix (g prefix) + 0 -> Tip prefix <$> (g prefix) _ -> case bits `iShiftRL` 1 of bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> @@ -3330,9 +3346,15 @@ fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> buildTree g prefix bmask bits2 | otherwise -> - Bin (Prefix (prefix .|. bits2)) - (buildTree g prefix bmask bits2) - (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) + liftA2 + (Bin (Prefix (prefix .|. bits2))) + (buildTree g prefix bmask bits2) + (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif {-------------------------------------------------------------------- Lists diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index e6be3148e..d49491669 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -103,6 +103,7 @@ module Data.IntMap.Lazy ( , empty , singleton , fromSet + , fromSetA -- ** From Unordered Lists , fromList diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 91c083152..41b0a587b 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -121,6 +121,7 @@ module Data.IntMap.Strict ( , empty , singleton , fromSet + , fromSetA -- ** From Unordered Lists , fromList diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 85dd7d63f..aba93fa49 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -64,6 +64,7 @@ module Data.IntMap.Strict.Internal ( , empty , singleton , fromSet + , fromSetA -- ** From Unordered Lists , fromList @@ -330,6 +331,11 @@ import qualified Data.IntSet.Internal as IntSet import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL) import Utils.Containers.Internal.StrictPair import qualified Data.Foldable as Foldable +import Data.Functor.Identity (Identity (..)) + +#ifdef __GLASGOW_HASKELL__ +import Data.Coerce +#endif {-------------------------------------------------------------------- Construction @@ -1056,25 +1062,63 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0 -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a -fromSet _ IntSet.Nil = Nil -fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r) -fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) - where -- This is slightly complicated, as we to convert the dense - -- representation of IntSet into tree representation of IntMap. - -- - -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'. - -- We split bmask into halves corresponding to left and right subtree. - -- If they are both nonempty, we create a Bin node, otherwise exactly - -- one of them is nonempty and we construct the IntMap from that half. - buildTree g !prefix !bmask bits = case bits of - 0 -> Tip prefix $! g prefix - _ -> case bits `iShiftRL` 1 of - bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 - | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g prefix bmask bits2 - | otherwise -> - Bin (Prefix (prefix .|. bits2)) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else +fromSet f = runIdentity . fromSetA (pure . f) +#endif + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value, while within an 'Applicative' context. +-- +-- This can only be as strict as the 'Applicative' allows it to be. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.IntSet.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.IntSet.empty == pure empty +-- +-- The following strictness properties hold: +-- +-- > fromSetA f = fmap forceValues . Data.Map.Lazy.fromSetA f +-- > where +-- > forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs +-- +-- > fromSetA f = +-- > fmap getSolo . +-- > getCompose . +-- > Data.Map.Lazy.fromSetA (Compose . fmap (MkSolo $!) . f) + +fromSetA :: Applicative f => (Key -> f a) -> IntSet.IntSet -> f (IntMap a) +fromSetA _ IntSet.Nil = pure Nil +fromSetA f (IntSet.Bin p l r) + | signBranch p = liftA2 (flip (Bin p)) (fromSetA f r) (fromSetA f l) + | otherwise = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) +fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) + where + -- This is slightly complicated, as we to convert the dense + -- representation of IntSet into tree representation of IntMap. + -- + -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'. + -- We split bmask into halves corresponding to left and right subtree. + -- If they are both nonempty, we create a Bin node, otherwise exactly + -- one of them is nonempty and we construct the IntMap from that half. + buildTree g !prefix !bmask bits = case bits of + 0 -> (Tip prefix $!) <$> g prefix + _ -> case bits `iShiftRL` 1 of + bits2 + | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> + buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 + | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> + buildTree g prefix bmask bits2 + | otherwise -> + liftA2 + (Bin (Prefix (prefix .|. bits2))) + (buildTree g prefix bmask bits2) + (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif {-------------------------------------------------------------------- Lists diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 40181416f..398e1e9cb 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -270,6 +270,7 @@ module Data.Map.Internal ( , keysSet , argSet , fromSet + , fromSetA , fromArgSet -- ** Lists @@ -3535,8 +3536,30 @@ argSet (Bin sz kx x l r) = Set.Bin sz (Arg kx x) (argSet l) (argSet r) -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet _ Set.Tip = Tip -fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else +fromSet f = runIdentity . fromSetA (pure . f) +#endif + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value in an 'Applicative' context. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.Set.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.Set.empty == pure empty + +fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) +fromSetA _ Set.Tip = pure Tip +fromSetA f (Set.Bin sz x l r) = + flip (Bin sz x) + <$> fromSetA f l + <*> f x + <*> fromSetA f r +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- diff --git a/containers/src/Data/Map/Lazy.hs b/containers/src/Data/Map/Lazy.hs index 56ca3c536..f1c4c984d 100644 --- a/containers/src/Data/Map/Lazy.hs +++ b/containers/src/Data/Map/Lazy.hs @@ -106,6 +106,7 @@ module Data.Map.Lazy ( , empty , singleton , fromSet + , fromSetA , fromArgSet -- ** From Unordered Lists diff --git a/containers/src/Data/Map/Strict.hs b/containers/src/Data/Map/Strict.hs index de0fb18c4..9715ad388 100644 --- a/containers/src/Data/Map/Strict.hs +++ b/containers/src/Data/Map/Strict.hs @@ -120,6 +120,7 @@ module Data.Map.Strict , empty , singleton , fromSet + , fromSetA , fromArgSet -- ** From Unordered Lists diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index d70977e38..de7edf82f 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -214,6 +214,7 @@ module Data.Map.Strict.Internal , keysSet , argSet , fromSet + , fromSetA , fromArgSet -- ** Lists @@ -420,9 +421,7 @@ import Utils.Containers.Internal.StrictPair import Data.Coerce #endif -#ifdef __GLASGOW_HASKELL__ import Data.Functor.Identity (Identity (..)) -#endif import qualified Data.Foldable as Foldable @@ -1455,8 +1454,43 @@ mapKeysWith c f m = -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet _ Set.Tip = Tip -fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else +fromSet f = runIdentity . fromSetA (pure . f) +#endif + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value in an 'Applicative' context. +-- +-- This can only be as strict as the 'Applicative' allows it to be. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.Set.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.Set.empty == pure empty +-- +-- The following strictness properties hold: +-- +-- > fromSetA f = fmap forceValues . Data.Map.Lazy.fromSetA f +-- > where +-- > forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs +-- +-- > fromSetA f = +-- > fmap getSolo . +-- > getCompose . +-- > Data.Map.Lazy.fromSetA (Compose . fmap (MkSolo $!) . f) + +fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) +fromSetA _ Set.Tip = pure Tip +fromSetA f (Set.Bin sz x l r) = + flip (Bin sz x $!) + <$> fromSetA f l + <*> f x + <*> fromSetA f r +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. --