summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordfeuer <>2019-06-11 12:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-06-11 12:52:00 (GMT)
commitdb8415ffb18ecb0e33ce40bb6e459380024d58d4 (patch)
treed5df2753b122e66e237415009c3920889be313a7
parent644652c20e19d75e9609d48424bd4e7da9227da0 (diff)
version 0.6.1.1HEAD0.6.1.1master
-rw-r--r--Data/IntMap/Merge/Strict.hs100
-rw-r--r--benchmarks/IntMap.hs97
-rw-r--r--benchmarks/IntSet.hs52
-rw-r--r--benchmarks/LookupGE/IntMap.hs47
-rw-r--r--benchmarks/LookupGE/LookupGE_IntMap.hs94
-rw-r--r--benchmarks/LookupGE/LookupGE_Map.hs75
-rw-r--r--benchmarks/LookupGE/Makefile3
-rw-r--r--benchmarks/LookupGE/Map.hs46
-rw-r--r--benchmarks/Makefile18
-rw-r--r--benchmarks/Map.hs197
-rw-r--r--benchmarks/Sequence.hs244
-rw-r--r--benchmarks/Set.hs53
-rw-r--r--benchmarks/SetOperations/Makefile3
-rw-r--r--benchmarks/SetOperations/SetOperations-IntMap.hs6
-rw-r--r--benchmarks/SetOperations/SetOperations-IntSet.hs6
-rw-r--r--benchmarks/SetOperations/SetOperations-Map.hs6
-rw-r--r--benchmarks/SetOperations/SetOperations-Set.hs6
-rw-r--r--benchmarks/SetOperations/SetOperations.hs45
-rwxr-xr-xbenchmarks/bench-cmp.pl24
-rwxr-xr-xbenchmarks/bench-cmp.sh3
-rw-r--r--changelog.md35
-rw-r--r--containers.cabal523
-rw-r--r--src/Data/Containers/ListUtils.hs (renamed from Data/Containers/ListUtils.hs)22
-rw-r--r--src/Data/Graph.hs (renamed from Data/Graph.hs)31
-rw-r--r--src/Data/IntMap.hs (renamed from Data/IntMap.hs)0
-rw-r--r--src/Data/IntMap/Internal.hs (renamed from Data/IntMap/Internal.hs)71
-rw-r--r--src/Data/IntMap/Internal/Debug.hs (renamed from Data/IntMap/Internal/Debug.hs)0
-rw-r--r--src/Data/IntMap/Internal/DeprecatedDebug.hs (renamed from Data/IntMap/Internal/DeprecatedDebug.hs)0
-rw-r--r--src/Data/IntMap/Lazy.hs (renamed from Data/IntMap/Lazy.hs)0
-rw-r--r--src/Data/IntMap/Merge/Lazy.hs (renamed from Data/IntMap/Merge/Lazy.hs)4
-rw-r--r--src/Data/IntMap/Merge/Strict.hs233
-rw-r--r--src/Data/IntMap/Strict.hs253
-rw-r--r--src/Data/IntMap/Strict/Internal.hs (renamed from Data/IntMap/Strict.hs)35
-rw-r--r--src/Data/IntSet.hs (renamed from Data/IntSet.hs)0
-rw-r--r--src/Data/IntSet/Internal.hs (renamed from Data/IntSet/Internal.hs)14
-rw-r--r--src/Data/Map.hs (renamed from Data/Map.hs)2
-rw-r--r--src/Data/Map/Internal.hs (renamed from Data/Map/Internal.hs)101
-rw-r--r--src/Data/Map/Internal/Debug.hs (renamed from Data/Map/Internal/Debug.hs)0
-rw-r--r--src/Data/Map/Internal/DeprecatedShowTree.hs (renamed from Data/Map/Internal/DeprecatedShowTree.hs)0
-rw-r--r--src/Data/Map/Lazy.hs (renamed from Data/Map/Lazy.hs)8
-rw-r--r--src/Data/Map/Merge/Lazy.hs (renamed from Data/Map/Merge/Lazy.hs)4
-rw-r--r--src/Data/Map/Merge/Strict.hs (renamed from Data/Map/Merge/Strict.hs)10
-rw-r--r--src/Data/Map/Strict.hs (renamed from Data/Map/Strict.hs)10
-rw-r--r--src/Data/Map/Strict/Internal.hs (renamed from Data/Map/Strict/Internal.hs)21
-rw-r--r--src/Data/Sequence.hs (renamed from Data/Sequence.hs)7
-rw-r--r--src/Data/Sequence/Internal.hs (renamed from Data/Sequence/Internal.hs)20
-rw-r--r--src/Data/Sequence/Internal/Sorting.hs (renamed from Data/Sequence/Internal/Sorting.hs)4
-rw-r--r--src/Data/Set.hs (renamed from Data/Set.hs)0
-rw-r--r--src/Data/Set/Internal.hs (renamed from Data/Set/Internal.hs)101
-rw-r--r--src/Data/Tree.hs (renamed from Data/Tree.hs)16
-rw-r--r--src/Utils/Containers/Internal/BitQueue.hs (renamed from Utils/Containers/Internal/BitQueue.hs)2
-rw-r--r--src/Utils/Containers/Internal/BitUtil.hs (renamed from Utils/Containers/Internal/BitUtil.hs)12
-rw-r--r--src/Utils/Containers/Internal/Coercions.hs (renamed from Utils/Containers/Internal/Coercions.hs)0
-rw-r--r--src/Utils/Containers/Internal/PtrEquality.hs (renamed from Utils/Containers/Internal/PtrEquality.hs)0
-rw-r--r--src/Utils/Containers/Internal/State.hs (renamed from Utils/Containers/Internal/State.hs)0
-rw-r--r--src/Utils/Containers/Internal/StrictMaybe.hs (renamed from Utils/Containers/Internal/StrictMaybe.hs)0
-rw-r--r--src/Utils/Containers/Internal/StrictPair.hs (renamed from Utils/Containers/Internal/StrictPair.hs)0
-rw-r--r--src/Utils/Containers/Internal/TypeError.hs (renamed from Utils/Containers/Internal/TypeError.hs)0
-rw-r--r--tests/IntMapValidity.hs65
-rw-r--r--tests/IntSetValidity.hs89
-rw-r--r--tests/Makefile20
-rw-r--r--tests/bitqueue-properties.hs34
-rw-r--r--tests/graph-properties.hs111
-rw-r--r--tests/intmap-properties.hs1166
-rw-r--r--tests/intmap-strictness.hs125
-rw-r--r--tests/intset-properties.hs400
-rw-r--r--tests/intset-strictness.hs43
-rw-r--r--tests/listutils-properties.hs60
-rw-r--r--tests/map-properties.hs1400
-rw-r--r--tests/map-strictness.hs125
-rw-r--r--tests/seq-properties.hs919
-rw-r--r--tests/set-properties.hs637
-rw-r--r--tests/tree-properties.hs104
73 files changed, 883 insertions, 7079 deletions
diff --git a/Data/IntMap/Merge/Strict.hs b/Data/IntMap/Merge/Strict.hs
deleted file mode 100644
index 100708c..0000000
--- a/Data/IntMap/Merge/Strict.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-#if __GLASGOW_HASKELL__
-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-#endif
-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
-{-# LANGUAGE Safe #-}
-#endif
-#if __GLASGOW_HASKELL__ >= 708
-{-# LANGUAGE RoleAnnotations #-}
-{-# LANGUAGE TypeFamilies #-}
-#define USE_MAGIC_PROXY 1
-#endif
-
-#if USE_MAGIC_PROXY
-{-# LANGUAGE MagicHash #-}
-#endif
-
-#include "containers.h"
-
------------------------------------------------------------------------------
--- |
--- Module : Data.IntMap.Merge.Strict
--- Copyright : (c) wren romano 2016
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Portability : portable
---
--- This module defines an API for writing functions that merge two
--- maps. The key functions are 'merge' and 'mergeA'.
--- Each of these can be used with several different \"merge tactics\".
---
--- The 'merge' and 'mergeA' functions are shared by
--- the lazy and strict modules. Only the choice of merge tactics
--- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing'
--- from this module then the results will be forced before they are
--- inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from
--- "Data.Map.Merge.Lazy" then they will not.
---
--- == Efficiency note
---
--- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'
--- tactics are included because they are valid. However, they are
--- inefficient in many cases and should usually be avoided. The instances
--- for 'WhenMatched' tactics should not pose any major efficiency problems.
---
--- @since 0.5.9
-
-module Data.IntMap.Merge.Strict (
- -- ** Simple merge tactic types
- SimpleWhenMissing
- , SimpleWhenMatched
-
- -- ** General combining function
- , merge
-
- -- *** @WhenMatched@ tactics
- , zipWithMaybeMatched
- , zipWithMatched
-
- -- *** @WhenMissing@ tactics
- , mapMaybeMissing
- , dropMissing
- , preserveMissing
- , mapMissing
- , filterMissing
-
- -- ** Applicative merge tactic types
- , WhenMissing
- , WhenMatched
-
- -- ** Applicative general combining function
- , mergeA
-
- -- *** @WhenMatched@ tactics
- -- | The tactics described for 'merge' work for
- -- 'mergeA' as well. Furthermore, the following
- -- are available.
- , zipWithMaybeAMatched
- , zipWithAMatched
-
- -- *** @WhenMissing@ tactics
- -- | The tactics described for 'merge' work for
- -- 'mergeA' as well. Furthermore, the following
- -- are available.
- , traverseMaybeMissing
- , traverseMissing
- , filterAMissing
-
- -- ** Covariant maps for tactics
- , mapWhenMissing
- , mapWhenMatched
-
- -- ** Miscellaneous functions on tactics
-
- , runWhenMatched
- , runWhenMissing
- ) where
-
-import Data.IntMap.Internal
diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs
deleted file mode 100644
index 43ddd91..0000000
--- a/benchmarks/IntMap.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module Main where
-
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Criterion.Main (bench, defaultMain, whnf)
-import Data.List (foldl')
-import qualified Data.IntMap as M
-import qualified Data.IntMap.Strict as MS
-import Data.Maybe (fromMaybe)
-import Prelude hiding (lookup)
-
-main = do
- let m = M.fromAscList elems :: M.IntMap Int
- evaluate $ rnf [m]
- defaultMain
- [ bench "lookup" $ whnf (lookup keys) m
- , bench "insert" $ whnf (ins elems) M.empty
- , bench "insertWith empty" $ whnf (insWith elems) M.empty
- , bench "insertWith update" $ whnf (insWith elems) m
- , bench "insertWith' empty" $ whnf (insWith' elems) M.empty
- , bench "insertWith' update" $ whnf (insWith' elems) m
- , bench "insertWithKey empty" $ whnf (insWithKey elems) M.empty
- , bench "insertWithKey update" $ whnf (insWithKey elems) m
- , bench "insertWithKey' empty" $ whnf (insWithKey' elems) M.empty
- , bench "insertWithKey' update" $ whnf (insWithKey' elems) m
- , bench "insertLookupWithKey empty" $ whnf (insLookupWithKey elems) M.empty
- , bench "insertLookupWithKey update" $ whnf (insLookupWithKey elems) m
- , bench "map" $ whnf (M.map (+ 1)) m
- , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m
- , bench "foldlWithKey" $ whnf (ins elems) m
- , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m
- , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m
- , bench "delete" $ whnf (del keys) m
- , bench "update" $ whnf (upd keys) m
- , bench "updateLookupWithKey" $ whnf (upd' keys) m
- , bench "alter" $ whnf (alt keys) m
- , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m
- , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m
- , bench "fromList" $ whnf M.fromList elems
- , bench "fromAscList" $ whnf M.fromAscList elems
- , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems
- , bench "minView" $ whnf (maybe 0 (\((k,v), m) -> k+v+M.size m) . M.minViewWithKey)
- (M.fromList $ zip [1..10] [1..10])
- ]
- where
- elems = zip keys values
- keys = [1..2^12]
- values = [1..2^12]
- sum k v1 v2 = k + v1 + v2
- consPair k v xs = (k, v) : xs
-
-add3 :: Int -> Int -> Int -> Int
-add3 x y z = x + y + z
-{-# INLINE add3 #-}
-
-lookup :: [Int] -> M.IntMap Int -> Int
-lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs
-
-ins :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int
-ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs
-
-insWith :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int
-insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs
-
-insWithKey :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int
-insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs
-
-insWith' :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int
-insWith' xs m = foldl' (\m (k, v) -> MS.insertWith (+) k v m) m xs
-
-insWithKey' :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int
-insWithKey' xs m = foldl' (\m (k, v) -> MS.insertWithKey add3 k v m) m xs
-
-data PairS a b = PS !a !b
-
-insLookupWithKey :: [(Int, Int)] -> M.IntMap Int -> (Int, M.IntMap Int)
-insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
- where
- f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m
- in PS (fromMaybe 0 n' + n) m'
-
-del :: [Int] -> M.IntMap Int -> M.IntMap Int
-del xs m = foldl' (\m k -> M.delete k m) m xs
-
-upd :: [Int] -> M.IntMap Int -> M.IntMap Int
-upd xs m = foldl' (\m k -> M.update Just k m) m xs
-
-upd' :: [Int] -> M.IntMap Int -> M.IntMap Int
-upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m xs
-
-alt :: [Int] -> M.IntMap Int -> M.IntMap Int
-alt xs m = foldl' (\m k -> M.alter id k m) m xs
-
-maybeDel :: Int -> Maybe Int
-maybeDel n | n `mod` 3 == 0 = Nothing
- | otherwise = Just n
diff --git a/benchmarks/IntSet.hs b/benchmarks/IntSet.hs
deleted file mode 100644
index 95d99d5..0000000
--- a/benchmarks/IntSet.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Main where
-
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Criterion.Main (bench, defaultMain, whnf)
-import Data.List (foldl')
-import qualified Data.IntSet as S
-
-main = do
- let s = S.fromAscList elems :: S.IntSet
- s_even = S.fromAscList elems_even :: S.IntSet
- s_odd = S.fromAscList elems_odd :: S.IntSet
- evaluate $ rnf [s, s_even, s_odd]
- defaultMain
- [ bench "member" $ whnf (member elems) s
- , bench "insert" $ whnf (ins elems) S.empty
- , bench "map" $ whnf (S.map (+ 1)) s
- , bench "filter" $ whnf (S.filter ((== 0) . (`mod` 2))) s
- , bench "partition" $ whnf (S.partition ((== 0) . (`mod` 2))) s
- , bench "fold" $ whnf (S.fold (:) []) s
- , bench "delete" $ whnf (del elems) s
- , bench "findMin" $ whnf S.findMin s
- , bench "findMax" $ whnf S.findMax s
- , bench "deleteMin" $ whnf S.deleteMin s
- , bench "deleteMax" $ whnf S.deleteMax s
- , bench "unions" $ whnf S.unions [s_even, s_odd]
- , bench "union" $ whnf (S.union s_even) s_odd
- , bench "difference" $ whnf (S.difference s) s_even
- , bench "intersection" $ whnf (S.intersection s) s_even
- , bench "fromList" $ whnf S.fromList elems
- , bench "fromAscList" $ whnf S.fromAscList elems
- , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems
- , bench "disjoint:false" $ whnf (S.disjoint s) s_even
- , bench "disjoint:true" $ whnf (S.disjoint s_odd) s_even
- , bench "null.intersection:false" $ whnf (S.null. S.intersection s) s_even
- , bench "null.intersection:true" $ whnf (S.null. S.intersection s_odd) s_even
- ]
- where
- elems = [1..2^12]
- elems_even = [2,4..2^12]
- elems_odd = [1,3..2^12]
-
-member :: [Int] -> S.IntSet -> Int
-member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs
-
-ins :: [Int] -> S.IntSet -> S.IntSet
-ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs
-
-del :: [Int] -> S.IntSet -> S.IntSet
-del xs s0 = foldl' (\s k -> S.delete k s) s0 xs
diff --git a/benchmarks/LookupGE/IntMap.hs b/benchmarks/LookupGE/IntMap.hs
deleted file mode 100644
index 993b0ee..0000000
--- a/benchmarks/LookupGE/IntMap.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module Main where
-
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Criterion.Main (bench, defaultMain, nf)
-import Data.List (foldl')
-import qualified Data.IntMap as M
-import qualified LookupGE_IntMap as M
-import Data.Maybe (fromMaybe)
-import Prelude hiding (lookup)
-
-main :: IO ()
-main = do
- evaluate $ rnf [m_even, m_odd, m_large]
- defaultMain [b f | b <- benches, f <- funs1]
- where
- m_even = M.fromAscList elems_even :: M.IntMap Int
- m_odd = M.fromAscList elems_odd :: M.IntMap Int
- m_large = M.fromAscList elems_large :: M.IntMap Int
- bound = 2^12
- elems_even = zip evens evens
- elems_odd = zip odds odds
- elems_large = zip large large
- evens = [2,4..bound]
- odds = [1,3..bound]
- large = [1,100..50*bound]
- benches =
- [ \(n,fun) -> bench (n++" present") $ nf (fge fun evens) m_even
- , \(n,fun) -> bench (n++" absent") $ nf (fge fun evens) m_odd
- , \(n,fun) -> bench (n++" far") $ nf (fge fun odds) m_large
- , \(n,fun) -> bench (n++" !present") $ nf (fge2 fun evens) m_even
- , \(n,fun) -> bench (n++" !absent") $ nf (fge2 fun evens) m_odd
- , \(n,fun) -> bench (n++" !far") $ nf (fge2 fun odds) m_large
- ]
- funs1 = [ ("GE split", M.lookupGE1)
- , ("GE Craig", M.lookupGE2)
- , ("GE Twan", M.lookupGE3)
- , ("GE Milan", M.lookupGE4) ]
-
-fge :: (Int -> M.IntMap Int -> Maybe (Int,Int)) -> [Int] -> M.IntMap Int -> (Int,Int)
-fge fun xs m = foldl' (\n k -> fromMaybe n (fun k m)) (0,0) xs
-
--- forcing values inside tuples!
-fge2 :: (Int -> M.IntMap Int -> Maybe (Int,Int)) -> [Int] -> M.IntMap Int -> (Int,Int)
-fge2 fun xs m = foldl' (\n@(!_, !_) k -> fromMaybe n (fun k m)) (0,0) xs
-
diff --git a/benchmarks/LookupGE/LookupGE_IntMap.hs b/benchmarks/LookupGE/LookupGE_IntMap.hs
deleted file mode 100644
index ff849b1..0000000
--- a/benchmarks/LookupGE/LookupGE_IntMap.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-{-# LANGUAGE CPP #-}
-module LookupGE_IntMap where
-
-import Prelude hiding (null)
-import Data.IntMap.Internal
-
-lookupGE1 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE1 k m =
- case splitLookup k m of
- (_,Just v,_) -> Just (k,v)
- (_,Nothing,r) -> findMinMaybe r
-
-lookupGE2 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE2 k t = case t of
- Bin _ m l r | m < 0 -> if k >= 0
- then go l
- else case go r of
- Nothing -> Just $ findMin l
- justx -> justx
- _ -> go t
- where
- go (Bin p m l r)
- | nomatch k p m = if k < p
- then Just $ findMin l
- else Nothing
- | zero k m = case go l of
- Nothing -> Just $ findMin r
- justx -> justx
- | otherwise = go r
- go (Tip ky y)
- | k > ky = Nothing
- | otherwise = Just (ky, y)
- go Nil = Nothing
-
-lookupGE3 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE3 k t = k `seq` case t of
- Bin _ m l r | m < 0 -> if k >= 0
- then go Nothing l
- else go (Just (findMin l)) r
- _ -> go Nothing t
- where
- go def (Bin p m l r)
- | nomatch k p m = if k < p then Just $ findMin l else def
- | zero k m = go (Just $ findMin r) l
- | otherwise = go def r
- go def (Tip ky y)
- | k > ky = def
- | otherwise = Just (ky, y)
- go def Nil = def
-
-lookupGE4 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE4 k t = k `seq` case t of
- Bin _ m l r | m < 0 -> if k >= 0 then go Nil l
- else go l r
- _ -> go Nil t
- where
- go def (Bin p m l r)
- | nomatch k p m = if k < p then fMin l else fMin def
- | zero k m = go r l
- | otherwise = go def r
- go def (Tip ky y)
- | k > ky = fMin def
- | otherwise = Just (ky, y)
- go def Nil = fMin def
-
- fMin :: IntMap a -> Maybe (Key, a)
- fMin Nil = Nothing
- fMin (Tip ky y) = Just (ky, y)
- fMin (Bin _ _ l _) = fMin l
-
--------------------------------------------------------------------------------
--- Utilities
--------------------------------------------------------------------------------
-
--- | /O(log n)/. The minimal key of the map.
-findMinMaybe :: IntMap a -> Maybe (Key, a)
-findMinMaybe m
- | null m = Nothing
- | otherwise = Just (findMin m)
-
-#ifdef TESTING
--------------------------------------------------------------------------------
--- Properties:
--------------------------------------------------------------------------------
-
-prop_lookupGE12 :: Int -> [Int] -> Bool
-prop_lookupGE12 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE2 x m
-
-prop_lookupGE13 :: Int -> [Int] -> Bool
-prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE3 x m
-
-prop_lookupGE14 :: Int -> [Int] -> Bool
-prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m
-#endif
diff --git a/benchmarks/LookupGE/LookupGE_Map.hs b/benchmarks/LookupGE/LookupGE_Map.hs
deleted file mode 100644
index 56cabf9..0000000
--- a/benchmarks/LookupGE/LookupGE_Map.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-{-# LANGUAGE BangPatterns, CPP #-}
-module LookupGE_Map where
-
-import Data.Map.Internal
-
-lookupGE1 :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupGE1 k m =
- case splitLookup k m of
- (_,Just v,_) -> Just (k,v)
- (_,Nothing,r) -> findMinMaybe r
-{-# INLINABLE lookupGE1 #-}
-
-lookupGE2 :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupGE2 = go
- where
- go !_ Tip = Nothing
- go !k (Bin _ kx x l r) =
- case compare k kx of
- LT -> case go k l of
- Nothing -> Just (kx,x)
- ret -> ret
- GT -> go k r
- EQ -> Just (kx,x)
-{-# INLINABLE lookupGE2 #-}
-
-lookupGE3 :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupGE3 = go Nothing
- where
- go def !_ Tip = def
- go def !k (Bin _ kx x l r) =
- case compare k kx of
- LT -> go (Just (kx,x)) k l
- GT -> go def k r
- EQ -> Just (kx,x)
-{-# INLINABLE lookupGE3 #-}
-
-lookupGE4 :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupGE4 k = k `seq` goNothing
- where
- goNothing Tip = Nothing
- goNothing (Bin _ kx x l r) = case compare k kx of
- LT -> goJust kx x l
- EQ -> Just (kx, x)
- GT -> goNothing r
-
- goJust ky y Tip = Just (ky, y)
- goJust ky y (Bin _ kx x l r) = case compare k kx of
- LT -> goJust kx x l
- EQ -> Just (kx, x)
- GT -> goJust ky y r
-{-# INLINABLE lookupGE4 #-}
-
--------------------------------------------------------------------------------
--- Utilities
--------------------------------------------------------------------------------
-
-findMinMaybe :: Map k a -> Maybe (k,a)
-findMinMaybe (Bin _ kx x Tip _) = Just (kx,x)
-findMinMaybe (Bin _ _ _ l _) = findMinMaybe l
-findMinMaybe Tip = Nothing
-
-#ifdef TESTING
--------------------------------------------------------------------------------
--- Properties:
--------------------------------------------------------------------------------
-
-prop_lookupGE12 :: Int -> [Int] -> Bool
-prop_lookupGE12 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE2 x m
-
-prop_lookupGE13 :: Int -> [Int] -> Bool
-prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE3 x m
-
-prop_lookupGE14 :: Int -> [Int] -> Bool
-prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m
-#endif
diff --git a/benchmarks/LookupGE/Makefile b/benchmarks/LookupGE/Makefile
deleted file mode 100644
index 019967b..0000000
--- a/benchmarks/LookupGE/Makefile
+++ /dev/null
@@ -1,3 +0,0 @@
-TOP = ..
-
-include ../Makefile
diff --git a/benchmarks/LookupGE/Map.hs b/benchmarks/LookupGE/Map.hs
deleted file mode 100644
index 42df16e..0000000
--- a/benchmarks/LookupGE/Map.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module Main where
-
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Criterion.Main (defaultMain, bench, nf)
-import Data.List (foldl')
-import qualified Data.Map as M
-import qualified LookupGE_Map as M
-import Data.Maybe (fromMaybe)
-import Prelude hiding (lookup)
-
-main :: IO ()
-main = do
- evaluate $ rnf [m_even, m_odd, m_large]
- defaultMain [b f | b <- benches, f <- funs1]
- where
- m_even = M.fromAscList elems_even :: M.Map Int Int
- m_odd = M.fromAscList elems_odd :: M.Map Int Int
- m_large = M.fromAscList elems_large :: M.Map Int Int
- bound = 2^10
- elems_even = zip evens evens
- elems_odd = zip odds odds
- elems_large = zip large large
- evens = [2,4..bound]
- odds = [1,3..bound]
- large = [1,100..50*bound]
- benches =
- [ \(n,fun) -> bench (n++" present") $ nf (fge fun evens) m_even
- , \(n,fun) -> bench (n++" absent") $ nf (fge fun evens) m_odd
- , \(n,fun) -> bench (n++" far") $ nf (fge fun odds) m_large
- , \(n,fun) -> bench (n++" !present") $ nf (fge2 fun evens) m_even
- , \(n,fun) -> bench (n++" !absent") $ nf (fge2 fun evens) m_odd
- , \(n,fun) -> bench (n++" !far") $ nf (fge2 fun odds) m_large
- ]
- funs1 = [ ("GE split", M.lookupGE1)
- , ("GE caseof", M.lookupGE2)
- , ("GE Twan", M.lookupGE3)
- , ("GE Milan", M.lookupGE4) ]
-
-fge :: (Int -> M.Map Int Int -> Maybe (Int,Int)) -> [Int] -> M.Map Int Int -> (Int,Int)
-fge fun xs m = foldl' (\n k -> fromMaybe n (fun k m)) (0,0) xs
-
--- forcing values inside tuples!
-fge2 :: (Int -> M.Map Int Int -> Maybe (Int,Int)) -> [Int] -> M.Map Int Int -> (Int,Int)
-fge2 fun xs m = foldl' (\n@(!_, !_) k -> fromMaybe n (fun k m)) (0,0) xs
diff --git a/benchmarks/Makefile b/benchmarks/Makefile
deleted file mode 100644
index f6a8909..0000000
--- a/benchmarks/Makefile
+++ /dev/null
@@ -1,18 +0,0 @@
-all:
-
-bench-%: %.hs force
- ghc -O2 -DTESTING $< -I$(TOP)../include -i$(TOP).. -o $@ -outputdir tmp -rtsopts
-
-.PRECIOUS: bench-%
-
-bench-%.csv: bench-%
- ./bench-$* "$(BENCHMARK)" -v1 --csv bench-$*.csv
-
-.PHONY: force clean veryclean
-force:
-
-clean:
- rm -rf tmp $(patsubst %.hs, bench-%, $(wildcard *.hs))
-
-veryclean: clean
- rm -rf *.csv
diff --git a/benchmarks/Map.hs b/benchmarks/Map.hs
deleted file mode 100644
index 731995f..0000000
--- a/benchmarks/Map.hs
+++ /dev/null
@@ -1,197 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-module Main where
-
-import Control.Applicative (Const(Const, getConst), pure)
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Criterion.Main (bench, defaultMain, whnf, nf)
-import Data.Functor.Identity (Identity(..))
-import Data.List (foldl')
-import qualified Data.Map as M
-import qualified Data.Map.Strict as MS
-import Data.Map (alterF)
-import Data.Maybe (fromMaybe)
-import Data.Functor ((<$))
-#if __GLASGOW_HASKELL__ >= 708
-import Data.Coerce
-#endif
-import Prelude hiding (lookup)
-
-main = do
- let m = M.fromAscList elems :: M.Map Int Int
- m_even = M.fromAscList elems_even :: M.Map Int Int
- m_odd = M.fromAscList elems_odd :: M.Map Int Int
- evaluate $ rnf [m, m_even, m_odd]
- defaultMain
- [ bench "lookup absent" $ whnf (lookup evens) m_odd
- , bench "lookup present" $ whnf (lookup evens) m_even
- , bench "map" $ whnf (M.map (+ 1)) m
- , bench "map really" $ nf (M.map (+ 2)) m
- , bench "<$" $ whnf ((1 :: Int) <$) m
- , bench "<$ really" $ nf ((2 :: Int) <$) m
- , bench "alterF lookup absent" $ whnf (atLookup evens) m_odd
- , bench "alterF lookup present" $ whnf (atLookup evens) m_even
- , bench "alterF no rules lookup absent" $ whnf (atLookupNoRules evens) m_odd
- , bench "alterF no rules lookup present" $ whnf (atLookupNoRules evens) m_even
- , bench "insert absent" $ whnf (ins elems_even) m_odd
- , bench "insert present" $ whnf (ins elems_even) m_even
- , bench "alterF insert absent" $ whnf (atIns elems_even) m_odd
- , bench "alterF insert present" $ whnf (atIns elems_even) m_even
- , bench "alterF no rules insert absent" $ whnf (atInsNoRules elems_even) m_odd
- , bench "alterF no rules insert present" $ whnf (atInsNoRules elems_even) m_even
- , bench "delete absent" $ whnf (del evens) m_odd
- , bench "delete present" $ whnf (del evens) m
- , bench "alterF delete absent" $ whnf (atDel evens) m_odd
- , bench "alterF delete present" $ whnf (atDel evens) m
- , bench "alterF no rules delete absent" $ whnf (atDelNoRules evens) m_odd
- , bench "alterF no rules delete present" $ whnf (atDelNoRules evens) m
- , bench "alter absent" $ whnf (alt id evens) m_odd
- , bench "alter insert" $ whnf (alt (const (Just 1)) evens) m_odd
- , bench "alter update" $ whnf (alt id evens) m_even
- , bench "alter delete" $ whnf (alt (const Nothing) evens) m
- , bench "alterF alter absent" $ whnf (atAlt id evens) m_odd
- , bench "alterF alter insert" $ whnf (atAlt (const (Just 1)) evens) m_odd
- , bench "alterF alter update" $ whnf (atAlt id evens) m_even
- , bench "alterF alter delete" $ whnf (atAlt (const Nothing) evens) m
- , bench "alterF no rules alter absent" $ whnf (atAltNoRules id evens) m_odd
- , bench "alterF no rules alter insert" $ whnf (atAltNoRules (const (Just 1)) evens) m_odd
- , bench "alterF no rules alter update" $ whnf (atAltNoRules id evens) m_even
- , bench "alterF no rules alter delete" $ whnf (atAltNoRules (const Nothing) evens) m
- , bench "insertWith absent" $ whnf (insWith elems_even) m_odd
- , bench "insertWith present" $ whnf (insWith elems_even) m_even
- , bench "insertWith' absent" $ whnf (insWith' elems_even) m_odd
- , bench "insertWith' present" $ whnf (insWith' elems_even) m_even
- , bench "insertWithKey absent" $ whnf (insWithKey elems_even) m_odd
- , bench "insertWithKey present" $ whnf (insWithKey elems_even) m_even
- , bench "insertWithKey' absent" $ whnf (insWithKey' elems_even) m_odd
- , bench "insertWithKey' present" $ whnf (insWithKey' elems_even) m_even
- , bench "insertLookupWithKey absent" $ whnf (insLookupWithKey elems_even) m_odd
- , bench "insertLookupWithKey present" $ whnf (insLookupWithKey elems_even) m_even
- , bench "insertLookupWithKey' absent" $ whnf (insLookupWithKey' elems_even) m_odd
- , bench "insertLookupWithKey' present" $ whnf (insLookupWithKey' elems_even) m_even
- , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m
- , bench "foldlWithKey" $ whnf (ins elems) m
--- , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m
- , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m
- , bench "update absent" $ whnf (upd Just evens) m_odd
- , bench "update present" $ whnf (upd Just evens) m_even
- , bench "update delete" $ whnf (upd (const Nothing) evens) m
- , bench "updateLookupWithKey absent" $ whnf (upd' Just evens) m_odd
- , bench "updateLookupWithKey present" $ whnf (upd' Just evens) m_even
- , bench "updateLookupWithKey delete" $ whnf (upd' (const Nothing) evens) m
- , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m
- , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m
- , bench "lookupIndex" $ whnf (lookupIndex keys) m
- , bench "union" $ whnf (M.union m_even) m_odd
- , bench "difference" $ whnf (M.difference m) m_even
- , bench "intersection" $ whnf (M.intersection m) m_even
- , bench "split" $ whnf (M.split (bound `div` 2)) m
- , bench "fromList" $ whnf M.fromList elems
- , bench "fromList-desc" $ whnf M.fromList (reverse elems)
- , bench "fromAscList" $ whnf M.fromAscList elems
- , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems
- , 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])
- ]
- where
- bound = 2^12
- elems = zip keys values
- elems_even = zip evens evens
- elems_odd = zip odds odds
- keys = [1..bound]
- evens = [2,4..bound]
- odds = [1,3..bound]
- values = [1..bound]
- sum k v1 v2 = k + v1 + v2
- consPair k v xs = (k, v) : xs
-
-add3 :: Int -> Int -> Int -> Int
-add3 x y z = x + y + z
-{-# INLINE add3 #-}
-
-lookup :: [Int] -> M.Map Int Int -> Int
-lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs
-
-atLookup :: [Int] -> M.Map Int Int -> Int
-atLookup xs m = foldl' (\n k -> fromMaybe n (getConst (alterF Const k m))) 0 xs
-
-newtype Consty a b = Consty { getConsty :: a }
-instance Functor (Consty a) where
- fmap _ (Consty a) = Consty a
-
-atLookupNoRules :: [Int] -> M.Map Int Int -> Int
-atLookupNoRules xs m = foldl' (\n k -> fromMaybe n (getConsty (alterF Consty k m))) 0 xs
-
-lookupIndex :: [Int] -> M.Map Int Int -> Int
-lookupIndex xs m = foldl' (\n k -> fromMaybe n (M.lookupIndex k m)) 0 xs
-
-ins :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs
-
-atIns :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-atIns xs m = foldl' (\m (k, v) -> runIdentity (alterF (\_ -> Identity (Just v)) k m)) m xs
-
-newtype Ident a = Ident { runIdent :: a }
-instance Functor Ident where
-#if __GLASGOW_HASKELL__ >= 708
- fmap = coerce
-#else
- fmap f (Ident a) = Ident (f a)
-#endif
-
-atInsNoRules :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-atInsNoRules xs m = foldl' (\m (k, v) -> runIdent (alterF (\_ -> Ident (Just v)) k m)) m xs
-
-insWith :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs
-
-insWithKey :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs
-
-insWith' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-insWith' xs m = foldl' (\m (k, v) -> MS.insertWith (+) k v m) m xs
-
-insWithKey' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-insWithKey' xs m = foldl' (\m (k, v) -> MS.insertWithKey add3 k v m) m xs
-
-data PairS a b = PS !a !b
-
-insLookupWithKey :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)
-insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
- where
- f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m
- in PS (fromMaybe 0 n' + n) m'
-
-insLookupWithKey' :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)
-insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
- where
- f (PS n m) (k, v) = let !(n', m') = MS.insertLookupWithKey add3 k v m
- in PS (fromMaybe 0 n' + n) m'
-
-del :: [Int] -> M.Map Int Int -> M.Map Int Int
-del xs m = foldl' (\m k -> M.delete k m) m xs
-
-atDel :: [Int] -> M.Map Int Int -> M.Map Int Int
-atDel xs m = foldl' (\m k -> runIdentity (alterF (\_ -> Identity Nothing) k m)) m xs
-
-atDelNoRules :: [Int] -> M.Map Int Int -> M.Map Int Int
-atDelNoRules xs m = foldl' (\m k -> runIdent (alterF (\_ -> Ident Nothing) k m)) m xs
-
-upd :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
-upd f xs m = foldl' (\m k -> M.update f k m) m xs
-
-upd' :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
-upd' f xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> f a) k m) m xs
-
-alt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
-alt f xs m = foldl' (\m k -> M.alter f k m) m xs
-
-atAlt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
-atAlt f xs m = foldl' (\m k -> runIdentity (alterF (Identity . f) k m)) m xs
-
-atAltNoRules :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
-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
diff --git a/benchmarks/Sequence.hs b/benchmarks/Sequence.hs
deleted file mode 100644
index 50ac9fd..0000000
--- a/benchmarks/Sequence.hs
+++ /dev/null
@@ -1,244 +0,0 @@
-module Main where
-
-import Control.Applicative
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Control.Monad.Trans.State.Strict
-import Criterion.Main (bench, bgroup, defaultMain, nf)
-import Data.Foldable (foldl', foldr')
-import qualified Data.Sequence as S
-import qualified Data.Foldable
-import Data.Traversable (traverse)
-import System.Random (mkStdGen, randoms)
-
-main = do
- let s10 = S.fromList [1..10] :: S.Seq Int
- s100 = S.fromList [1..100] :: S.Seq Int
- s1000 = S.fromList [1..1000] :: S.Seq Int
- s10000 = S.fromList [1..10000] :: S.Seq Int
- evaluate $ rnf [s10, s100, s1000, s10000]
- let g = mkStdGen 1
- let rlist n = map (`mod` (n+1)) (take 10000 (randoms g)) :: [Int]
- r10 = rlist 10
- r100 = rlist 100
- r1000 = rlist 1000
- r10000 = rlist 10000
- evaluate $ rnf [r10, r100, r1000, r10000]
- let rs10 = S.fromList r10
- rs100 = S.fromList r100
- rs1000 = S.fromList r1000
- rs10000 = S.fromList r10000
- evaluate $ rnf [rs10, rs100, rs1000, rs10000]
- let u10 = S.replicate 10 () :: S.Seq ()
- u100 = S.replicate 100 () :: S.Seq ()
- u1000 = S.replicate 1000 () :: S.Seq ()
- u10000 = S.replicate 10000 () :: S.Seq ()
- evaluate $ rnf [u10, u100, u1000, u10000]
- defaultMain
- [ bgroup "splitAt/append"
- [ bench "10" $ nf (shuffle r10) s10
- , bench "100" $ nf (shuffle r100) s100
- , bench "1000" $ nf (shuffle r1000) s1000
- ]
- , bgroup "fromList"
- [ bench "10" $ nf S.fromList [(0 :: Int)..9]
- , bench "100" $ nf S.fromList [(0 :: Int)..99]
- , bench "1000" $ nf S.fromList [(0 :: Int)..999]
- , bench "10000" $ nf S.fromList [(0 :: Int)..9999]
- , bench "100000" $ nf S.fromList [(0 :: Int)..99999]
- ]
- , bgroup "partition"
- [ bench "10" $ nf (S.partition even) s10
- , bench "100" $ nf (S.partition even) s100
- , bench "1000" $ nf (S.partition even) s1000
- , bench "10000" $ nf (S.partition even) s10000
- ]
- , bgroup "foldl'"
- [ bench "10" $ nf (foldl' (+) 0) s10
- , bench "100" $ nf (foldl' (+) 0) s100
- , bench "1000" $ nf (foldl' (+) 0) s1000
- , bench "10000" $ nf (foldl' (+) 0) s10000
- ]
- , bgroup "foldr'"
- [ bench "10" $ nf (foldr' (+) 0) s10
- , bench "100" $ nf (foldr' (+) 0) s100
- , bench "1000" $ nf (foldr' (+) 0) s1000
- , bench "10000" $ nf (foldr' (+) 0) s10000
- ]
- , bgroup "update"
- [ bench "10" $ nf (updatePoints r10 10) s10
- , bench "100" $ nf (updatePoints r100 10) s100
- , bench "1000" $ nf (updatePoints r1000 10) s1000
- ]
- , bgroup "adjust"
- [ bench "10" $ nf (adjustPoints r10 (+10)) s10
- , bench "100" $ nf (adjustPoints r100 (+10)) s100
- , bench "1000" $ nf (adjustPoints r1000 (+10)) s1000
- ]
- , bgroup "deleteAt"
- [ bench "10" $ nf (deleteAtPoints r10) s10
- , bench "100" $ nf (deleteAtPoints r100) s100
- , bench "1000" $ nf (deleteAtPoints r1000) s1000
- ]
- , bgroup "insertAt"
- [ bench "10" $ nf (insertAtPoints r10 10) s10
- , bench "100" $ nf (insertAtPoints r100 10) s100
- , bench "1000" $ nf (insertAtPoints r1000 10) s1000
- ]
- , bgroup "traverseWithIndex/State"
- [ bench "10" $ nf multiplyDown s10
- , bench "100" $ nf multiplyDown s100
- , bench "1000" $ nf multiplyDown s1000
- ]
- , bgroup "traverse/State"
- [ bench "10" $ nf multiplyUp s10
- , bench "100" $ nf multiplyUp s100
- , bench "1000" $ nf multiplyUp s1000
- ]
- , bgroup "replicateA/State"
- [ bench "10" $ nf stateReplicate 10
- , bench "100" $ nf stateReplicate 100
- , bench "1000" $ nf stateReplicate 1000
- ]
- , bgroup "zip"
- [ bench "ix10000/5000" $ nf (\(xs,ys) -> S.zip xs ys `S.index` 5000) (s10000, u10000)
- , bench "nf100" $ nf (uncurry S.zip) (s100, u100)
- , bench "nf10000" $ nf (uncurry S.zip) (s10000, u10000)
- ]
- , bgroup "fromFunction"
- [ bench "ix10000/5000" $ nf (\s -> S.fromFunction s (+1) `S.index` (s `div` 2)) 10000
- , bench "nf10" $ nf (\s -> S.fromFunction s (+1)) 10
- , bench "nf100" $ nf (\s -> S.fromFunction s (+1)) 100
- , bench "nf1000" $ nf (\s -> S.fromFunction s (+1)) 1000
- , bench "nf10000" $ nf (\s -> S.fromFunction s (+1)) 10000
- ]
- , bgroup "<*>"
- [ bench "ix500/1000^2" $
- nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s `div` 2)) (S.fromFunction 1000 (+1))
- , bench "ix500000/1000^2" $
- nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2)) (S.fromFunction 1000 (+1))
- , bench "ixBIG" $
- nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2))
- (S.fromFunction (floor (sqrt $ fromIntegral (maxBound::Int))-10) (+1))
- , bench "nf100/2500/rep" $
- nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500)
- , bench "nf100/2500/ff" $
- nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (100,2500)
- , bench "nf500/500/rep" $
- nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (500,500)
- , bench "nf500/500/ff" $
- nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (500,500)
- , bench "nf2500/100/rep" $
- nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (2500,100)
- , bench "nf2500/100/ff" $
- nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (2500,100)
- ]
- , bgroup "sort"
- [ bgroup "already sorted"
- [ bench "10" $ nf S.sort s10
- , bench "100" $ nf S.sort s100
- , bench "1000" $ nf S.sort s1000
- , bench "10000" $ nf S.sort s10000]
- , bgroup "random"
- [ bench "10" $ nf S.sort rs10
- , bench "100" $ nf S.sort rs100
- , bench "1000" $ nf S.sort rs1000
- , bench "10000" $ nf S.sort rs10000]
- ]
- , bgroup "unstableSort"
- [ bgroup "already sorted"
- [ bench "10" $ nf S.unstableSort s10
- , bench "100" $ nf S.unstableSort s100
- , bench "1000" $ nf S.unstableSort s1000
- , bench "10000" $ nf S.unstableSort s10000]
- , bgroup "random"
- [ bench "10" $ nf S.unstableSort rs10
- , bench "100" $ nf S.unstableSort rs100
- , bench "1000" $ nf S.unstableSort rs1000
- , bench "10000" $ nf S.unstableSort rs10000]
- ]
- , bgroup "unstableSortOn"
- [ bgroup "already sorted"
- [ bench "10" $ nf (S.unstableSortOn id) s10
- , bench "100" $ nf (S.unstableSortOn id) s100
- , bench "1000" $ nf (S.unstableSortOn id) s1000
- , bench "10000" $ nf (S.unstableSortOn id) s10000]
- , bgroup "random"
- [ bench "10" $ nf (S.unstableSortOn id) rs10
- , bench "100" $ nf (S.unstableSortOn id) rs100
- , bench "1000" $ nf (S.unstableSortOn id) rs1000
- , bench "10000" $ nf (S.unstableSortOn id) rs10000]
- ]
- ]
-
-{-
--- This is around 4.6 times as slow as insertAt
-fakeInsertAt :: Int -> a -> S.Seq a -> S.Seq a
-fakeInsertAt i x xs = case S.splitAt i xs of
- (before, after) -> before S.>< x S.<| after
--}
-
-adjustPoints :: [Int] -> (a -> a) -> S.Seq a -> S.Seq a
-adjustPoints points f xs =
- foldl' (\acc k -> S.adjust f k acc) xs points
-
-insertAtPoints :: [Int] -> a -> S.Seq a -> S.Seq a
-insertAtPoints points x xs =
- foldl' (\acc k -> S.insertAt k x acc) xs points
-
-updatePoints :: [Int] -> a -> S.Seq a -> S.Seq a
-updatePoints points x xs =
- foldl' (\acc k -> S.update k x acc) xs points
-
-{-
--- For comparison. Using the old implementation of update,
--- which this simulates, can cause thunks to build up in the leaves.
-fakeupdatePoints :: [Int] -> a -> S.Seq a -> S.Seq a
-fakeupdatePoints points x xs =
- foldl' (\acc k -> S.adjust (const x) k acc) xs points
--}
-
-deleteAtPoints :: [Int] -> S.Seq a -> S.Seq a
-deleteAtPoints points xs =
- foldl' (\acc k -> S.deleteAt k acc) xs points
-
-{-
-fakedeleteAtPoints :: [Int] -> S.Seq a -> S.Seq a
-fakedeleteAtPoints points xs =
- foldl' (\acc k -> fakeDeleteAt k acc) xs points
--- For comparison with deleteAt. deleteAt is several
--- times faster for long sequences.
-fakeDeleteAt :: Int -> S.Seq a -> S.Seq a
-fakeDeleteAt i xs
- | 0 < i && i < S.length xs = case S.splitAt i xs of
- (before, after) -> before S.>< S.drop 1 after
- | otherwise = xs
--}
-
--- splitAt+append: repeatedly cut the sequence at a random point
--- and rejoin the pieces in the opposite order.
--- Finally getting the middle element forces the whole spine.
-shuffle :: [Int] -> S.Seq Int -> Int
-shuffle ps s = case S.viewl (S.drop (S.length s `div` 2) (foldl' cut s ps)) of
- x S.:< _ -> x
- where cut xs p = let (front, back) = S.splitAt p xs in back S.>< front
-
-stateReplicate :: Int -> S.Seq Char
-stateReplicate n = flip evalState 0 . S.replicateA n $ do
- old <- get
- if old > (10 :: Int) then put 0 else put (old + 1)
- return $ toEnum old
-
-multiplyUp :: S.Seq Int -> S.Seq Int
-multiplyUp = flip evalState 0 . traverse go where
- go x = do
- s <- get
- put (s + 1)
- return (s * x)
-
-multiplyDown :: S.Seq Int -> S.Seq Int
-multiplyDown = flip evalState 0 . S.traverseWithIndex go where
- go i x = do
- s <- get
- put (s - 1)
- return (s * i * x)
diff --git a/benchmarks/Set.hs b/benchmarks/Set.hs
deleted file mode 100644
index d0086b9..0000000
--- a/benchmarks/Set.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Main where
-
-import Control.DeepSeq (rnf)
-import Control.Exception (evaluate)
-import Criterion.Main (bench, defaultMain, whnf)
-import Data.List (foldl')
-import qualified Data.Set as S
-
-main = do
- let s = S.fromAscList elems :: S.Set Int
- s_even = S.fromAscList elems_even :: S.Set Int
- s_odd = S.fromAscList elems_odd :: S.Set Int
- evaluate $ rnf [s, s_even, s_odd]
- defaultMain
- [ bench "member" $ whnf (member elems) s
- , bench "insert" $ whnf (ins elems) S.empty
- , bench "map" $ whnf (S.map (+ 1)) s
- , bench "filter" $ whnf (S.filter ((== 0) . (`mod` 2))) s
- , bench "partition" $ whnf (S.partition ((== 0) . (`mod` 2))) s
- , bench "fold" $ whnf (S.fold (:) []) s
- , bench "delete" $ whnf (del elems) s
- , bench "findMin" $ whnf S.findMin s
- , bench "findMax" $ whnf S.findMax s
- , bench "deleteMin" $ whnf S.deleteMin s
- , bench "deleteMax" $ whnf S.deleteMax s
- , bench "unions" $ whnf S.unions [s_even, s_odd]
- , bench "union" $ whnf (S.union s_even) s_odd
- , bench "difference" $ whnf (S.difference s) s_even
- , bench "intersection" $ whnf (S.intersection s) s_even
- , bench "fromList" $ whnf S.fromList elems
- , bench "fromList-desc" $ whnf S.fromList (reverse elems)
- , bench "fromAscList" $ whnf S.fromAscList elems
- , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems
- , bench "disjoint:false" $ whnf (S.disjoint s) s_even
- , bench "disjoint:true" $ whnf (S.disjoint s_odd) s_even
- , bench "null.intersection:false" $ whnf (S.null. S.intersection s) s_even
- , bench "null.intersection:true" $ whnf (S.null. S.intersection s_odd) s_even
- ]
- where
- elems = [1..2^12]
- elems_even = [2,4..2^12]
- elems_odd = [1,3..2^12]
-
-member :: [Int] -> S.Set Int -> Int
-member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs
-
-ins :: [Int] -> S.Set Int -> S.Set Int
-ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs
-
-del :: [Int] -> S.Set Int -> S.Set Int
-del xs s0 = foldl' (\s k -> S.delete k s) s0 xs
diff --git a/benchmarks/SetOperations/Makefile b/benchmarks/SetOperations/Makefile
deleted file mode 100644
index e662979..0000000
--- a/benchmarks/SetOperations/Makefile
+++ /dev/null
@@ -1,3 +0,0 @@
-TOP = ../
-
-include ../Makefile
diff --git a/benchmarks/SetOperations/SetOperations-IntMap.hs b/benchmarks/SetOperations/SetOperations-IntMap.hs
deleted file mode 100644
index 036c82c..0000000
--- a/benchmarks/SetOperations/SetOperations-IntMap.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main where
-
-import Data.IntMap as C
-import SetOperations
-
-main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
diff --git a/benchmarks/SetOperations/SetOperations-IntSet.hs b/benchmarks/SetOperations/SetOperations-IntSet.hs
deleted file mode 100644
index 3b116c7..0000000
--- a/benchmarks/SetOperations/SetOperations-IntSet.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main where
-
-import Data.IntSet as C
-import SetOperations
-
-main = benchmark fromList True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
diff --git a/benchmarks/SetOperations/SetOperations-Map.hs b/benchmarks/SetOperations/SetOperations-Map.hs
deleted file mode 100644
index 7d08e3c..0000000
--- a/benchmarks/SetOperations/SetOperations-Map.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main where
-
-import Data.Map as C
-import SetOperations
-
-main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
diff --git a/benchmarks/SetOperations/SetOperations-Set.hs b/benchmarks/SetOperations/SetOperations-Set.hs
deleted file mode 100644
index bd1a0c9..0000000
--- a/benchmarks/SetOperations/SetOperations-Set.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main where
-
-import Data.Set as C
-import SetOperations
-
-main = benchmark fromList True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
diff --git a/benchmarks/SetOperations/SetOperations.hs b/benchmarks/SetOperations/SetOperations.hs
deleted file mode 100644
index dec6a87..0000000
--- a/benchmarks/SetOperations/SetOperations.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module SetOperations (benchmark) where
-
-import Criterion.Main (bench, defaultMain, whnf)
-import Data.List (partition)
-
-benchmark :: ([Int] -> container) -> Bool -> [(String, container -> container -> container)] -> IO ()
-benchmark fromList swap methods = do
- defaultMain $ [ bench (method_str++"-"++input_str) $ whnf (method input1) input2 | (method_str, method) <- methods, (input_str, input1, input2) <- inputs ]
-
- where
- n, s, t :: Int
- n = 100000
- s {-small-} = n `div` 10
- t {-tiny-} = round $ sqrt $ fromIntegral n
-
- inputs = [ (mode_str, left, right)
- | (mode_str, (left, right)) <- [ ("disj_nn", disj_nn), ("disj_ns", disj_ns), ("disj_nt", disj_nt)
- , ("common_nn", common_nn), ("common_ns", common_ns), ("common_nt", common_nt)
- , ("mix_nn", mix_nn), ("mix_ns", mix_ns), ("mix_nt", mix_nt)
- , ("block_nn", block_nn), ("block_ns", block_ns)
- ]
-
- , (mode_str, left, right) <- replicate 2 (mode_str, left, right) ++
- replicate (if swap && take 4 mode_str /= "diff" && last mode_str /= last (init mode_str) then 2 else 0)
- (init (init mode_str) ++ [last mode_str] ++ [last (init mode_str)], right, left)
- ]
-
- all_n = fromList [1..n]
-
- !disj_nn = seqPair $ (all_n, fromList [n+1..n+n])
- !disj_ns = seqPair $ (all_n, fromList [n+1..n+s])
- !disj_nt = seqPair $ (all_n, fromList [n+1..n+t])
- !common_nn = seqPair $ (all_n, fromList [2,4..n])
- !common_ns = seqPair $ (all_n, fromList [0,1+n`div`s..n])
- !common_nt = seqPair $ (all_n, fromList [0,1+n`div`t..n])
- !mix_nn = seqPair $ fromLists $ partition ((/= 0) . (`mod` 2)) [1..n+n]
- !mix_ns = seqPair $ fromLists $ partition ((/= 0) . (`mod` (1 + n`div`s))) [1..s+n]
- !mix_nt = seqPair $ fromLists $ partition ((/= 0) . (`mod` (1 + n`div`t))) [1..t+n]
- !block_nn = seqPair $ fromLists $ partition ((>= t) . (`mod` (t * 2))) [1..n+n]
- !block_ns = seqPair $ fromLists $ partition ((>= t) . (`mod` (t * (1 + n`div`s)))) [1..s+n]
-
- fromLists (xs, ys) = (fromList xs, fromList ys)
- seqPair pair@(xs, ys) = xs `seq` ys `seq` pair
diff --git a/benchmarks/bench-cmp.pl b/benchmarks/bench-cmp.pl
deleted file mode 100755
index b1864c7..0000000
--- a/benchmarks/bench-cmp.pl
+++ /dev/null
@@ -1,24 +0,0 @@
-#!/usr/bin/perl
-use warnings;
-use strict;
-
-@ARGV >= 2 or die "Usage: bench-cmp.pl csv_file_1 csv_file_2";
-open (my $f1, "<", $ARGV[0]) or die "Cannot open file $ARGV[0]";
-open (my $f2, "<", $ARGV[1]) or die "Cannot open file $ARGV[1]";
-
-my $l1 = <$f1>;
-my $l2 = <$f2>;
-$l1 eq $l2 or die "CSV files do not correspond -- $l1 and $l2";
-
-while (defined($l1 = <$f1>)) {
- $l2 = <$f2>;
-
- my @parts1 = split /,/, $l1;
- my @parts2 = split /,/, $l2;
-
- $parts1[0] eq $parts2[0] or die "CSV files do not correspond -- $parts1[0] and $parts2[0]";
- printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $parts2[1] / $parts1[1] - 100, $parts1[1];
-}
-
-close $f2;
-close $f1;
diff --git a/benchmarks/bench-cmp.sh b/benchmarks/bench-cmp.sh
deleted file mode 100755
index b72d0d0..0000000
--- a/benchmarks/bench-cmp.sh
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/bin/sh
-
-(echo 'Benchmark;Runtime change;Original runtime'; ./bench-cmp.pl "$@") | column -ts\;
diff --git a/changelog.md b/changelog.md
index 751b75a..6c4115f 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,40 @@
# Changelog for [`containers` package](http://github.com/haskell/containers)
+## 0.6.1.1
+
+* Fix Foldable instance for IntMap, which previously placed positively
+ keyed entries before negatively keyed ones for `fold`, `foldMap`, and
+ `traverse`.
+
+* Make strict `IntMap` merges strict.
+
+* Make `Data.IntMap.Merge.Strict` tactics (except `preserveMissing`)
+ strict.
+
+* Add a strict `Data.Map.Merge.Strict.preserveMissing'` tactic.
+
+* Make `stimes` for sequences work with 0 arguments, and make it more
+ efficient.
+
+* Speed up `cartesianProduct` for `Data.Set`.
+
+* Speed up `Data.Set.isSubsetOf`, `Data.Map.isSubmapOf`, and `Data.Set.disjoint`.
+
+* Allow inlining for `Data.Sequence.traverseWithIndex`, making it faster
+ than `sequence` combined with `mapWithIndex`.
+
+* Produce more concise assembly from `maskW`. (Thanks, Mateusz Kowalczyk)
+
+* Use `countLeadingZeros` to implement `highestBitMask` (Thanks, Dmitry
+ Ivanov)
+
+* Improve documentation. (Thanks to jwaldmann, Yuji Yamamoto, David Sanders,
+ Alec Theriault, Vaibhav Sagar, Boro Sitnikovski, Morten Kolstad, Vados,
+ Benjamin Web, Chris Martin, Alexandre Esteves).
+
+* Clean up packaging and testing. (Thanks, David Eichmann, Simon Jakobi,
+ Oleg Grenrus, Andreas Klebinger)
+
## 0.6.0.1
* Released with GHC 8.6
diff --git a/containers.cabal b/containers.cabal
index 0adb9a1..7e903e1 100644
--- a/containers.cabal
+++ b/containers.cabal
@@ -1,5 +1,5 @@
name: containers
-version: 0.6.0.1
+version: 0.6.1.1
license: BSD3
license-file: LICENSE
maintainer: libraries@haskell.org
@@ -23,27 +23,17 @@ build-type: Simple
cabal-version: >=1.8
extra-source-files:
include/containers.h
- tests/Makefile
- tests/*.hs
- benchmarks/Makefile
- benchmarks/bench-cmp.pl
- benchmarks/bench-cmp.sh
- benchmarks/*.hs
- benchmarks/SetOperations/Makefile
- benchmarks/SetOperations/*.hs
- benchmarks/LookupGE/Makefile
- benchmarks/LookupGE/*.hs
changelog.md
+tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3
+
source-repository head
type: git
location: http://github.com/haskell/containers.git
Library
build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5
- if impl(ghc)
- build-depends: ghc-prim
-
+ hs-source-dirs: src
ghc-options: -O2 -Wall
other-extensions: CPP, BangPatterns
@@ -53,6 +43,7 @@ Library
Data.IntMap
Data.IntMap.Lazy
Data.IntMap.Strict
+ Data.IntMap.Strict.Internal
Data.IntMap.Internal
Data.IntMap.Internal.Debug
Data.IntMap.Merge.Lazy
@@ -90,507 +81,3 @@ Library
Data.IntMap.Internal.DeprecatedDebug
include-dirs: include
-
------------------------------
--- B E N C H M A R K I N G --
------------------------------
-
-benchmark intmap-benchmarks
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks
- main-is: IntMap.hs
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5
-
-benchmark intset-benchmarks
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks
- main-is: IntSet.hs
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5
-
-benchmark map-benchmarks
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks
- main-is: Map.hs
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5,
- transformers
-
-benchmark sequence-benchmarks
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks
- main-is: Sequence.hs
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5,
- random < 1.2,
- transformers
-
-benchmark set-benchmarks
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks
- main-is: Set.hs
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5
-
-benchmark set-operations-intmap
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks/SetOperations
- main-is: SetOperations-IntMap.hs
- other-modules: SetOperations
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3
-
-benchmark set-operations-intset
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks/SetOperations
- main-is: SetOperations-IntSet.hs
- other-modules: SetOperations
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3
-
-benchmark set-operations-map
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks/SetOperations
- main-is: SetOperations-Map.hs
- other-modules: SetOperations
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3
-
-benchmark set-operations-set
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks/SetOperations
- main-is: SetOperations-Set.hs
- other-modules: SetOperations
- ghc-options: -O2
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3
-
-benchmark lookupge-intmap
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks/LookupGE, .
- main-is: IntMap.hs
- other-modules:
- Data.IntMap
- Data.IntMap.Internal.DeprecatedDebug
- Data.IntMap.Lazy
- Data.IntMap.Strict
- Data.IntSet.Internal
- LookupGE_IntMap
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.StrictPair
- Utils.Containers.Internal.TypeError
- ghc-options: -O2
- cpp-options: -DTESTING
- other-modules:
- Data.IntMap.Internal
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5,
- ghc-prim
-
-benchmark lookupge-map
- type: exitcode-stdio-1.0
- hs-source-dirs: benchmarks/LookupGE, .
- main-is: Map.hs
- other-modules:
- Data.Map
- Data.Map.Internal.Debug
- Data.Map.Internal.DeprecatedShowTree
- Data.Map.Lazy
- Data.Map.Strict
- Data.Map.Strict.Internal
- Data.Set.Internal
- LookupGE_Map
- Utils.Containers.Internal.BitQueue
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.PtrEquality
- Utils.Containers.Internal.StrictMaybe
- Utils.Containers.Internal.StrictPair
- ghc-options: -O2
- cpp-options: -DTESTING
- other-modules:
- Data.Map.Internal
- build-depends:
- base >= 4.6 && < 5,
- containers,
- criterion >= 0.4.0 && < 1.3,
- deepseq >= 1.1.0.0 && < 1.5,
- ghc-prim
-
--------------------
--- T E S T I N G --
--------------------
-
--- Every test-suite contains the build-depends and options of the library,
--- plus the testing stuff.
-
-Test-suite map-lazy-properties
- hs-source-dirs: tests, .
- main-is: map-properties.hs
- other-modules:
- Data.Map.Internal
- Data.Map.Internal.Debug
- Data.Map.Internal.DeprecatedShowTree
- Data.Map.Lazy
- Data.Map.Merge.Lazy
- Data.Set
- Data.Set.Internal
- Utils.Containers.Internal.BitQueue
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.PtrEquality
- Utils.Containers.Internal.StrictMaybe
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- HUnit,
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2,
- transformers
-
-Test-suite map-strict-properties
- hs-source-dirs: tests, .
- main-is: map-properties.hs
- other-modules:
- Data.Map.Internal
- Data.Map.Internal.Debug
- Data.Map.Internal.DeprecatedShowTree
- Data.Map.Merge.Strict
- Data.Map.Strict
- Data.Map.Strict.Internal
- Data.Set
- Data.Set.Internal
- Utils.Containers.Internal.BitQueue
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.PtrEquality
- Utils.Containers.Internal.StrictMaybe
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING -DSTRICT
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- HUnit,
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2,
- transformers
-
-Test-suite bitqueue-properties
- hs-source-dirs: tests, .
- main-is: bitqueue-properties.hs
- other-modules:
- Utils.Containers.Internal.BitQueue
- Utils.Containers.Internal.BitUtil
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-quickcheck2
-
-Test-suite set-properties
- hs-source-dirs: tests, .
- main-is: set-properties.hs
- other-modules:
- Data.IntSet
- Data.IntSet.Internal
- Data.Set
- Data.Set.Internal
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.PtrEquality
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- HUnit,
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2,
- transformers
-
-Test-suite intmap-lazy-properties
- hs-source-dirs: tests, .
- main-is: intmap-properties.hs
- other-modules:
- Data.IntMap.Internal
- Data.IntMap.Internal.Debug
- Data.IntMap.Internal.DeprecatedDebug
- Data.IntMap.Lazy
- Data.IntSet
- Data.IntSet.Internal
- IntMapValidity
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.StrictPair
- Utils.Containers.Internal.TypeError
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- HUnit,
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2
-
-Test-suite intmap-strict-properties
- hs-source-dirs: tests, .
- main-is: intmap-properties.hs
- other-modules:
- Data.IntMap.Internal
- Data.IntMap.Internal.Debug
- Data.IntMap.Internal.DeprecatedDebug
- Data.IntMap.Strict
- Data.IntSet
- Data.IntSet.Internal
- IntMapValidity
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.StrictPair
- Utils.Containers.Internal.TypeError
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING -DSTRICT
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- HUnit,
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2
-
-Test-suite intset-properties
- hs-source-dirs: tests, .
- main-is: intset-properties.hs
- other-modules:
- Data.IntSet
- Data.IntSet.Internal
- Data.Set
- Data.Set.Internal
- IntSetValidity
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.PtrEquality
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- HUnit,
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2
-
-Test-suite seq-properties
- hs-source-dirs: tests, .
- main-is: seq-properties.hs
- other-modules:
- Data.Sequence
- Data.Sequence.Internal
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-quickcheck2,
- transformers
-
-Test-suite tree-properties
- hs-source-dirs: tests, .
- main-is: tree-properties.hs
- other-modules:
- Data.Tree
- type: exitcode-stdio-1.0
- cpp-options: -DTESTING
-
- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim
- ghc-options: -O2
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
- build-depends:
- QuickCheck >= 2.7.1,
- test-framework,
- test-framework-quickcheck2,
- transformers
-
-test-suite map-strictness-properties
- hs-source-dirs: tests, .
- main-is: map-strictness.hs
- other-modules:
- Data.Map.Internal
- Data.Map.Internal.Debug
- Data.Map.Internal.DeprecatedShowTree
- Data.Map.Strict
- Data.Map.Strict.Internal
- Data.Set.Internal
- Utils.Containers.Internal.BitQueue
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.PtrEquality
- Utils.Containers.Internal.StrictMaybe
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
-
- build-depends:
- array >= 0.4.0.0,
- base >= 4.6 && < 5,
- ChasingBottoms,
- deepseq >= 1.2 && < 1.5,
- QuickCheck >= 2.7.1,
- ghc-prim,
- test-framework >= 0.3.3,
- test-framework-quickcheck2 >= 0.2.9
-
- ghc-options: -Wall
- other-extensions: CPP, BangPatterns
- include-dirs: include
-
-test-suite intmap-strictness-properties
- hs-source-dirs: tests, .
- main-is: intmap-strictness.hs
- other-modules:
- Data.IntMap.Internal
- Data.IntMap.Internal.DeprecatedDebug
- Data.IntMap.Strict
- Data.IntSet.Internal
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.StrictPair
- Utils.Containers.Internal.TypeError
- type: exitcode-stdio-1.0
- other-extensions: CPP, BangPatterns
-
- build-depends:
- array >= 0.4.0.0,
- base >= 4.6 && < 5,
- ChasingBottoms,
- deepseq >= 1.2 && < 1.5,
- QuickCheck >= 2.7.1,
- ghc-prim,
- test-framework >= 0.3.3,
- test-framework-quickcheck2 >= 0.2.9
-
- ghc-options: -Wall
- include-dirs: include
-
-test-suite intset-strictness-properties
- hs-source-dirs: tests, .
- main-is: intset-strictness.hs
- other-modules:
- Data.IntSet
- Data.IntSet.Internal
- Utils.Containers.Internal.BitUtil
- Utils.Containers.Internal.StrictPair
- type: exitcode-stdio-1.0
- other-extensions: CPP, BangPatterns
-
- build-depends:
- array >= 0.4.0.0,
- base >= 4.6 && < 5,
- ChasingBottoms,
- deepseq >= 1.2 && < 1.5,
- QuickCheck >= 2.7.1,
- ghc-prim,
- test-framework >= 0.3.3,
- test-framework-quickcheck2 >= 0.2.9
-
- ghc-options: -Wall
- include-dirs: include
-
-test-suite listutils-properties
- hs-source-dirs: tests, .
- main-is: listutils-properties.hs
- other-modules:
- Data.Containers.ListUtils
- type: exitcode-stdio-1.0
-
- build-depends:
- base >= 4.6 && < 5,
- ChasingBottoms,
- deepseq >= 1.2 && < 1.5,
- QuickCheck >= 2.7.1,
- ghc-prim,
- test-framework >= 0.3.3,
- test-framework-quickcheck2 >= 0.2.9
-
- ghc-options: -Wall
- include-dirs: include
diff --git a/Data/Containers/ListUtils.hs b/src/Data/Containers/ListUtils.hs
index 419c4b0..9203c60 100644
--- a/Data/Containers/ListUtils.hs
+++ b/src/Data/Containers/ListUtils.hs
@@ -13,6 +13,10 @@
-- Portability : portable
--
-- This module provides efficient containers-based functions on the list type.
+--
+-- In the documentation, \(n\) is the number of elements in the list while
+-- \(d\) is the number of distinct elements in the list. \(W\) is the number
+-- of bits in an 'Int'.
-----------------------------------------------------------------------------
module Data.Containers.ListUtils (
@@ -33,10 +37,10 @@ import GHC.Exts ( build )
-- *** Ord-based nubbing ***
--- | \( O(n \log n \). The @nubOrd@ function removes duplicate elements from a list.
--- In particular, it keeps only the first occurrence of each element. By using a
--- 'Set' internally it has better asymptotics than the standard 'Data.List.nub'
--- function.
+-- | \( O(n \log d) \). The @nubOrd@ function removes duplicate elements from a
+-- list. In particular, it keeps only the first occurrence of each element. By
+-- using a 'Set' internally it has better asymptotics than the standard
+-- 'Data.List.nub' function.
--
-- ==== Strictness
--
@@ -44,8 +48,9 @@ import GHC.Exts ( build )
--
-- ==== Efficiency note
--
--- When applicable, it is almost always better to use 'nubInt' or 'nubIntOn' instead
--- of this function. For example, the best way to nub a list of characters is
+-- When applicable, it is almost always better to use 'nubInt' or 'nubIntOn'
+-- instead of this function, although it can be a little worse in certain
+-- pathological cases. For example, to nub a list of characters, use
--
-- @ nubIntOn fromEnum xs @
nubOrd :: Ord a => [a] -> [a]
@@ -114,7 +119,7 @@ constNubOn x _ = x
-- *** Int-based nubbing ***
--- | \( O(n \min(n,W)) \). The @nubInt@ function removes duplicate 'Int'
+-- | \( O(n \min(d,W)) \). The @nubInt@ function removes duplicate 'Int'
-- values from a list. In particular, it keeps only the first occurrence
-- of each element. By using an 'IntSet' internally, it attains better
-- asymptotics than the standard 'Data.List.nub' function.
@@ -130,7 +135,8 @@ nubInt = nubIntOn id
-- | The @nubIntOn@ function behaves just like 'nubInt' except it performs
-- comparisons not on the original datatype, but a user-specified projection
--- from that datatype.
+-- from that datatype. For example, @nubIntOn 'fromEnum'@ can be used to
+-- nub characters and typical fixed-with numerical types efficiently.
--
-- ==== Strictness
--
diff --git a/Data/Graph.hs b/src/Data/Graph.hs
index ac32473..8260980 100644
--- a/Data/Graph.hs
+++ b/src/Data/Graph.hs
@@ -36,7 +36,7 @@
-- The implementation is based on
--
-- * /Structuring Depth-First Search Algorithms in Haskell/,
--- by David King and John Launchbury.
+-- by David King and John Launchbury, <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.52.6526>
--
-----------------------------------------------------------------------------
@@ -124,6 +124,8 @@ import qualified Data.Array as UA
import Data.List
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
+#endif
+#if (!MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#endif
#ifdef __GLASGOW_HASKELL__
@@ -217,8 +219,13 @@ flattenSCC :: SCC vertex -> [vertex]
flattenSCC (AcyclicSCC v) = [v]
flattenSCC (CyclicSCC vs) = vs
--- | The strongly connected components of a directed graph, topologically
+-- | The strongly connected components of a directed graph, reverse topologically
-- sorted.
+--
+-- ==== __Examples__
+--
+-- > stronglyConnComp [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]
+-- > == [CyclicSCC ["d"],CyclicSCC ["b","c"],AcyclicSCC "a"]
stronglyConnComp
:: Ord key
=> [(node, key, [key])]
@@ -234,12 +241,17 @@ stronglyConnComp edges0
get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
--- | The strongly connected components of a directed graph, topologically
+-- | The strongly connected components of a directed graph, reverse topologically
-- sorted. The function is the same as 'stronglyConnComp', except that
-- all the information about each node retained.
-- This interface is used when you expect to apply 'SCC' to
-- (some of) the result of 'SCC', so you don't want to lose the
-- dependency information.
+--
+-- ==== __Examples__
+--
+-- > stronglyConnCompR [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]
+-- > == [CyclicSCC [("d",3,[3])],CyclicSCC [("b",1,[2,3]),("c",2,[1])],AcyclicSCC ("a",0,[1])]
stronglyConnCompR
:: Ord key
=> [(node, key, [key])]
@@ -247,7 +259,7 @@ stronglyConnCompR
-- with a list of keys of nodes this node has edges to.
-- The out-list may contain keys that don't correspond to
-- nodes of the graph; such edges are ignored.
- -> [SCC (node, key, [key])] -- ^ Topologically sorted
+ -> [SCC (node, key, [key])] -- ^ Reverse topologically sorted
stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
stronglyConnCompR edges0
@@ -400,7 +412,7 @@ graphFromEdges' x = (a,b) where
-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges []
-- > graph = array (0,-1) []
--
--- A graph where the out-list references unspecified nodes (@'c'@), these are
+-- A graph where the out-list references unspecified nodes (@\'c\'@), these are
-- ignored.
--
-- > (graph, _, _) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c'])]
@@ -620,7 +632,14 @@ undirected g = buildG (bounds g) (edges g ++ reverseE g)
-- Algorithm 4: strongly connected components
--- | The strongly connected components of a graph.
+-- | The strongly connected components of a graph, in reverse topological order.
+--
+-- ==== __Examples__
+--
+-- > scc (buildG (0,3) [(3,1),(1,2),(2,0),(0,1)])
+-- > == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]}
+-- > ,Node {rootLabel = 3, subForest = []}]
+
scc :: Graph -> Forest Vertex
scc g = dfs g (reverse (postOrd (transposeG g)))
diff --git a/Data/IntMap.hs b/src/Data/IntMap.hs
index 75855de..75855de 100644
--- a/Data/IntMap.hs
+++ b/src/Data/IntMap.hs
diff --git a/Data/IntMap/Internal.hs b/src/Data/IntMap/Internal.hs
index 1bad02b..edc2bf8 100644
--- a/Data/IntMap/Internal.hs
+++ b/src/Data/IntMap/Internal.hs
@@ -32,7 +32,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -173,6 +173,7 @@ module Data.IntMap.Internal (
, map
, mapWithKey
, traverseWithKey
+ , traverseMaybeWithKey
, mapAccum
, mapAccumWithKey
, mapAccumRWithKey
@@ -296,14 +297,22 @@ import Data.Traversable (Traversable(traverse))
import Data.Word (Word)
#endif
#if MIN_VERSION_base(4,9,0)
-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+import Data.Semigroup (Semigroup(stimes))
+#endif
+#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup((<>)))
+#endif
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (stimesIdempotentMonoid)
import Data.Functor.Classes
#endif
import Control.DeepSeq (NFData(rnf))
import Data.Bits
import qualified Data.Foldable as Foldable
+#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable())
+#endif
import Data.Maybe (fromMaybe)
import Data.Typeable
import Prelude hiding (lookup, map, filter, foldr, foldl, null)
@@ -429,11 +438,14 @@ instance Semigroup (IntMap a) where
stimes = stimesIdempotentMonoid
#endif
+-- | Folds in order of increasing key.
instance Foldable.Foldable IntMap where
fold = go
where go Nil = mempty
go (Tip _ v) = v
- go (Bin _ _ l r) = go l `mappend` go r
+ go (Bin _ m l r)
+ | m < 0 = go r `mappend` go l
+ | otherwise = go l `mappend` go r
{-# INLINABLE fold #-}
foldr = foldr
{-# INLINE foldr #-}
@@ -442,7 +454,9 @@ instance Foldable.Foldable IntMap where
foldMap f t = go t
where go Nil = mempty
go (Tip _ v) = f v
- go (Bin _ _ l r) = go l `mappend` go r
+ go (Bin _ m l r)
+ | m < 0 = go r `mappend` go l
+ | otherwise = go l `mappend` go r
{-# INLINE foldMap #-}
foldl' = foldl'
{-# INLINE foldl' #-}
@@ -484,6 +498,7 @@ instance Foldable.Foldable IntMap where
{-# INLINABLE product #-}
#endif
+-- | Traverses in order of increasing key.
instance Traversable IntMap where
traverse f = traverseWithKey (\_ -> f)
{-# INLINE traverse #-}
@@ -963,21 +978,21 @@ alter f k Nil = case f Nothing of
-- @
-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)
-- interactiveAlter k m = alterF f k m where
--- f Nothing -> do
+-- f Nothing = do
-- putStrLn $ show k ++
-- " was not found in the map. Would you like to add it?"
-- getUserResponse1 :: IO (Maybe String)
--- f (Just old) -> do
--- putStrLn "The key is currently bound to " ++ show old ++
+-- f (Just old) = do
+-- putStrLn $ "The key is currently bound to " ++ show old ++
-- ". Would you like to change or delete it?"
--- getUserresponse2 :: IO (Maybe String)
+-- getUserResponse2 :: IO (Maybe String)
-- @
--
-- 'alterF' is the most general operation for working with an individual
-- key that may or may not be in a given map.
--
--- Note: 'alterF' is a flipped version of the 'at' combinator from
--- 'Control.Lens.At'.
+-- Note: 'alterF' is a flipped version of the @at@ combinator from
+-- @Control.Lens.At@.
--
-- @since 0.5.8
@@ -1102,7 +1117,7 @@ withoutKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =
let minbit = bitmapOf p1
lt_minbit = minbit - 1
maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))
- gt_maxbit = maxbit `xor` complement (maxbit - 1)
+ gt_maxbit = (-maxbit) `xor` maxbit
-- TODO(wrengr): should we manually inline/unroll 'updatePrefix'
-- and 'withoutBM' here, in order to avoid redundant case analyses?
in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)
@@ -1825,7 +1840,7 @@ traverseMaybeWithKey f = go
-- | Merge two maps.
--
--- @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched' tactic
+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic
-- and two maps. It uses the tactics to merge the maps. Its behavior
-- is best understood via its fundamental tactics, 'mapMaybeMissing'
-- and 'zipWithMaybeMatched'.
@@ -1842,22 +1857,22 @@ traverseMaybeWithKey f = go
-- Take, for example,
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
--- @merge@ will first ''align'' these maps by key:
+-- 'merge' will first \"align\" these maps by key:
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
--- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
-- It will then pass the individual entries and pairs of entries
-- to @g1@, @g2@, or @f@ as appropriate:
--
-- @
--- maybes = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]
+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]
-- @
--
-- This produces a 'Maybe' for each key:
@@ -1907,7 +1922,7 @@ merge g1 g2 f m1 m2 =
-- | An applicative version of 'merge'.
--
--- @mergeA@ takes two 'WhenMissing' tactics, a 'WhenMatched'
+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'
-- tactic and two maps. It uses the tactics to merge the maps.
-- Its behavior is best understood via its fundamental tactics,
-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.
@@ -1924,22 +1939,22 @@ merge g1 g2 f m1 m2 =
-- Take, for example,
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]
-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
--- @mergeA@ will first ''align'' these maps by key:
+-- 'mergeA' will first \"align\" these maps by key:
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
--- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
-- It will then pass the individual entries and pairs of entries
-- to @g1@, @g2@, or @f@ as appropriate:
--
-- @
--- actions = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]
+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]
-- @
--
-- Next, it will perform the actions in the @actions@ list in order from
@@ -2408,7 +2423,9 @@ traverseWithKey f = go
where
go Nil = pure Nil
go (Tip k v) = Tip k <$> f k v
- go (Bin p m l r) = liftA2 (Bin p m) (go l) (go r)
+ go (Bin p m l r)
+ | m < 0 = liftA2 (Bin p m) (go r) (go l)
+ | otherwise = liftA2 (Bin p m) (go l) (go r)
{-# INLINE traverseWithKey #-}
-- | /O(n)/. The function @'mapAccum'@ threads an accumulating
@@ -2867,7 +2884,9 @@ foldMapWithKey f = go
where
go Nil = mempty
go (Tip kx x) = f kx x
- go (Bin _ _ l r) = go l `mappend` go r
+ go (Bin _ m l r)
+ | m < 0 = go r `mappend` go l
+ | otherwise = go l `mappend` go r
{-# INLINE foldMapWithKey #-}
{--------------------------------------------------------------------
@@ -3317,7 +3336,7 @@ mask i m
-- bit @m@.
maskW :: Nat -> Nat -> Prefix
maskW i m
- = intFromNat (i .&. (complement (m-1) `xor` m))
+ = intFromNat (i .&. ((-m) `xor` m))
{-# INLINE maskW #-}
-- | Does the left switching bit specify a shorter prefix?
diff --git a/Data/IntMap/Internal/Debug.hs b/src/Data/IntMap/Internal/Debug.hs
index a30dc69..a30dc69 100644
--- a/Data/IntMap/Internal/Debug.hs
+++ b/src/Data/IntMap/Internal/Debug.hs
diff --git a/Data/IntMap/Internal/DeprecatedDebug.hs b/src/Data/IntMap/Internal/DeprecatedDebug.hs
index 708a38a..708a38a 100644
--- a/Data/IntMap/Internal/DeprecatedDebug.hs
+++ b/src/Data/IntMap/Internal/DeprecatedDebug.hs
diff --git a/Data/IntMap/Lazy.hs b/src/Data/IntMap/Lazy.hs
index 57b26ee..57b26ee 100644
--- a/Data/IntMap/Lazy.hs
+++ b/src/Data/IntMap/Lazy.hs
diff --git a/Data/IntMap/Merge/Lazy.hs b/src/Data/IntMap/Merge/Lazy.hs
index 261124f..c24d0e4 100644
--- a/Data/IntMap/Merge/Lazy.hs
+++ b/src/Data/IntMap/Merge/Lazy.hs
@@ -39,8 +39,8 @@
--
-- == Efficiency note
--
--- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'
--- tactics are included because they are valid. However, they are
+-- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for
+-- 'WhenMissing' tactics are included because they are valid. However, they are
-- inefficient in many cases and should usually be avoided. The instances
-- for 'WhenMatched' tactics should not pose any major efficiency problems.
--
diff --git a/src/Data/IntMap/Merge/Strict.hs b/src/Data/IntMap/Merge/Strict.hs
new file mode 100644
index 0000000..d21c4e1
--- /dev/null
+++ b/src/Data/IntMap/Merge/Strict.hs
@@ -0,0 +1,233 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+#if __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Trustworthy #-}
+#endif
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
+#define USE_MAGIC_PROXY 1
+#endif
+
+#if USE_MAGIC_PROXY
+{-# LANGUAGE MagicHash #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.IntMap.Merge.Strict
+-- Copyright : (c) wren romano 2016
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This module defines an API for writing functions that merge two
+-- maps. The key functions are 'merge' and 'mergeA'.
+-- Each of these can be used with several different \"merge tactics\".
+--
+-- The 'merge' and 'mergeA' functions are shared by
+-- the lazy and strict modules. Only the choice of merge tactics
+-- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing'
+-- from this module then the results will be forced before they are
+-- inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from
+-- "Data.Map.Merge.Lazy" then they will not.
+--
+-- == Efficiency note
+--
+-- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for
+-- 'WhenMissing' tactics are included because they are valid. However, they are
+-- inefficient in many cases and should usually be avoided. The instances
+-- for 'WhenMatched' tactics should not pose any major efficiency problems.
+--
+-- @since 0.5.9
+
+module Data.IntMap.Merge.Strict (
+ -- ** Simple merge tactic types
+ SimpleWhenMissing
+ , SimpleWhenMatched
+
+ -- ** General combining function
+ , merge
+
+ -- *** @WhenMatched@ tactics
+ , zipWithMaybeMatched
+ , zipWithMatched
+
+ -- *** @WhenMissing@ tactics
+ , mapMaybeMissing
+ , dropMissing
+ , preserveMissing
+ , mapMissing
+ , filterMissing
+
+ -- ** Applicative merge tactic types
+ , WhenMissing
+ , WhenMatched
+
+ -- ** Applicative general combining function
+ , mergeA
+
+ -- *** @WhenMatched@ tactics
+ -- | The tactics described for 'merge' work for
+ -- 'mergeA' as well. Furthermore, the following
+ -- are available.
+ , zipWithMaybeAMatched
+ , zipWithAMatched
+
+ -- *** @WhenMissing@ tactics
+ -- | The tactics described for 'merge' work for
+ -- 'mergeA' as well. Furthermore, the following
+ -- are available.
+ , traverseMaybeMissing
+ , traverseMissing
+ , filterAMissing
+
+ -- ** Covariant maps for tactics
+ , mapWhenMissing
+ , mapWhenMatched
+
+ -- ** Miscellaneous functions on tactics
+
+ , runWhenMatched
+ , runWhenMissing
+ ) where
+
+import Data.IntMap.Internal
+ ( SimpleWhenMissing
+ , SimpleWhenMatched
+ , merge
+ , dropMissing
+ , preserveMissing
+ , filterMissing
+ , WhenMissing (..)
+ , WhenMatched (..)
+ , mergeA
+ , filterAMissing
+ , runWhenMatched
+ , runWhenMissing
+ )
+import Data.IntMap.Strict.Internal
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (Applicative (..), (<$>))
+#endif
+import Prelude hiding (filter, map, foldl, foldr)
+
+-- | Map covariantly over a @'WhenMissing' f k x@.
+mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f x a -> WhenMissing f x b
+mapWhenMissing f q = WhenMissing
+ { missingSubtree = fmap (map f) . missingSubtree q
+ , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x}
+
+-- | Map covariantly over a @'WhenMatched' f k x y@.
+mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f x y a -> WhenMatched f x y b
+mapWhenMatched f q = WhenMatched
+ { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y }
+
+-- | When a key is found in both maps, apply a function to the
+-- key and values and maybe use the result in the merged map.
+--
+-- @
+-- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)
+-- -> SimpleWhenMatched k x y z
+-- @
+zipWithMaybeMatched :: Applicative f
+ => (Key -> x -> y -> Maybe z)
+ -> WhenMatched f x y z
+zipWithMaybeMatched f = WhenMatched $
+ \k x y -> pure $! forceMaybe $! f k x y
+{-# INLINE zipWithMaybeMatched #-}
+
+-- | When a key is found in both maps, apply a function to the
+-- key and values, perform the resulting action, and maybe use
+-- the result in the merged map.
+--
+-- This is the fundamental 'WhenMatched' tactic.
+zipWithMaybeAMatched :: Applicative f
+ => (Key -> x -> y -> f (Maybe z))
+ -> WhenMatched f x y z
+zipWithMaybeAMatched f = WhenMatched $
+ \ k x y -> forceMaybe <$> f k x y
+{-# INLINE zipWithMaybeAMatched #-}
+
+-- | When a key is found in both maps, apply a function to the
+-- key and values to produce an action and use its result in the merged map.
+zipWithAMatched :: Applicative f
+ => (Key -> x -> y -> f z)
+ -> WhenMatched f x y z
+zipWithAMatched f = WhenMatched $
+ \ k x y -> (Just $!) <$> f k x y
+{-# INLINE zipWithAMatched #-}
+
+-- | When a key is found in both maps, apply a function to the
+-- key and values and use the result in the merged map.
+--
+-- @
+-- zipWithMatched :: (k -> x -> y -> z)
+-- -> SimpleWhenMatched k x y z
+-- @
+zipWithMatched :: Applicative f
+ => (Key -> x -> y -> z) -> WhenMatched f x y z
+zipWithMatched f = WhenMatched $
+ \k x y -> pure $! Just $! f k x y
+{-# INLINE zipWithMatched #-}
+
+-- | Map over the entries whose keys are missing from the other map,
+-- optionally removing some. This is the most powerful 'SimpleWhenMissing'
+-- tactic, but others are usually more efficient.
+--
+-- @
+-- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y
+-- @
+--
+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))
+--
+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.
+mapMaybeMissing :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y
+mapMaybeMissing f = WhenMissing
+ { missingSubtree = \m -> pure $! mapMaybeWithKey f m
+ , missingKey = \k x -> pure $! forceMaybe $! f k x }
+{-# INLINE mapMaybeMissing #-}
+
+-- | Map over the entries whose keys are missing from the other map.
+--
+-- @
+-- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y
+-- @
+--
+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)
+--
+-- but @mapMissing@ is somewhat faster.
+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y
+mapMissing f = WhenMissing
+ { missingSubtree = \m -> pure $! mapWithKey f m
+ , missingKey = \k x -> pure $! Just $! f k x }
+{-# INLINE mapMissing #-}
+
+-- | Traverse over the entries whose keys are missing from the other map,
+-- optionally producing values to put in the result.
+-- This is the most powerful 'WhenMissing' tactic, but others are usually
+-- more efficient.
+traverseMaybeMissing :: Applicative f
+ => (Key -> x -> f (Maybe y)) -> WhenMissing f x y
+traverseMaybeMissing f = WhenMissing
+ { missingSubtree = traverseMaybeWithKey f
+ , missingKey = \k x -> forceMaybe <$> f k x }
+{-# INLINE traverseMaybeMissing #-}
+
+-- | Traverse over the entries whose keys are missing from the other map.
+traverseMissing :: Applicative f
+ => (Key -> x -> f y) -> WhenMissing f x y
+traverseMissing f = WhenMissing
+ { missingSubtree = traverseWithKey f
+ , missingKey = \k x -> (Just $!) <$> f k x }
+{-# INLINE traverseMissing #-}
+
+forceMaybe :: Maybe a -> Maybe a
+forceMaybe Nothing = Nothing
+forceMaybe m@(Just !_) = m
+{-# INLINE forceMaybe #-}
diff --git a/src/Data/IntMap/Strict.hs b/src/Data/IntMap/Strict.hs
new file mode 100644
index 0000000..88bdc93
--- /dev/null
+++ b/src/Data/IntMap/Strict.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.IntMap.Strict
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Int Maps (strict interface)
+--
+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)
+-- from key of type @Int@ to values of type @v@.
+--
+-- Each function in this module is careful to force values before installing
+-- them in an 'IntMap'. This is usually more efficient when laziness is not
+-- necessary. When laziness /is/ required, use the functions in
+-- "Data.IntMap.Lazy".
+--
+-- In particular, the functions in this module obey the following law:
+--
+-- - If all values stored in all maps in the arguments are in WHNF, then all
+-- values stored in all maps in the results will be in WHNF once those maps
+-- are evaluated.
+--
+-- For a walkthrough of the most commonly used functions see the
+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.
+--
+-- This module is intended to be imported qualified, to avoid name clashes with
+-- Prelude functions:
+--
+-- > import Data.IntMap.Strict (IntMap)
+-- > import qualified Data.IntMap.Strict as IntMap
+--
+-- Note that the implementation is generally /left-biased/. Functions that take
+-- two maps as arguments and combine them, such as `union` and `intersection`,
+-- prefer the values in the first argument to those in the second.
+--
+--
+-- == Detailed performance information
+--
+-- The amortized running time is given for each operation, with /n/ referring to
+-- the number of entries in the map and /W/ referring to the number of bits in
+-- an 'Int' (32 or 64).
+--
+-- Benchmarks comparing "Data.IntMap.Strict" with other dictionary
+-- implementations can be found at https://github.com/haskell-perf/dictionaries.
+--
+--
+-- == Warning
+--
+-- The 'IntMap' type is shared between the lazy and strict modules, meaning that
+-- the same 'IntMap' value can be passed to functions in both modules. This
+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are
+-- the same as for the "Data.IntMap.Lazy" module, so if they are used the
+-- resulting map may contain suspended values (thunks).
+--
+--
+-- == Implementation
+--
+-- The implementation is based on /big-endian patricia trees/. This data
+-- structure performs especially well on binary operations like 'union' and
+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster
+-- on insertions and deletions when compared to a generic size-balanced map
+-- implementation (see "Data.Map").
+--
+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+-- Workshop on ML, September 1998, pages 77-86,
+-- <http://citeseer.ist.psu.edu/okasaki98fast.html>
+--
+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
+-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
+-- October 1968, pages 514-534.
+--
+-----------------------------------------------------------------------------
+
+-- See the notes at the beginning of Data.IntMap.Internal.
+
+module Data.IntMap.Strict (
+ -- * Map type
+#if !defined(TESTING)
+ IntMap, Key -- instance Eq,Show
+#else
+ IntMap(..), Key -- instance Eq,Show
+#endif
+
+ -- * Construction
+ , empty
+ , singleton
+ , fromSet
+
+ -- ** From Unordered Lists
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** From Ascending Lists
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Insertion
+ , insert
+ , insertWith
+ , insertWithKey
+ , insertLookupWithKey
+
+ -- * Deletion\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+ , alter
+ , alterF
+
+ -- * Query
+ -- ** Lookup
+ , lookup
+ , (!?)
+ , (!)
+ , findWithDefault
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+
+ -- ** Size
+ , null
+ , size
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , (\\)
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- ** Universal combining function
+ , mergeWithKey
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , traverseWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapAccumRWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- * Folds
+ , foldr
+ , foldl
+ , foldrWithKey
+ , foldlWithKey
+ , foldMapWithKey
+
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+ , foldrWithKey'
+ , foldlWithKey'
+
+ -- * Conversion
+ , elems
+ , keys
+ , assocs
+ , keysSet
+
+ -- ** Lists
+ , toList
+
+-- ** Ordered lists
+ , toAscList
+ , toDescList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , restrictKeys
+ , withoutKeys
+ , partition
+ , partitionWithKey
+
+ , mapMaybe
+ , mapMaybeWithKey
+ , mapEither
+ , mapEitherWithKey
+
+ , split
+ , splitLookup
+ , splitRoot
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+
+#ifdef __GLASGOW_HASKELL__
+ -- * Debugging
+ , showTree
+ , showTreeWith
+#endif
+ ) where
+
+import Data.IntMap.Strict.Internal
+import Prelude ()
diff --git a/Data/IntMap/Strict.hs b/src/Data/IntMap/Strict/Internal.hs
index 2cc992c..f53280e 100644
--- a/Data/IntMap/Strict.hs
+++ b/src/Data/IntMap/Strict/Internal.hs
@@ -1,14 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
-{-# LANGUAGE Trustworthy #-}
-#endif
#include "containers.h"
-----------------------------------------------------------------------------
-- |
--- Module : Data.IntMap.Strict
+-- Module : Data.IntMap.Strict.Internal
-- Copyright : (c) Daan Leijen 2002
-- (c) Andriy Palamarchuk 2008
-- License : BSD-style
@@ -22,7 +19,7 @@
-- from key of type @Int@ to values of type @v@.
--
-- Each function in this module is careful to force values before installing
--- them in a 'Map'. This is usually more efficient when laziness is not
+-- them in an 'IntMap'. This is usually more efficient when laziness is not
-- necessary. When laziness /is/ required, use the functions in
-- "Data.IntMap.Lazy".
--
@@ -60,9 +57,9 @@
--
-- The 'IntMap' type is shared between the lazy and strict modules, meaning that
-- the same 'IntMap' value can be passed to functions in both modules. This
--- means that the 'Functor', 'Traversable' and 'Data' instances are the same as
--- for the "Data.IntMap.Lazy" module, so if they are used the resulting map may
--- contain suspended values (thunks).
+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are
+-- the same as for the "Data.IntMap.Lazy" module, so if they are used the
+-- resulting map may contain suspended values (thunks).
--
--
-- == Implementation
@@ -85,7 +82,7 @@
-- See the notes at the beginning of Data.IntMap.Internal.
-module Data.IntMap.Strict (
+module Data.IntMap.Strict.Internal (
-- * Map type
#if !defined(TESTING)
IntMap, Key -- instance Eq,Show
@@ -170,6 +167,7 @@ module Data.IntMap.Strict (
, map
, mapWithKey
, traverseWithKey
+ , traverseMaybeWithKey
, mapAccum
, mapAccumWithKey
, mapAccumRWithKey
@@ -344,7 +342,9 @@ import Data.Functor((<$>))
#endif
import Control.Applicative (Applicative (..), liftA2)
import qualified Data.Foldable as Foldable
+#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable())
+#endif
{--------------------------------------------------------------------
Query
@@ -607,14 +607,14 @@ alter f !k t =
-- @
-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)
-- interactiveAlter k m = alterF f k m where
--- f Nothing -> do
+-- f Nothing = do
-- putStrLn $ show k ++
-- " was not found in the map. Would you like to add it?"
-- getUserResponse1 :: IO (Maybe String)
--- f (Just old) -> do
--- putStrLn "The key is currently bound to " ++ show old ++
+-- f (Just old) = do
+-- putStrLn $ "The key is currently bound to " ++ show old ++
-- ". Would you like to change or delete it?"
--- getUserresponse2 :: IO (Maybe String)
+-- getUserResponse2 :: IO (Maybe String)
-- @
--
-- 'alterF' is the most general operation for working with an individual
@@ -893,6 +893,15 @@ traverseWithKey f = go
go (Bin p m l r) = liftA2 (Bin p m) (go l) (go r)
{-# INLINE traverseWithKey #-}
+-- | /O(n)/. Traverse keys\/values and collect the 'Just' results.
+traverseMaybeWithKey
+ :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b)
+traverseMaybeWithKey f = go
+ where
+ go Nil = pure Nil
+ go (Tip k x) = maybe Nil (Tip k $!) <$> f k x
+ go (Bin p m l r) = liftA2 (bin p m) (go l) (go r)
+
-- | /O(n)/. The function @'mapAccum'@ threads an accumulating
-- argument through the map in ascending order of keys.
--
diff --git a/Data/IntSet.hs b/src/Data/IntSet.hs
index c883411..c883411 100644
--- a/Data/IntSet.hs
+++ b/src/Data/IntSet.hs
diff --git a/Data/IntSet/Internal.hs b/src/Data/IntSet/Internal.hs
index 8a0b08e..3bc157b 100644
--- a/Data/IntSet/Internal.hs
+++ b/src/Data/IntSet/Internal.hs
@@ -29,7 +29,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -195,7 +195,13 @@ import Data.Monoid (Monoid(..))
import Data.Word (Word)
#endif
#if MIN_VERSION_base(4,9,0)
-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+import Data.Semigroup (Semigroup(stimes))
+#endif
+#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup((<>)))
+#endif
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (stimesIdempotentMonoid)
#endif
import Data.Typeable
import Prelude hiding (filter, foldr, foldl, null, map)
@@ -213,11 +219,13 @@ import GHC.Exts (Int(..), build)
#if __GLASGOW_HASKELL__ >= 708
import qualified GHC.Exts as GHCExts
#endif
-import GHC.Prim (indexInt8OffAddr#)
+import GHC.Exts (indexInt8OffAddr#)
#endif
import qualified Data.Foldable as Foldable
+#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable())
+#endif
infixl 9 \\{-This comment teaches CPP correct behaviour -}
diff --git a/Data/Map.hs b/src/Data/Map.hs
index 47385aa..3330153 100644
--- a/Data/Map.hs
+++ b/src/Data/Map.hs
@@ -101,7 +101,7 @@ insertLookupWithKey' :: Whoops "Data.Map.insertLookupWithKey' is gone. Use Data.
insertLookupWithKey' _ _ _ _ = undefined
-- | This function is being removed and is no longer usable.
--- Use 'foldr'.
+-- Use 'Data.Map.Strict.foldr'.
fold :: Whoops "Data.Map.fold is gone. Use foldr."
=> (a -> b -> b) -> b -> Map k a -> b
fold _ _ _ = undefined
diff --git a/Data/Map/Internal.hs b/src/Data/Map/Internal.hs
index 4506e1b..f8b18a3 100644
--- a/Data/Map/Internal.hs
+++ b/src/Data/Map/Internal.hs
@@ -40,7 +40,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -202,6 +202,7 @@ module Data.Map.Internal (
, mapMaybeMissing
, dropMissing
, preserveMissing
+ , preserveMissing'
, mapMissing
, filterMissing
@@ -372,13 +373,21 @@ import Data.Traversable (Traversable(traverse))
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+import Data.Semigroup (stimesIdempotentMonoid)
+#endif
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup(stimes))
+#endif
+#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup((<>)))
#endif
import Control.Applicative (Const (..))
import Control.DeepSeq (NFData(rnf))
import Data.Bits (shiftL, shiftR)
import qualified Data.Foldable as Foldable
+#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable())
+#endif
import Data.Typeable
import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop)
@@ -454,6 +463,11 @@ m1 \\ m2 = difference m1 m2
Size balanced trees.
--------------------------------------------------------------------}
-- | A Map from keys @k@ to values @a@.
+--
+-- The 'Semigroup' operation for 'Map' is 'union', which prefers
+-- values from the left operand. If @m1@ maps a key @k@ to a value
+-- @a1@, and @m2@ maps the same key to a different value @a2@, then
+-- their union @m1 <> m2@ maps @k@ to @a1@.
-- See Note: Order of constructors
data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
@@ -1167,14 +1181,14 @@ data AreWeStrict = Strict | Lazy
-- @
-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
-- interactiveAlter k m = alterF f k m where
--- f Nothing -> do
+-- f Nothing = do
-- putStrLn $ show k ++
-- " was not found in the map. Would you like to add it?"
-- getUserResponse1 :: IO (Maybe String)
--- f (Just old) -> do
--- putStrLn "The key is currently bound to " ++ show old ++
+-- f (Just old) = do
+-- putStrLn $ "The key is currently bound to " ++ show old ++
-- ". Would you like to change or delete it?"
--- getUserresponse2 :: IO (Maybe String)
+-- getUserResponse2 :: IO (Maybe String)
-- @
--
-- 'alterF' is the most general operation for working with an individual
@@ -1194,8 +1208,8 @@ data AreWeStrict = Strict | Lazy
-- a very large fraction of the time, you might consider using a
-- private copy of the 'Identity' type.
--
--- Note: 'alterF' is a flipped version of the 'at' combinator from
--- 'Control.Lens.At'.
+-- Note: 'alterF' is a flipped version of the @at@ combinator from
+-- @Control.Lens.At@.
--
-- @since 0.5.8
alterF :: (Functor f, Ord k)
@@ -1982,7 +1996,7 @@ intersection t1@(Bin _ k x l1 r1) t2
--
-- @
-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m
--- m \`restrictKeys\` s = m ``intersect`` 'fromSet' (const ()) s
+-- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s
-- @
--
-- @since 0.5.8
@@ -2359,6 +2373,29 @@ preserveMissing = WhenMissing
, missingKey = \_ v -> pure (Just v) }
{-# INLINE preserveMissing #-}
+-- | Force the entries whose keys are missing from
+-- the other map and otherwise preserve them unchanged.
+--
+-- @
+-- preserveMissing' :: SimpleWhenMissing k x x
+-- @
+--
+-- prop> preserveMissing' = Merge.Lazy.mapMaybeMissing (\_ x -> Just $! x)
+--
+-- but @preserveMissing'@ is quite a bit faster.
+--
+-- @since 0.5.9
+preserveMissing' :: Applicative f => WhenMissing f k x x
+preserveMissing' = WhenMissing
+ { missingSubtree = \t -> pure $! forceTree t `seq` t
+ , missingKey = \_ v -> pure $! Just $! v }
+{-# INLINE preserveMissing' #-}
+
+-- Force all the values in a tree.
+forceTree :: Map k a -> ()
+forceTree (Bin _ _ v l r) = v `seq` forceTree l `seq` forceTree r `seq` ()
+forceTree Tip = ()
+
-- | Map over the entries whose keys are missing from the other map.
--
-- @
@@ -2461,7 +2498,7 @@ traverseMaybeMissing f = WhenMissing
-- | Merge two maps.
--
--- @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched'
+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched'
-- tactic and two maps. It uses the tactics to merge the maps.
-- Its behavior is best understood via its fundamental tactics,
-- 'mapMaybeMissing' and 'zipWithMaybeMatched'.
@@ -2478,22 +2515,22 @@ traverseMaybeMissing f = WhenMissing
-- Take, for example,
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
--- @merge@ will first ''align'' these maps by key:
+-- 'merge' will first \"align\" these maps by key:
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
--- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
-- It will then pass the individual entries and pairs of entries
-- to @g1@, @g2@, or @f@ as appropriate:
--
-- @
--- maybes = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]
+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]
-- @
--
-- This produces a 'Maybe' for each key:
@@ -2542,7 +2579,7 @@ merge g1 g2 f m1 m2 = runIdentity $
-- | An applicative version of 'merge'.
--
--- @mergeA@ takes two 'WhenMissing' tactics, a 'WhenMatched'
+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'
-- tactic and two maps. It uses the tactics to merge the maps.
-- Its behavior is best understood via its fundamental tactics,
-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.
@@ -2559,22 +2596,22 @@ merge g1 g2 f m1 m2 = runIdentity $
-- Take, for example,
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
--- @mergeA@ will first ''align'' these maps by key:
+-- @mergeA@ will first \"align\" these maps by key:
--
-- @
--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
--- m2 = [(1, "one"), (2, "two"), (4, "three")]
+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]
+-- m2 = [(1, "one"), (2, "two"), (4, "three")]
-- @
--
-- It will then pass the individual entries and pairs of entries
-- to @g1@, @g2@, or @f@ as appropriate:
--
-- @
--- actions = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]
+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]
-- @
--
-- Next, it will perform the actions in the @actions@ list in order from
@@ -2719,22 +2756,33 @@ isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2
> isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
> isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
+ Note that @isSubmapOfBy (\_ _ -> True) m1 m2@ tests whether all the keys
+ in @m1@ are also keys in @m2@.
-}
isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
isSubmapOfBy f t1 t2
- = (size t1 <= size t2) && (submap' f t1 t2)
+ = size t1 <= size t2 && submap' f t1 t2
#if __GLASGOW_HASKELL__
{-# INLINABLE isSubmapOfBy #-}
#endif
+-- Test whether a map is a submap of another without the *initial*
+-- size test. See Data.Set.Internal.isSubsetOfX for notes on
+-- implementation and analysis.
submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool
submap' _ Tip _ = True
submap' _ _ Tip = False
+submap' f (Bin 1 kx x _ _) t
+ = case lookup kx t of
+ Just y -> f x y
+ Nothing -> False
submap' f (Bin _ kx x l r) t
= case found of
Nothing -> False
- Just y -> f x y && submap' f l lt && submap' f r gt
+ Just y -> f x y
+ && size l <= size lt && size r <= size gt
+ && submap' f l lt && submap' f r gt
where
(lt,found,gt) = splitLookup kx t
#if __GLASGOW_HASKELL__
@@ -2770,7 +2818,7 @@ isProperSubmapOf m1 m2
-}
isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
isProperSubmapOfBy f t1 t2
- = (size t1 < size t2) && (submap' f t1 t2)
+ = size t1 < size t2 && submap' f t1 t2
#if __GLASGOW_HASKELL__
{-# INLINABLE isProperSubmapOfBy #-}
#endif
@@ -2854,7 +2902,7 @@ dropWhileAntitone p (Bin _ kx x l r)
--
-- @
-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)
--- spanAntitone p xs = partition p xs
+-- spanAntitone p xs = partitionWithKey (\k _ -> p k) xs
-- @
--
-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map
@@ -3315,7 +3363,6 @@ fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)
{--------------------------------------------------------------------
Lists
- use [foldlStrict] to reduce demand on the control-stack
--------------------------------------------------------------------}
#if __GLASGOW_HASKELL__ >= 708
-- | @since 0.5.6.2
@@ -4123,10 +4170,12 @@ instance Functor (Map k) where
a <$ (Bin sx kx _ l r) = Bin sx kx a (a <$ l) (a <$ r)
#endif
+-- | Traverses in order of increasing key.
instance Traversable (Map k) where
traverse f = traverseWithKey (\_ -> f)
{-# INLINE traverse #-}
+-- | Folds in order of increasing key.
instance Foldable.Foldable (Map k) where
fold = go
where go Tip = mempty
diff --git a/Data/Map/Internal/Debug.hs b/src/Data/Map/Internal/Debug.hs
index e17aa8a..e17aa8a 100644
--- a/Data/Map/Internal/Debug.hs
+++ b/src/Data/Map/Internal/Debug.hs
diff --git a/Data/Map/Internal/DeprecatedShowTree.hs b/src/Data/Map/Internal/DeprecatedShowTree.hs
index 0d296d0..0d296d0 100644
--- a/Data/Map/Internal/DeprecatedShowTree.hs
+++ b/src/Data/Map/Internal/DeprecatedShowTree.hs
diff --git a/Data/Map/Lazy.hs b/src/Data/Map/Lazy.hs
index 64a0bc6..1080f96 100644
--- a/Data/Map/Lazy.hs
+++ b/src/Data/Map/Lazy.hs
@@ -27,7 +27,7 @@
--
-- When deciding if this is the correct data structure to use, consider:
--
--- * If you are using 'Int' keys, you will get much better performance for most
+-- * If you are using 'Prelude.Int' keys, you will get much better performance for most
-- operations using "Data.IntMap.Lazy".
--
-- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the
@@ -58,9 +58,9 @@
--
-- == Warning
--
--- The size of a 'Map' must not exceed @maxBound::Int@. Violation of this
--- condition is not detected and if the size limit is exceeded, its behaviour is
--- undefined.
+-- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.
+-- Violation of this condition is not detected and if the size limit is exceeded,
+-- its behaviour is undefined.
--
--
-- == Implementation
diff --git a/Data/Map/Merge/Lazy.hs b/src/Data/Map/Merge/Lazy.hs
index cace54b..cfc52c5 100644
--- a/Data/Map/Merge/Lazy.hs
+++ b/src/Data/Map/Merge/Lazy.hs
@@ -39,8 +39,8 @@
--
-- == Efficiency note
--
--- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'
--- tactics are included because they are valid. However, they are
+-- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for
+-- 'WhenMissing' tactics are included because they are valid. However, they are
-- inefficient in many cases and should usually be avoided. The instances
-- for 'WhenMatched' tactics should not pose any major efficiency problems.
--
diff --git a/Data/Map/Merge/Strict.hs b/src/Data/Map/Merge/Strict.hs
index f7d5241..bf683f8 100644
--- a/Data/Map/Merge/Strict.hs
+++ b/src/Data/Map/Merge/Strict.hs
@@ -37,10 +37,15 @@
-- inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from
-- "Data.Map.Merge.Lazy" then they will not.
--
+-- == 'preserveMissing' inconsistency
+--
+-- For historical reasons, the preserved values are //not// forced. To force
+-- them, use 'preserveMissing''.
+--
-- == Efficiency note
--
--- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'
--- tactics are included because they are valid. However, they are
+-- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for
+-- 'WhenMissing' tactics are included because they are valid. However, they are
-- inefficient in many cases and should usually be avoided. The instances
-- for 'WhenMatched' tactics should not pose any major efficiency problems.
--
@@ -62,6 +67,7 @@ module Data.Map.Merge.Strict (
, mapMaybeMissing
, dropMissing
, preserveMissing
+ , preserveMissing'
, mapMissing
, filterMissing
diff --git a/Data/Map/Strict.hs b/src/Data/Map/Strict.hs
index 206985f..084b856 100644
--- a/Data/Map/Strict.hs
+++ b/src/Data/Map/Strict.hs
@@ -33,8 +33,8 @@
--
-- When deciding if this is the correct data structure to use, consider:
--
--- * If you are using 'Int' keys, you will get much better performance for most
--- operations using "Data.IntMap.Strict".
+-- * If you are using 'Prelude.Int' keys, you will get much better performance for
+-- most operations using "Data.IntMap.Strict".
--
-- * If you don't care about ordering, consider use @Data.HashMap.Strict@ from the
-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>
@@ -70,9 +70,9 @@
--
-- The 'Map' type is shared between the lazy and strict modules, meaning that
-- the same 'Map' value can be passed to functions in both modules. This means
--- that the 'Functor', 'Traversable' and 'Data' instances are the same as for
--- the "Data.Map.Lazy" module, so if they are used the resulting maps may contain
--- suspended values (thunks).
+-- that the 'Data.Functor.Functor', 'Data.Traversable.Traversable' and
+-- 'Data.Data.Data' instances are the same as for the "Data.Map.Lazy" module, so
+-- if they are used the resulting maps may contain suspended values (thunks).
--
--
-- == Implementation
diff --git a/Data/Map/Strict/Internal.hs b/src/Data/Map/Strict/Internal.hs
index 756582b..788d51d 100644
--- a/Data/Map/Strict/Internal.hs
+++ b/src/Data/Map/Strict/Internal.hs
@@ -22,7 +22,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -72,7 +72,7 @@
-- Operation comments contain the operation time complexity in
-- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).
--
--- Be aware that the 'Functor', 'Traversable' and 'Data' instances
+-- Be aware that the 'Functor', 'Traversable' and 'Data.Data.Data' instances
-- are the same as for the "Data.Map.Lazy" module, so if they are used
-- on strict maps, the resulting maps will be lazy.
-----------------------------------------------------------------------------
@@ -157,6 +157,7 @@ module Data.Map.Strict.Internal
, mapMaybeMissing
, dropMissing
, preserveMissing
+ , preserveMissing'
, mapMissing
, filterMissing
@@ -311,6 +312,7 @@ import Data.Map.Internal
, SimpleWhenMissing
, SimpleWhenMatched
, preserveMissing
+ , preserveMissing'
, dropMissing
, filterMissing
, filterAMissing
@@ -422,7 +424,9 @@ import Data.Functor.Identity (Identity (..))
#endif
import qualified Data.Foldable as Foldable
+#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable())
+#endif
-- $strictness
--
@@ -814,14 +818,14 @@ alter = go
-- @
-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
-- interactiveAlter k m = alterF f k m where
--- f Nothing -> do
+-- f Nothing = do
-- putStrLn $ show k ++
-- " was not found in the map. Would you like to add it?"
-- getUserResponse1 :: IO (Maybe String)
--- f (Just old) -> do
--- putStrLn "The key is currently bound to " ++ show old ++
+-- f (Just old) = do
+-- putStrLn $ "The key is currently bound to " ++ show old ++
-- ". Would you like to change or delete it?"
--- getUserresponse2 :: IO (Maybe String)
+-- getUserResponse2 :: IO (Maybe String)
-- @
--
-- 'alterF' is the most general operation for working with an individual
@@ -841,8 +845,8 @@ alter = go
-- a very large fraction of the time, you might consider using a
-- private copy of the 'Identity' type.
--
--- Note: 'alterF' is a flipped version of the 'at' combinator from
--- 'Control.Lens.At'.
+-- Note: 'alterF' is a flipped version of the @at@ combinator from
+-- @Control.Lens.At@.
alterF :: (Functor f, Ord k)
=> (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
alterF f k m = atKeyImpl Strict k f m
@@ -1467,7 +1471,6 @@ fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l)
{--------------------------------------------------------------------
Lists
- use [foldlStrict] to reduce demand on the control-stack
--------------------------------------------------------------------}
-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
-- If the list contains more than one value for the same key, the last value
diff --git a/Data/Sequence.hs b/src/Data/Sequence.hs
index 3e4c705..3aa4fea 100644
--- a/Data/Sequence.hs
+++ b/src/Data/Sequence.hs
@@ -91,7 +91,7 @@
-- * The 'Functor' methods 'fmap' and '<$', along with 'mapWithIndex'
-- * The 'Applicative' methods '<*>', '*>', and '<*'
-- * The zips: 'zipWith', 'zip', etc.
--- * 'heads' and 'tails'
+-- * 'inits', 'tails'
-- * 'fromFunction', 'replicate', 'intersperse', and 'cycleTaking'
-- * 'reverse'
-- * 'chunksOf'
@@ -156,7 +156,7 @@ module Data.Sequence (
unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
-- * Deconstruction
-- | Additional functions for deconstructing sequences are available
- -- via the 'Foldable' instance of 'Seq'.
+ -- via the 'Data.Foldable.Foldable' instance of 'Seq'.
-- ** Queries
null, -- :: Seq a -> Bool
@@ -218,7 +218,8 @@ module Data.Sequence (
findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
-- * Folds
- -- | General folds are available via the 'Foldable' instance of 'Seq'.
+ -- | General folds are available via the 'Data.Foldable.Foldable' instance
+ -- of 'Seq'.
foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m
foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
diff --git a/Data/Sequence/Internal.hs b/src/Data/Sequence/Internal.hs
index b945b12..8a4dc90 100644
--- a/Data/Sequence/Internal.hs
+++ b/src/Data/Sequence/Internal.hs
@@ -36,7 +36,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -645,10 +645,10 @@ type Digit23 a = Node a
-- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to
-- produce the main body, and glues all the pieces together.
--
--- 'map23' itself is a bit horrifying because of the nested types involved. Its
+-- @map23@ itself is a bit horrifying because of the nested types involved. Its
-- job is to map over the *elements* of a 2-3 tree, rather than the subtrees.
-- If we used a higher-order nested type with MPTC, we could probably use a
--- class, but as it is we have to build up 'map23' explicitly through the
+-- class, but as it is we have to build up @map23@ explicitly through the
-- recursion.
aptyMiddle
:: (b -> c)
@@ -891,6 +891,7 @@ instance Monoid (Seq a) where
-- | @since 0.5.7
instance Semigroup.Semigroup (Seq a) where
(<>) = (><)
+ stimes = cycleNTimes . fromIntegral
#endif
INSTANCE_TYPEABLE1(Seq)
@@ -1425,9 +1426,9 @@ replicateM n x
--
-- prop> cycleTaking k = fromList . take k . cycle . toList
--- If you wish to concatenate a non-empty sequence @xs@ with itself precisely
--- @k@ times, you can use @cycleTaking (k * length xs)@ or just
--- @replicate k () *> xs@.
+-- If you wish to concatenate a possibly empty sequence @xs@ with
+-- itself precisely @k@ times, use @'stimes' k xs@ instead of this
+-- function.
--
-- @since 0.5.8
cycleTaking :: Int -> Seq a -> Seq a
@@ -2974,7 +2975,12 @@ traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) ->
!sPsab = sPsa + size b
-{-# NOINLINE [1] traverseWithIndex #-}
+#ifdef __GLASGOW_HASKELL__
+{-# INLINABLE [1] traverseWithIndex #-}
+#else
+{-# INLINE [1] traverseWithIndex #-}
+#endif
+
#ifdef __GLASGOW_HASKELL__
{-# RULES
"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =
diff --git a/Data/Sequence/Internal/Sorting.hs b/src/Data/Sequence/Internal/Sorting.hs
index 4c8d38f..5b84b37 100644
--- a/Data/Sequence/Internal/Sorting.hs
+++ b/src/Data/Sequence/Internal/Sorting.hs
@@ -10,7 +10,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -396,7 +396,7 @@ foldToMaybeTree (<+>) f (Deep _ pr m sf) =
m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m
{-# INLINE foldToMaybeTree #-}
--- | A 'foldMapWithIndex'-like function, specialized to the
+-- | A 'Data.Sequence.foldMapWithIndex'-like function, specialized to the
-- 'Data.Semigroup.Option' monoid, which takes advantage of the
-- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain
-- points.
diff --git a/Data/Set.hs b/src/Data/Set.hs
index 2dea90b..2dea90b 100644
--- a/Data/Set.hs
+++ b/src/Data/Set.hs
diff --git a/Data/Set/Internal.hs b/src/Data/Set/Internal.hs
index 53a8d60..c6ce3f2 100644
--- a/Data/Set/Internal.hs
+++ b/src/Data/Set/Internal.hs
@@ -30,7 +30,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -236,7 +236,13 @@ import Data.Bits (shiftL, shiftR)
import Data.Monoid (Monoid(..))
#endif
#if MIN_VERSION_base(4,9,0)
-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+import Data.Semigroup (Semigroup(stimes))
+#endif
+#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup((<>)))
+#endif
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (stimesIdempotentMonoid)
import Data.Functor.Classes
#endif
import qualified Data.Foldable as Foldable
@@ -302,6 +308,7 @@ instance Ord a => Semigroup (Set a) where
#endif
+-- | Folds in order of increasing key.
instance Foldable.Foldable Set where
fold = go
where go Tip = mempty
@@ -590,29 +597,67 @@ delete = go
{--------------------------------------------------------------------
Subset
--------------------------------------------------------------------}
--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
+-- | /O(m*log(n\/m + 1)), m <= n/.
+-- @(s1 \`isProperSubsetOf\` s2)@ indicates whether @s1@ is a
+-- proper subset of @s2@.
+--
+-- @
+-- s1 \`isProperSubsetOf\` s2 = s1 ``isSubsetOf`` s2 && s1 /= s2
+-- @
isProperSubsetOf :: Ord a => Set a -> Set a -> Bool
isProperSubsetOf s1 s2
- = (size s1 < size s2) && (isSubsetOf s1 s2)
+ = size s1 < size s2 && isSubsetOfX s1 s2
#if __GLASGOW_HASKELL__
{-# INLINABLE isProperSubsetOf #-}
#endif
--- | /O(n+m)/. Is this a subset?
--- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.
+-- | /O(m*log(n\/m + 1)), m <= n/.
+-- @(s1 \`isSubsetOf\` s2)@ indicates whether @s1@ is a subset of @s2@.
+--
+-- @
+-- s1 \`isSubsetOf\` s2 = all (``member`` s2) s1
+-- s1 \`isSubsetOf\` s2 = null (s1 ``difference`` s2)
+-- s1 \`isSubsetOf\` s2 = s1 ``union`` s2 == s2
+-- s1 \`isSubsetOf\` s2 = s1 ``intersection`` s2 == s1
+-- @
isSubsetOf :: Ord a => Set a -> Set a -> Bool
isSubsetOf t1 t2
- = (size t1 <= size t2) && (isSubsetOfX t1 t2)
+ = size t1 <= size t2 && isSubsetOfX t1 t2
#if __GLASGOW_HASKELL__
{-# INLINABLE isSubsetOf #-}
#endif
+-- Test whether a set is a subset of another without the *initial*
+-- size test.
+--
+-- This function is structured very much like `difference`, `union`,
+-- and `intersection`. Whereas the bounds proofs for those in Blelloch
+-- et al needed to accound for both "split work" and "merge work", we
+-- only have to worry about split work here, which is the same as in
+-- those functions.
isSubsetOfX :: Ord a => Set a -> Set a -> Bool
isSubsetOfX Tip _ = True
isSubsetOfX _ Tip = False
+-- Skip the final split when we hit a singleton.
+isSubsetOfX (Bin 1 x _ _) t = member x t
isSubsetOfX (Bin _ x l r) t
- = found && isSubsetOfX l lt && isSubsetOfX r gt
+ = found &&
+ -- Cheap size checks can sometimes save expensive recursive calls when the
+ -- result will be False. Suppose we check whether [1..10] (with root 4) is
+ -- a subset of [0..9]. After the first split, we have to check if [1..3] is
+ -- a subset of [0..3] and if [5..10] is a subset of [5..9]. But we can bail
+ -- immediately because size [5..10] > size [5..9].
+ --
+ -- Why not just call `isSubsetOf` on each side to do the size checks?
+ -- Because that could make a recursive call on the left even though the
+ -- size check would fail on the right. In principle, we could take this to
+ -- extremes by maintaining a queue of pairs of sets to be checked, working
+ -- through the tree level-wise. But that would impose higher administrative
+ -- costs without obvious benefits. It might be worth considering if we find
+ -- a way to use it to tighten the bounds in some useful/comprehensible way.
+ size l <= size lt && size r <= size gt &&
+ isSubsetOfX l lt && isSubsetOfX r gt
where
(lt,found,gt) = splitMember x t
#if __GLASGOW_HASKELL__
@@ -622,19 +667,25 @@ isSubsetOfX (Bin _ x l r) t
{--------------------------------------------------------------------
Disjoint
--------------------------------------------------------------------}
--- | /O(n+m)/. Check whether two sets are disjoint (i.e. their intersection
--- is empty).
+-- | /O(m*log(n\/m + 1)), m <= n/. Check whether two sets are disjoint
+-- (i.e., their intersection is empty).
--
-- > disjoint (fromList [2,4,6]) (fromList [1,3]) == True
-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False
-- > disjoint (fromList [1,2]) (fromList [1,2,3,4]) == False
-- > disjoint (fromList []) (fromList []) == True
--
+-- @
+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)
+-- @
+--
-- @since 0.5.11
disjoint :: Ord a => Set a -> Set a -> Bool
disjoint Tip _ = True
disjoint _ Tip = True
+-- Avoid a split for the singleton case.
+disjoint (Bin 1 x _ _) t = x `notMember` t
disjoint (Bin _ x l r) t
-- Analogous implementation to `subsetOfX`
= not found && disjoint l lt && disjoint r gt
@@ -700,7 +751,7 @@ deleteMax Tip = Tip
{--------------------------------------------------------------------
Union.
--------------------------------------------------------------------}
--- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
+-- | The union of the sets in a Foldable structure : (@'unions' == 'foldl' 'union' 'empty'@).
unions :: (Foldable f, Ord a) => f (Set a) -> Set a
unions = Foldable.foldl' union empty
#if __GLASGOW_HASKELL__
@@ -1698,7 +1749,7 @@ splitRoot orig =
--
-- @
-- powerSet (fromList [1,2,3]) =
--- fromList [[], [1], [2], [3], [1,2], [1,3], [2,3], [1,2,3]]
+-- fromList $ map fromList [[],[1],[1,2],[1,2,3],[1,3],[2],[2,3],[3]]
-- @
--
-- @since 0.5.11
@@ -1706,7 +1757,7 @@ powerSet :: Set a -> Set (Set a)
powerSet xs0 = insertMin empty (foldr' step Tip xs0) where
step x pxs = insertMin (singleton x) (insertMin x `mapMonotonic` pxs) `glue` pxs
--- | Calculate the Cartesian product of two sets.
+-- | /O(m*n)/ (conjectured). Calculate the Cartesian product of two sets.
--
-- @
-- cartesianProduct xs ys = fromList $ liftA2 (,) (toList xs) (toList ys)
@@ -1715,12 +1766,32 @@ powerSet xs0 = insertMin empty (foldr' step Tip xs0) where
-- Example:
--
-- @
--- cartesianProduct (fromList [1,2]) (fromList ['a','b']) =
--- fromList [(1,'a'), (1,'b'), (2,'a'), (2,'b')]
+-- cartesianProduct (fromList [1,2]) (fromList [\'a\',\'b\']) =
+-- fromList [(1,\'a\'), (1,\'b\'), (2,\'a\'), (2,\'b\')]
-- @
--
-- @since 0.5.11
cartesianProduct :: Set a -> Set b -> Set (a, b)
+-- I don't know for sure if this implementation (slightly modified from one
+-- that Edward Kmett hacked together) is optimal. TODO: try to prove or
+-- refute it.
+--
+-- We could definitely get big-O optimal (O(m * n)) in a rather simple way:
+--
+-- cartesianProduct _as Tip = Tip
+-- cartesianProduct as bs = fromDistinctAscList
+-- [(a,b) | a <- toList as, b <- toList bs]
+--
+-- Unfortunately, this is much slower in practice, at least when the sets are
+-- constructed from ascending lists. I tried doing the same thing using a
+-- known-length (perfect balancing) variant of fromDistinctAscList, but it
+-- still didn't come close to the performance of Kmett's version in my very
+-- informal tests.
+
+-- When the second argument has at most one element, we can be a little
+-- clever.
+cartesianProduct !_as Tip = Tip
+cartesianProduct as (Bin 1 b _ _) = mapMonotonic (flip (,) b) as
cartesianProduct as bs =
getMergeSet $ foldMap (\a -> MergeSet $ mapMonotonic ((,) a) bs) as
diff --git a/Data/Tree.hs b/src/Data/Tree.hs
index 3f3a1bb..44bd303 100644
--- a/Data/Tree.hs
+++ b/src/Data/Tree.hs
@@ -81,6 +81,8 @@ import Data.Coerce
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
+#endif
+#if (!MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#endif
@@ -299,7 +301,7 @@ levels t =
-- | Fold a tree into a "summary" value in depth-first order.
--
-- For each node in the tree, apply @f@ to the @rootLabel@ and the result
--- of applying @f@ to each @subForent@.
+-- of applying @f@ to each @subForest@.
--
-- This is also known as the catamorphism on trees.
--
@@ -313,6 +315,18 @@ levels t =
--
-- > foldTree (\x xs -> maximum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 3
--
+-- Count the number of leaves in the tree:
+--
+-- > foldTree (\_ xs -> if null xs then 1 else sum xs) (Node 1 [Node 2 [], Node 3 []]) == 2
+--
+-- Find depth of the tree; i.e. the number of branches from the root of the tree to the furthest leaf:
+--
+-- > foldTree (\_ xs -> if null xs then 0 else 1 + maximum xs) (Node 1 [Node 2[], Node 3 []]) == 1
+--
+-- You can even implement traverse using foldTree:
+--
+-- > traverse' f = foldTree (\x xs -> liftA2 Node (f x) (sequenceA xs))
+--
--
-- @since 0.5.8
foldTree :: (a -> [b] -> b) -> Tree a -> b
diff --git a/Utils/Containers/Internal/BitQueue.hs b/src/Utils/Containers/Internal/BitQueue.hs
index 63c5c62..99d9ea0 100644
--- a/Utils/Containers/Internal/BitQueue.hs
+++ b/src/Utils/Containers/Internal/BitQueue.hs
@@ -17,7 +17,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
diff --git a/Utils/Containers/Internal/BitUtil.hs b/src/Utils/Containers/Internal/BitUtil.hs
index f1d2c94..01cbbe4 100644
--- a/Utils/Containers/Internal/BitUtil.hs
+++ b/src/Utils/Containers/Internal/BitUtil.hs
@@ -24,7 +24,7 @@
--
-- The Package Versioning Policy __does not apply__.
--
--- This contents of this module may change __in any way whatsoever__
+-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
@@ -39,7 +39,11 @@ module Utils.Containers.Internal.BitUtil
) where
import Data.Bits ((.|.), xor)
-import Data.Bits (popCount, unsafeShiftL, unsafeShiftR)
+import Data.Bits (popCount, unsafeShiftL, unsafeShiftR
+#if MIN_VERSION_base(4,8,0)
+ , countLeadingZeros
+#endif
+ )
#if MIN_VERSION_base(4,7,0)
import Data.Bits (finiteBitSize)
#else
@@ -72,6 +76,9 @@ bitcount a x = a + popCount x
-- | Return a word where only the highest bit is set.
highestBitMask :: Word -> Word
+#if MIN_VERSION_base(4,8,0)
+highestBitMask w = shiftLL 1 (wordSize - 1 - countLeadingZeros w)
+#else
highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1
x3 = x2 .|. x2 `shiftRL` 2
x4 = x3 .|. x3 `shiftRL` 4
@@ -83,6 +90,7 @@ highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1
#else
in x6 `xor` (x6 `shiftRL` 1)
#endif
+#endif
{-# INLINE highestBitMask #-}
-- Right and left logical shifts.
diff --git a/Utils/Containers/Internal/Coercions.hs b/src/Utils/Containers/Internal/Coercions.hs
index 6d76eaf..6d76eaf 100644
--- a/Utils/Containers/Internal/Coercions.hs
+++ b/src/Utils/Containers/Internal/Coercions.hs
diff --git a/Utils/Containers/Internal/PtrEquality.hs b/src/Utils/Containers/Internal/PtrEquality.hs
index d6ac879..d6ac879 100644
--- a/Utils/Containers/Internal/PtrEquality.hs
+++ b/src/Utils/Containers/Internal/PtrEquality.hs
diff --git a/Utils/Containers/Internal/State.hs b/src/Utils/Containers/Internal/State.hs
index 0df0415..0df0415 100644
--- a/Utils/Containers/Internal/State.hs
+++ b/src/Utils/Containers/Internal/State.hs
diff --git a/Utils/Containers/Internal/StrictMaybe.hs b/src/Utils/Containers/Internal/StrictMaybe.hs
index ed0e3c9..ed0e3c9 100644
--- a/Utils/Containers/Internal/StrictMaybe.hs
+++ b/src/Utils/Containers/Internal/StrictMaybe.hs
diff --git a/Utils/Containers/Internal/StrictPair.hs b/src/Utils/Containers/Internal/StrictPair.hs
index 5c374e8..5c374e8 100644
--- a/Utils/Containers/Internal/StrictPair.hs
+++ b/src/Utils/Containers/Internal/StrictPair.hs
diff --git a/Utils/Containers/Internal/TypeError.hs b/src/Utils/Containers/Internal/TypeError.hs
index 972918b..972918b 100644
--- a/Utils/Containers/Internal/TypeError.hs
+++ b/src/Utils/Containers/Internal/TypeError.hs
diff --git a/tests/IntMapValidity.hs b/tests/IntMapValidity.hs
deleted file mode 100644
index 9e92ba6..0000000
--- a/tests/IntMapValidity.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-module IntMapValidity (valid) where
-
-import Data.Bits (xor, (.&.))
-import Data.IntMap.Internal
-import Test.QuickCheck (Property, counterexample, property, (.&&.))
-import Utils.Containers.Internal.BitUtil (bitcount)
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | Returns true iff the internal structure of the IntMap is valid.
-valid :: IntMap a -> Property
-valid t =
- counterexample "nilNeverChildOfBin" (nilNeverChildOfBin t) .&&.
- counterexample "commonPrefix" (commonPrefix t) .&&.
- counterexample "maskRespected" (maskRespected t)
-
--- Invariant: Nil is never found as a child of Bin.
-nilNeverChildOfBin :: IntMap a -> Bool
-nilNeverChildOfBin t =
- case t of
- Nil -> True
- Tip _ _ -> True
- Bin _ _ l r -> noNilInSet l && noNilInSet r
- where
- noNilInSet t' =
- case t' of
- Nil -> False
- Tip _ _ -> True
- Bin _ _ l' r' -> noNilInSet l' && noNilInSet r'
-
--- Invariant: The Mask is a power of 2. It is the largest bit position at which
--- two keys of the map differ.
-maskPowerOfTwo :: IntMap a -> Bool
-maskPowerOfTwo t =
- case t of
- Nil -> True
- Tip _ _ -> True
- Bin _ m l r ->
- bitcount 0 (fromIntegral m) == 1 && maskPowerOfTwo l && maskPowerOfTwo r
-
--- Invariant: Prefix is the common high-order bits that all elements share to
--- the left of the Mask bit.
-commonPrefix :: IntMap a -> Bool
-commonPrefix t =
- case t of
- Nil -> True
- Tip _ _ -> True
- b@(Bin p _ l r) -> all (sharedPrefix p) (keys b) && commonPrefix l && commonPrefix r
- where
- sharedPrefix :: Prefix -> Int -> Bool
- sharedPrefix p a = p == p .&. a
-
--- Invariant: In Bin prefix mask left right, left consists of the elements that
--- don't have the mask bit set; right is all the elements that do.
-maskRespected :: IntMap a -> Bool
-maskRespected t =
- case t of
- Nil -> True
- Tip _ _ -> True
- Bin _ binMask l r ->
- all (\x -> zero x binMask) (keys l) &&
- all (\x -> not (zero x binMask)) (keys r) &&
- maskRespected l &&
- maskRespected r
diff --git a/tests/IntSetValidity.hs b/tests/IntSetValidity.hs
deleted file mode 100644
index e12af96..0000000
--- a/tests/IntSetValidity.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-{-# LANGUAGE CPP #-}
-module IntSetValidity (valid) where
-
-import Data.Bits (xor, (.&.))
-import Data.IntSet.Internal
-import Test.QuickCheck (Property, counterexample, property, (.&&.))
-import Utils.Containers.Internal.BitUtil (bitcount)
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | Returns true iff the internal structure of the IntSet is valid.
-valid :: IntSet -> Property
-valid t =
- counterexample "nilNeverChildOfBin" (nilNeverChildOfBin t) .&&.
- counterexample "maskPowerOfTwo" (maskPowerOfTwo t) .&&.
- counterexample "commonPrefix" (commonPrefix t) .&&.
- counterexample "markRespected" (maskRespected t) .&&.
- counterexample "tipsValid" (tipsValid t)
-
--- Invariant: Nil is never found as a child of Bin.
-nilNeverChildOfBin :: IntSet -> Bool
-nilNeverChildOfBin t =
- case t of
- Nil -> True
- Tip _ _ -> True
- Bin _ _ l r -> noNilInSet l && noNilInSet r
- where
- noNilInSet t' =
- case t' of
- Nil -> False
- Tip _ _ -> True
- Bin _ _ l' r' -> noNilInSet l' && noNilInSet r'
-
--- Invariant: The Mask is a power of 2. It is the largest bit position at which
--- two elements of the set differ.
-maskPowerOfTwo :: IntSet -> Bool
-maskPowerOfTwo t =
- case t of
- Nil -> True
- Tip _ _ -> True
- Bin _ m l r ->
- bitcount 0 (fromIntegral m) == 1 && maskPowerOfTwo l && maskPowerOfTwo r
-
--- Invariant: Prefix is the common high-order bits that all elements share to
--- the left of the Mask bit.
-commonPrefix :: IntSet -> Bool
-commonPrefix t =
- case t of
- Nil -> True
- Tip _ _ -> True
- b@(Bin p _ l r) -> all (sharedPrefix p) (elems b) && commonPrefix l && commonPrefix r
- where
- sharedPrefix :: Prefix -> Int -> Bool
- sharedPrefix p a = p == p .&. a
-
--- Invariant: In Bin prefix mask left right, left consists of the elements that
--- don't have the mask bit set; right is all the elements that do.
-maskRespected :: IntSet -> Bool
-maskRespected t =
- case t of
- Nil -> True
- Tip _ _ -> True
- Bin _ binMask l r ->
- all (\x -> zero x binMask) (elems l) &&
- all (\x -> not (zero x binMask)) (elems r) &&
- maskRespected l &&
- maskRespected r
-
--- Invariant: The Prefix is zero for the last 5 (on 32 bit arches) or 6 bits
--- (on 64 bit arches). The values of the set represented by a tip
--- are the prefix plus the indices of the set bits in the bit map.
---
--- Note: Valid entries stored in tip omitted.
-tipsValid :: IntSet -> Bool
-tipsValid t =
- case t of
- Nil -> True
- tip@(Tip p b) -> validTipPrefix p
- Bin _ _ l r -> tipsValid l && tipsValid r
-
-validTipPrefix :: Prefix -> Bool
-#if WORD_SIZE_IN_BITS==32
--- Last 5 bits of the prefix must be zero for 32 bit arches.
-validTipPrefix p = (0x0000001F .&. p) == 0
-#else
--- Last 6 bits of the prefix must be zero 64 bit anches.
-validTipPrefix p = (0x000000000000003F .&. p) == 0
-#endif
diff --git a/tests/Makefile b/tests/Makefile
deleted file mode 100644
index 231c863..0000000
--- a/tests/Makefile
+++ /dev/null
@@ -1,20 +0,0 @@
-# The tests should be compiled and run using cabal:
-# > cabal configure --enable-tests
-# > cabal build
-# > cabal test
-#
-# This Makefile is used by developers to compile the tests manually.
-
-all:
-
-%-properties: %-properties.hs force
- ghc -I../include -O2 -DTESTING $< -i.. -o $@ -outputdir tmp
-
-%-strict-properties: %-properties.hs force
- ghc -I../include -O2 -DTESTING -DSTRICT $< -o $@ -i.. -outputdir tmp
-
-.PHONY: force clean
-force:
-
-clean:
- rm -rf tmp $(patsubst %.hs, %, $(wildcard *-properties.hs)) $(patsubst %-properties.hs, %-strict-properties, $(wildcard *-properties.hs))
diff --git a/tests/bitqueue-properties.hs b/tests/bitqueue-properties.hs
deleted file mode 100644
index 7ee2693..0000000
--- a/tests/bitqueue-properties.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-#endif
-import qualified Data.List as List
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Test.QuickCheck
-import Utils.Containers.Internal.BitUtil (wordSize)
-import Utils.Containers.Internal.BitQueue
- ( BitQueue
- , emptyQB
- , snocQB
- , buildQ
- , toListQ )
-
-default (Int)
-
-main :: IO ()
-main = defaultMain $ map testNum [0..(wordSize - 2)]
-
-testNum :: Int -> Test
-testNum n = testProperty ("Size "++show n) (prop_n n)
-
-prop_n :: Int -> Gen Bool
-prop_n n = checkList <$> vectorOf n (arbitrary :: Gen Bool)
- where
- checkList :: [Bool] -> Bool
- checkList values = toListQ q == values
- where
- q :: BitQueue
- !q = buildQ $ List.foldl' snocQB emptyQB values
diff --git a/tests/graph-properties.hs b/tests/graph-properties.hs
deleted file mode 100644
index ffe4483..0000000
--- a/tests/graph-properties.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-import Data.Graph as G
-
-import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), liftA2)
-
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Test.QuickCheck
-import Test.QuickCheck.Function (Fun (..), apply)
-import Test.QuickCheck.Poly (A, B, C)
-import Control.Monad (ap)
-
-default (Int)
-
-main :: IO ()
-main = defaultMain
- [
- testProperty "monad_id1" prop_monad_id1
- , testProperty "monad_id2" prop_monad_id2
- , testProperty "monad_assoc" prop_monad_assoc
- , testProperty "ap_ap" prop_ap_ap
- , testProperty "ap_liftA2" prop_ap_liftA2
- , testProperty "monadFix_ls" prop_monadFix_ls
- ]
-
-{--------------------------------------------------------------------
- Arbitrary trees
---------------------------------------------------------------------}
-
-newtype G = G Graph
-
--- This instance isn't balanced very well; the trees will probably tend
--- to lean left. But it's better than nothing and we can fix it later.
-instance Arbitrary a => Arbitrary G where
- arbitrary = sized arbgraph
- where
- arbgraph :: Arbitrary a => Int -> Gen G
- arbgraph nv = do
- lo <- arbitrary
- hi <- (lo+) <$> choose (0, nv)
-{-
- arbtree 0 = fmap ((,) 1) $ Node <$> arbitrary <*> pure []
- arbtree n = do
- root <- arbitrary
- num_children <- choose (0, n - 1)
- (st, tl) <- go num_children
- return (1+st, Node root tl)
--}
-
- go 0 = pure (0, [])
- go n = do
- (sh, hd) <- arbtree n
- (st, tl) <- go (n - sh)
- pure (sh + st, hd : tl)
-
--- genericShrink only became available when generics did, so it's
--- not available under GHC 7.0.
-#if __GLASGOW_HASKELL__ >= 704
- shrink = genericShrink
-#endif
-
-----------------------------------------------------------------
--- Unit tests
-----------------------------------------------------------------
-
-----------------------------------------------------------------
--- QuickCheck
-----------------------------------------------------------------
-
-apply2 :: Fun (a, b) c -> a -> b -> c
-apply2 f a b = apply f (a, b)
-
-prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property
-prop_ap_ap fs xs = (apply <$> fs <*> xs) === ((apply <$> fs) `ap` xs)
-
-prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property
-prop_ap_liftA2 f as bs = (apply2 f <$> as <*> bs) === liftA2 (apply2 f) as bs
-
-prop_monad_id1 :: Tree A -> Property
-prop_monad_id1 t = (t >>= pure) === t
-
-prop_monad_id2 :: A -> Fun A (Tree B) -> Property
-prop_monad_id2 a f = (pure a >>= apply f) === apply f a
-
-prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property
-prop_monad_assoc ta atb btc =
- ((ta >>= apply atb) >>= apply btc)
- ===
- (ta >>= \a -> apply atb a >>= apply btc)
-
--- The left shrinking law
---
--- This test is kind of wonky and unprincipled, because it's
--- rather tricky to construct test cases!
--- This is the most important MonadFix law to test because it's the
--- least intuitive by far, and because it's the only one that's
--- sensitive to the Monad instance.
-prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property
-prop_monadFix_ls val ta ti =
- fmap ($val) (mfix (\x -> ta >>= \y -> f x y))
- ===
- fmap ($val) (ta >>= \y -> mfix (\x -> f x y))
- where
- fact :: Int -> (Int -> Int) -> Int -> Int
- fact x _ 0 = x + 1
- fact x f n = x + n * f ((n - 1) `mod` 23)
-
- f :: (Int -> Int) -> Int -> Tree (Int -> Int)
- f q y = let t = apply ti y
- in fmap (\w -> fact w q) t
diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs
deleted file mode 100644
index 18c55e6..0000000
--- a/tests/intmap-properties.hs
+++ /dev/null
@@ -1,1166 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-#ifdef STRICT
-import Data.IntMap.Strict as Data.IntMap hiding (showTree)
-#else
-import Data.IntMap.Lazy as Data.IntMap hiding (showTree)
-#endif
-import Data.IntMap.Internal.Debug (showTree)
-import IntMapValidity (valid)
-
-import Data.Monoid
-import Data.Maybe hiding (mapMaybe)
-import qualified Data.Maybe as Maybe (mapMaybe)
-import Data.Ord
-import Data.Function
-import Prelude hiding (lookup, null, map, filter, foldr, foldl)
-import qualified Prelude (map)
-
-import Data.List (nub,sort)
-import qualified Data.List as List
-import qualified Data.IntSet as IntSet
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2
-import Test.HUnit hiding (Test, Testable)
-import Test.QuickCheck
-import Test.QuickCheck.Function (Fun(..), apply)
-
-default (Int)
-
-main :: IO ()
-main = defaultMain
- [
- testCase "index" test_index
- , testCase "index_lookup" test_index_lookup
- , testCase "size" test_size
- , testCase "size2" test_size2
- , testCase "member" test_member
- , testCase "notMember" test_notMember
- , testCase "lookup" test_lookup
- , testCase "findWithDefault" test_findWithDefault
- , testCase "lookupLT" test_lookupLT
- , testCase "lookupGT" test_lookupGT
- , testCase "lookupLE" test_lookupLE
- , testCase "lookupGE" test_lookupGE
- , testCase "empty" test_empty
- , testCase "mempty" test_mempty
- , testCase "singleton" test_singleton
- , testCase "insert" test_insert
- , testCase "insertWith" test_insertWith
- , testCase "insertWithKey" test_insertWithKey
- , testCase "insertLookupWithKey" test_insertLookupWithKey
- , testCase "delete" test_delete
- , testCase "adjust" test_adjust
- , testCase "adjustWithKey" test_adjustWithKey
- , testCase "update" test_update
- , testCase "updateWithKey" test_updateWithKey
- , testCase "updateLookupWithKey" test_updateLookupWithKey
- , testCase "alter" test_alter
- , testCase "union" test_union
- , testCase "mappend" test_mappend
- , testCase "unionWith" test_unionWith
- , testCase "unionWithKey" test_unionWithKey
- , testCase "unions" test_unions
- , testCase "mconcat" test_mconcat
- , testCase "unionsWith" test_unionsWith
- , testCase "difference" test_difference
- , testCase "differenceWith" test_differenceWith
- , testCase "differenceWithKey" test_differenceWithKey
- , testCase "intersection" test_intersection
- , testCase "intersectionWith" test_intersectionWith
- , testCase "intersectionWithKey" test_intersectionWithKey
- , testCase "map" test_map
- , testCase "mapWithKey" test_mapWithKey
- , testCase "mapAccum" test_mapAccum
- , testCase "mapAccumWithKey" test_mapAccumWithKey
- , testCase "mapAccumRWithKey" test_mapAccumRWithKey
- , testCase "mapKeys" test_mapKeys
- , testCase "mapKeysWith" test_mapKeysWith
- , testCase "mapKeysMonotonic" test_mapKeysMonotonic
- , testCase "elems" test_elems
- , testCase "keys" test_keys
- , testCase "assocs" test_assocs
- , testCase "keysSet" test_keysSet
- , testCase "keysSet" test_fromSet
- , testCase "toList" test_toList
- , testCase "fromList" test_fromList
- , testCase "fromListWith" test_fromListWith
- , testCase "fromListWithKey" test_fromListWithKey
- , testCase "toAscList" test_toAscList
- , testCase "toDescList" test_toDescList
- , testCase "showTree" test_showTree
- , testCase "fromAscList" test_fromAscList
- , testCase "fromAscListWith" test_fromAscListWith
- , testCase "fromAscListWithKey" test_fromAscListWithKey
- , testCase "fromDistinctAscList" test_fromDistinctAscList
- , testCase "filter" test_filter
- , testCase "filterWithKey" test_filteWithKey
- , testCase "partition" test_partition
- , testCase "partitionWithKey" test_partitionWithKey
- , testCase "mapMaybe" test_mapMaybe
- , testCase "mapMaybeWithKey" test_mapMaybeWithKey
- , testCase "mapEither" test_mapEither
- , testCase "mapEitherWithKey" test_mapEitherWithKey
- , testCase "split" test_split
- , testCase "splitLookup" test_splitLookup
- , testCase "isSubmapOfBy" test_isSubmapOfBy
- , testCase "isSubmapOf" test_isSubmapOf
- , testCase "isProperSubmapOfBy" test_isProperSubmapOfBy
- , testCase "isProperSubmapOf" test_isProperSubmapOf
- , testCase "lookupMin" test_lookupMin
- , testCase "lookupMax" test_lookupMax
- , testCase "findMin" test_findMin
- , testCase "findMax" test_findMax
- , testCase "deleteMin" test_deleteMin
- , testCase "deleteMax" test_deleteMax
- , testCase "deleteFindMin" test_deleteFindMin
- , testCase "deleteFindMax" test_deleteFindMax
- , testCase "updateMin" test_updateMin
- , testCase "updateMax" test_updateMax
- , testCase "updateMinWithKey" test_updateMinWithKey
- , testCase "updateMaxWithKey" test_updateMaxWithKey
- , testCase "minView" test_minView
- , testCase "maxView" test_maxView
- , testCase "minViewWithKey" test_minViewWithKey
- , testCase "maxViewWithKey" test_maxViewWithKey
- , testProperty "valid" prop_valid
- , testProperty "empty valid" prop_emptyValid
- , testProperty "insert to singleton" prop_singleton
- , testProperty "insert then lookup" prop_insertLookup
- , testProperty "insert then delete" prop_insertDelete
- , testProperty "delete non member" prop_deleteNonMember
- , testProperty "union model" prop_unionModel
- , testProperty "union singleton" prop_unionSingleton
- , testProperty "union associative" prop_unionAssoc
- , testProperty "union+unionWith" prop_unionWith
- , testProperty "union sum" prop_unionSum
- , testProperty "difference model" prop_differenceModel
- , testProperty "intersection model" prop_intersectionModel
- , testProperty "intersectionWith model" prop_intersectionWithModel
- , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel
- , testProperty "mergeWithKey model" prop_mergeWithKeyModel
- , testProperty "fromAscList" prop_ordered
- , testProperty "fromList then toList" prop_list
- , testProperty "toDescList" prop_descList
- , testProperty "toAscList+toDescList" prop_ascDescList
- , testProperty "fromList" prop_fromList
- , testProperty "alter" prop_alter
- , testProperty "index" prop_index
- , testProperty "index_lookup" prop_index_lookup
- , testProperty "null" prop_null
- , testProperty "size" prop_size
- , testProperty "member" prop_member
- , testProperty "notmember" prop_notmember
- , testProperty "lookup" prop_lookup
- , testProperty "find" prop_find
- , testProperty "findWithDefault" prop_findWithDefault
- , testProperty "lookupLT" prop_lookupLT
- , testProperty "lookupGT" prop_lookupGT
- , testProperty "lookupLE" prop_lookupLE
- , testProperty "lookupGE" prop_lookupGE
- , testProperty "lookupMin" prop_lookupMin
- , testProperty "lookupMax" prop_lookupMax
- , testProperty "findMin" prop_findMin
- , testProperty "findMax" prop_findMax
- , testProperty "deleteMin" prop_deleteMinModel
- , testProperty "deleteMax" prop_deleteMaxModel
- , testProperty "filter" prop_filter
- , testProperty "partition" prop_partition
- , testProperty "map" prop_map
- , testProperty "fmap" prop_fmap
- , testProperty "mapkeys" prop_mapkeys
- , testProperty "split" prop_splitModel
- , testProperty "splitRoot" prop_splitRoot
- , testProperty "foldr" prop_foldr
- , testProperty "foldr'" prop_foldr'
- , testProperty "foldl" prop_foldl
- , testProperty "foldl'" prop_foldl'
- , testProperty "keysSet" prop_keysSet
- , testProperty "fromSet" prop_fromSet
- , testProperty "restrictKeys" prop_restrictKeys
- , testProperty "withoutKeys" prop_withoutKeys
- ]
-
-apply2 :: Fun (a, b) c -> a -> b -> c
-apply2 f a b = apply f (a, b)
-
-apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
-apply3 f a b c = apply f (a, b, c)
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-
-instance Arbitrary a => Arbitrary (IntMap a) where
- arbitrary = do{ ks <- arbitrary
- ; xs <- arbitrary
- ; return (fromList (zip xs ks))
- }
-
-newtype NonEmptyIntMap a = NonEmptyIntMap {getNonEmptyIntMap :: IntMap a} deriving (Eq, Show)
-
-instance Arbitrary a => Arbitrary (NonEmptyIntMap a) where
- arbitrary = fmap (NonEmptyIntMap . fromList . getNonEmpty) arbitrary
-
-
-------------------------------------------------------------------------
-
-type UMap = IntMap ()
-type IMap = IntMap Int
-type SMap = IntMap String
-
-----------------------------------------------------------------
-
-tests :: [Test]
-tests = [ testGroup "Test Case" [
- ]
- , testGroup "Property Test" [
- ]
- ]
-
-
-----------------------------------------------------------------
--- Unit tests
-----------------------------------------------------------------
-
-----------------------------------------------------------------
--- Operators
-
-test_index :: Assertion
-test_index = fromList [(5,'a'), (3,'b')] ! 5 @?= 'a'
-
-test_index_lookup :: Assertion
-test_index_lookup = do
- fromList [(5,'a'), (3,'b')] !? 1 @?= Nothing
- fromList [(5,'a'), (3,'b')] !? 5 @?= Just 'a'
-
-----------------------------------------------------------------
--- Query
-
-test_size :: Assertion
-test_size = do
- null (empty) @?= True
- null (singleton 1 'a') @?= False
-
-test_size2 :: Assertion
-test_size2 = do
- size empty @?= 0
- size (singleton 1 'a') @?= 1
- size (fromList([(1,'a'), (2,'c'), (3,'b')])) @?= 3
-
-test_member :: Assertion
-test_member = do
- member 5 (fromList [(5,'a'), (3,'b')]) @?= True
- member 1 (fromList [(5,'a'), (3,'b')]) @?= False
-
-test_notMember :: Assertion
-test_notMember = do
- notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False
- notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True
-
-test_lookup :: Assertion
-test_lookup = do
- employeeCurrency 1 @?= Just 1
- employeeCurrency 2 @?= Nothing
- where
- employeeDept = fromList([(1,2), (3,1)])
- deptCountry = fromList([(1,1), (2,2)])
- countryCurrency = fromList([(1, 2), (2, 1)])
- employeeCurrency :: Int -> Maybe Int
- employeeCurrency name = do
- dept <- lookup name employeeDept
- country <- lookup dept deptCountry
- lookup country countryCurrency
-
-test_findWithDefault :: Assertion
-test_findWithDefault = do
- findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x'
- findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a'
-
-test_lookupLT :: Assertion
-test_lookupLT = do
- lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing
- lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')
-
-test_lookupGT :: Assertion
-test_lookupGT = do
- lookupGT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')
- lookupGT 5 (fromList [(3,'a'), (5,'b')]) @?= Nothing
-
-test_lookupLE :: Assertion
-test_lookupLE = do
- lookupLE 2 (fromList [(3,'a'), (5,'b')]) @?= Nothing
- lookupLE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')
- lookupLE 5 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')
-
-test_lookupGE :: Assertion
-test_lookupGE = do
- lookupGE 3 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')
- lookupGE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')
- lookupGE 6 (fromList [(3,'a'), (5,'b')]) @?= Nothing
-
-----------------------------------------------------------------
--- Construction
-
-test_empty :: Assertion
-test_empty = do
- (empty :: UMap) @?= fromList []
- size empty @?= 0
-
-test_mempty :: Assertion
-test_mempty = do
- (mempty :: UMap) @?= fromList []
- size (mempty :: UMap) @?= 0
-
-test_singleton :: Assertion
-test_singleton = do
- singleton 1 'a' @?= fromList [(1, 'a')]
- size (singleton 1 'a') @?= 1
-
-test_insert :: Assertion
-test_insert = do
- insert 5 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'x')]
- insert 7 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'a'), (7, 'x')]
- insert 5 'x' empty @?= singleton 5 'x'
-
-test_insertWith :: Assertion
-test_insertWith = do
- insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "xxxa")]
- insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")]
- insertWith (++) 5 "xxx" empty @?= singleton 5 "xxx"
-
-test_insertWithKey :: Assertion
-test_insertWithKey = do
- insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:xxx|a")]
- insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")]
- insertWithKey f 5 "xxx" empty @?= singleton 5 "xxx"
- where
- f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
-
-test_insertLookupWithKey :: Assertion
-test_insertLookupWithKey = do
- insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
- insertLookupWithKey f 2 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing,fromList [(2,"xxx"),(3,"b"),(5,"a")])
- insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
- insertLookupWithKey f 5 "xxx" empty @?= (Nothing, singleton 5 "xxx")
- where
- f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
-
-----------------------------------------------------------------
--- Delete/Update
-
-test_delete :: Assertion
-test_delete = do
- delete 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- delete 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- delete 5 empty @?= (empty :: IMap)
-
-test_adjust :: Assertion
-test_adjust = do
- adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")]
- adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- adjust ("new " ++) 7 empty @?= empty
-
-test_adjustWithKey :: Assertion
-test_adjustWithKey = do
- adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")]
- adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- adjustWithKey f 7 empty @?= empty
- where
- f key x = (show key) ++ ":new " ++ x
-
-test_update :: Assertion
-test_update = do
- update f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")]
- update f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- update f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
- where
- f x = if x == "a" then Just "new a" else Nothing
-
-test_updateWithKey :: Assertion
-test_updateWithKey = do
- updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")]
- updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
- where
- f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
-
-test_updateLookupWithKey :: Assertion
-test_updateLookupWithKey = do
- updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:new a")])
- updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a")])
- updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= (Just "b", singleton 5 "a")
- where
- f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
-
-test_alter :: Assertion
-test_alter = do
- alter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- alter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")]
- alter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")]
- where
- f _ = Nothing
- g _ = Just "c"
-
-----------------------------------------------------------------
--- Combine
-
-test_union :: Assertion
-test_union = union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]
-
-test_mappend :: Assertion
-test_mappend = mappend (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]
-
-test_unionWith :: Assertion
-test_unionWith = unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")]
-
-test_unionWithKey :: Assertion
-test_unionWithKey = unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
- where
- f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
-
-test_unions :: Assertion
-test_unions = do
- unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
- @?= fromList [(3, "b"), (5, "a"), (7, "C")]
- unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
- @?= fromList [(3, "B3"), (5, "A3"), (7, "C")]
-
-test_mconcat :: Assertion
-test_mconcat = do
- mconcat [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
- @?= fromList [(3, "b"), (5, "a"), (7, "C")]
- mconcat [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
- @?= fromList [(3, "B3"), (5, "A3"), (7, "C")]
-
-test_unionsWith :: Assertion
-test_unionsWith = unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
- @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
-
-test_difference :: Assertion
-test_difference = difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b"
-
-test_differenceWith :: Assertion
-test_differenceWith = differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
- @?= singleton 3 "b:B"
- where
- f al ar = if al== "b" then Just (al ++ ":" ++ ar) else Nothing
-
-test_differenceWithKey :: Assertion
-test_differenceWithKey = differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
- @?= singleton 3 "3:b|B"
- where
- f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
-
-test_intersection :: Assertion
-test_intersection = intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a"
-
-
-test_intersectionWith :: Assertion
-test_intersectionWith = intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA"
-
-test_intersectionWithKey :: Assertion
-test_intersectionWithKey = intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A"
- where
- f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
-
-----------------------------------------------------------------
--- Traversal
-
-test_map :: Assertion
-test_map = map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")]
-
-test_mapWithKey :: Assertion
-test_mapWithKey = mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")]
- where
- f key x = (show key) ++ ":" ++ x
-
-test_mapAccum :: Assertion
-test_mapAccum = mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
- where
- f a b = (a ++ b, b ++ "X")
-
-test_mapAccumWithKey :: Assertion
-test_mapAccumWithKey = mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
- where
- f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
-
-test_mapAccumRWithKey :: Assertion
-test_mapAccumRWithKey = mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")])
- where
- f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
-
-test_mapKeys :: Assertion
-test_mapKeys = do
- mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")]
- mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "c"
- mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "c"
-
-test_mapKeysWith :: Assertion
-test_mapKeysWith = do
- mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "cdab"
- mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "cdab"
-
-test_mapKeysMonotonic :: Assertion
-test_mapKeysMonotonic = do
- mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")]
- mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")]
-
-----------------------------------------------------------------
--- Conversion
-
-test_elems :: Assertion
-test_elems = do
- elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"]
- elems (empty :: UMap) @?= []
-
-test_keys :: Assertion
-test_keys = do
- keys (fromList [(5,"a"), (3,"b")]) @?= [3,5]
- keys (empty :: UMap) @?= []
-
-test_assocs :: Assertion
-test_assocs = do
- assocs (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]
- assocs (empty :: UMap) @?= []
-
-test_keysSet :: Assertion
-test_keysSet = do
- keysSet (fromList [(5,"a"), (3,"b")]) @?= IntSet.fromList [3,5]
- keysSet (empty :: UMap) @?= IntSet.empty
-
-test_fromSet :: Assertion
-test_fromSet = do
- fromSet (\k -> replicate k 'a') (IntSet.fromList [3, 5]) @?= fromList [(5,"aaaaa"), (3,"aaa")]
- fromSet undefined IntSet.empty @?= (empty :: IMap)
-
-----------------------------------------------------------------
--- Lists
-
-test_toList :: Assertion
-test_toList = do
- toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]
- toList (empty :: SMap) @?= []
-
-test_fromList :: Assertion
-test_fromList = do
- fromList [] @?= (empty :: SMap)
- fromList [(5,"a"), (3,"b"), (5, "c")] @?= fromList [(5,"c"), (3,"b")]
- fromList [(5,"c"), (3,"b"), (5, "a")] @?= fromList [(5,"a"), (3,"b")]
-
-test_fromListWith :: Assertion
-test_fromListWith = do
- fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "ab"), (5, "aba")]
- fromListWith (++) [] @?= (empty :: SMap)
-
-test_fromListWithKey :: Assertion
-test_fromListWithKey = do
- fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "3ab"), (5, "5a5ba")]
- fromListWithKey f [] @?= (empty :: SMap)
- where
- f k a1 a2 = (show k) ++ a1 ++ a2
-
-----------------------------------------------------------------
--- Ordered lists
-
-test_toAscList :: Assertion
-test_toAscList = toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]
-
-test_toDescList :: Assertion
-test_toDescList = toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")]
-
-test_showTree :: Assertion
-test_showTree =
- (let t = fromDistinctAscList [(x,()) | x <- [1..5]]
- in showTree t) @?= "*\n+--*\n| +-- 1:=()\n| +--*\n| +-- 2:=()\n| +-- 3:=()\n+--*\n +-- 4:=()\n +-- 5:=()\n"
-
-test_fromAscList :: Assertion
-test_fromAscList = do
- fromAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")]
- fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")]
-
-
-test_fromAscListWith :: Assertion
-test_fromAscListWith = do
- fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")]
-
-test_fromAscListWithKey :: Assertion
-test_fromAscListWithKey = do
- fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b5:ba")]
- where
- f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
-
-test_fromDistinctAscList :: Assertion
-test_fromDistinctAscList = do
- fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")]
-
-----------------------------------------------------------------
--- Filter
-
-test_filter :: Assertion
-test_filter = do
- filter (> "a") (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- filter (> "x") (fromList [(5,"a"), (3,"b")]) @?= empty
- filter (< "a") (fromList [(5,"a"), (3,"b")]) @?= empty
-
-test_filteWithKey :: Assertion
-test_filteWithKey = filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
-
-test_partition :: Assertion
-test_partition = do
- partition (> "a") (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a")
- partition (< "x") (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty)
- partition (> "x") (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")])
-
-test_partitionWithKey :: Assertion
-test_partitionWithKey = do
- partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) @?= (singleton 5 "a", singleton 3 "b")
- partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty)
- partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")])
-
-test_mapMaybe :: Assertion
-test_mapMaybe = mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a"
- where
- f x = if x == "a" then Just "new a" else Nothing
-
-test_mapMaybeWithKey :: Assertion
-test_mapMaybeWithKey = mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3"
- where
- f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
-
-test_mapEither :: Assertion
-test_mapEither = do
- mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
- mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= ((empty :: SMap), fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- where
- f a = if a < "c" then Left a else Right a
-
-test_mapEitherWithKey :: Assertion
-test_mapEitherWithKey = do
- mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
- mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= ((empty :: SMap), fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
- where
- f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
-
-test_split :: Assertion
-test_split = do
- split 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3,"b"), (5,"a")])
- split 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, singleton 5 "a")
- split 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a")
- split 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", empty)
- split 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], empty)
-
-test_splitLookup :: Assertion
-test_splitLookup = do
- splitLookup 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, Nothing, fromList [(3,"b"), (5,"a")])
- splitLookup 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, Just "b", singleton 5 "a")
- splitLookup 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Nothing, singleton 5 "a")
- splitLookup 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Just "a", empty)
- splitLookup 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], Nothing, empty)
-
-----------------------------------------------------------------
--- Submap
-
-test_isSubmapOfBy :: Assertion
-test_isSubmapOfBy = do
- isSubmapOfBy (==) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True
- isSubmapOfBy (<=) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True
- isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True
- isSubmapOfBy (==) (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False
- isSubmapOfBy (<) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False
- isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1)]) @?= False
-
-test_isSubmapOf :: Assertion
-test_isSubmapOf = do
- isSubmapOf (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True
- isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True
- isSubmapOf (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False
- isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1)]) @?= False
-
-test_isProperSubmapOfBy :: Assertion
-test_isProperSubmapOfBy = do
- isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
- isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
- isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False
- isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False
- isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= False
-
-test_isProperSubmapOf :: Assertion
-test_isProperSubmapOf = do
- isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
- isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False
- isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False
-
-----------------------------------------------------------------
--- Min/Max
-
-test_lookupMin :: Assertion
-test_lookupMin = do
- lookupMin (fromList [(5,"a"), (3,"b")]) @?= Just (3,"b")
- lookupMin (empty :: SMap) @?= Nothing
-
-test_lookupMax :: Assertion
-test_lookupMax = do
- lookupMax (fromList [(5,"a"), (3,"b")]) @?= Just (5,"a")
- lookupMax (empty :: SMap) @?= Nothing
-
-test_findMin :: Assertion
-test_findMin = findMin (fromList [(5,"a"), (3,"b")]) @?= (3,"b")
-
-test_findMax :: Assertion
-test_findMax = findMax (fromList [(5,"a"), (3,"b")]) @?= (5,"a")
-
-test_deleteMin :: Assertion
-test_deleteMin = do
- deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(5,"a"), (7,"c")]
- deleteMin (empty :: SMap) @?= empty
-
-test_deleteMax :: Assertion
-test_deleteMax = do
- deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(3,"b"), (5,"a")]
- deleteMax (empty :: SMap) @?= empty
-
-test_deleteFindMin :: Assertion
-test_deleteFindMin = deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((3,"b"), fromList[(5,"a"), (10,"c")])
-
-test_deleteFindMax :: Assertion
-test_deleteFindMax = deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((10,"c"), fromList [(3,"b"), (5,"a")])
-
-test_updateMin :: Assertion
-test_updateMin = do
- updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "Xb"), (5, "a")]
- updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
-
-test_updateMax :: Assertion
-test_updateMax = do
- updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "Xa")]
- updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
-
-test_updateMinWithKey :: Assertion
-test_updateMinWithKey = do
- updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"3:b"), (5,"a")]
- updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
-
-test_updateMaxWithKey :: Assertion
-test_updateMaxWithKey = do
- updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"b"), (5,"5:a")]
- updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
-
-test_minView :: Assertion
-test_minView = do
- minView (fromList [(5,"a"), (3,"b")]) @?= Just ("b", singleton 5 "a")
- minView (empty :: SMap) @?= Nothing
-
-test_maxView :: Assertion
-test_maxView = do
- maxView (fromList [(5,"a"), (3,"b")]) @?= Just ("a", singleton 3 "b")
- maxView (empty :: SMap) @?= Nothing
-
-test_minViewWithKey :: Assertion
-test_minViewWithKey = do
- minViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((3,"b"), singleton 5 "a")
- minViewWithKey (empty :: SMap) @?= Nothing
-
-test_maxViewWithKey :: Assertion
-test_maxViewWithKey = do
- maxViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((5,"a"), singleton 3 "b")
- maxViewWithKey (empty :: SMap) @?= Nothing
-
-----------------------------------------------------------------
--- Valid IntMaps
-----------------------------------------------------------------
-
-forValid :: Testable b => (SMap -> b) -> Property
-forValid f = forAll arbitrary $ \t ->
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $ f t
-
-forValidUnitTree :: Testable b => (SMap -> b) -> Property
-forValidUnitTree f = forValid f
-
-prop_valid :: Property
-prop_valid = forValidUnitTree $ \t -> valid t
-
-----------------------------------------------------------------
--- QuickCheck
-----------------------------------------------------------------
-
-prop_emptyValid :: Property
-prop_emptyValid = valid empty
-
-prop_singleton :: Int -> Int -> Property
-prop_singleton k x =
- case singleton k x of
- s ->
- valid s .&&.
- s === insert k x empty
-
-prop_insertLookup :: Int -> UMap -> Bool
-prop_insertLookup k t = lookup k (insert k () t) /= Nothing
-
-prop_insertDelete :: Int -> UMap -> Property
-prop_insertDelete k t =
- lookup k t == Nothing ==>
- case delete k (insert k () t) of
- t' -> valid t' .&&. t' === t
-
-prop_deleteNonMember :: Int -> UMap -> Property
-prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t)
-
-----------------------------------------------------------------
-
-prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Property
-prop_unionModel xs ys =
- case union (fromList xs) (fromList ys) of
- t ->
- valid t .&&.
- sort (keys t) === sort (nub (Prelude.map fst xs ++ Prelude.map fst ys))
-
-prop_unionSingleton :: IMap -> Int -> Int -> Bool
-prop_unionSingleton t k x = union (singleton k x) t == insert k x t
-
-prop_unionAssoc :: IMap -> IMap -> IMap -> Bool
-prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_unionWith :: IMap -> IMap -> Bool
-prop_unionWith t1 t2 = (union t1 t2 == unionWith (\_ y -> y) t2 t1)
-
-prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_unionSum xs ys
- = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
- == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
-
-prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Property
-prop_differenceModel xs ys =
- case difference (fromListWith (+) xs) (fromListWith (+) ys) of
- t ->
- valid t .&&.
- sort (keys t) === sort ((List.\\)
- (nub (Prelude.map fst xs))
- (nub (Prelude.map fst ys)))
-
-prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Property
-prop_intersectionModel xs ys =
- case intersection (fromListWith (+) xs) (fromListWith (+) ys) of
- t ->
- valid t .&&.
- sort (keys t) === sort (nub ((List.intersect)
- (Prelude.map fst xs)
- (Prelude.map fst ys)))
-
-prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_intersectionWithModel xs ys
- = toList (intersectionWith f (fromList xs') (fromList ys'))
- == [(kx, f vx vy ) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]
- where xs' = List.nubBy ((==) `on` fst) xs
- ys' = List.nubBy ((==) `on` fst) ys
- f l r = l + 2 * r
-
-prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_intersectionWithKeyModel xs ys
- = toList (intersectionWithKey f (fromList xs') (fromList ys'))
- == [(kx, f kx vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]
- where xs' = List.nubBy ((==) `on` fst) xs
- ys' = List.nubBy ((==) `on` fst) ys
- f k l r = k + 2 * l + 3 * r
-
--- TODO: the second argument should be simply an 'IntSet', but that
--- runs afoul of our orphan instance.
-prop_restrictKeys :: IMap -> IMap -> Property
-prop_restrictKeys m s0 =
- m `restrictKeys` s === filterWithKey (\k _ -> k `IntSet.member` s) m
- where
- s = keysSet s0
-
--- TODO: the second argument should be simply an 'IntSet', but that
--- runs afoul of our orphan instance.
-prop_withoutKeys :: IMap -> IMap -> Property
-prop_withoutKeys m s0 =
- m `withoutKeys` s === filterWithKey (\k _ -> k `IntSet.notMember` s) m
- where
- s = keysSet s0
-
-prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_mergeWithKeyModel xs ys
- = and [ testMergeWithKey f keep_x keep_y
- | f <- [ \_k x1 _x2 -> Just x1
- , \_k _x1 x2 -> Just x2
- , \_k _x1 _x2 -> Nothing
- , \k x1 x2 -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2)
- ]
- , keep_x <- [ True, False ]
- , keep_y <- [ True, False ]
- ]
-
- where xs' = List.nubBy ((==) `on` fst) xs
- ys' = List.nubBy ((==) `on` fst) ys
-
- xm = fromList xs'
- ym = fromList ys'
-
- testMergeWithKey f keep_x keep_y
- = toList (mergeWithKey f (keep keep_x) (keep keep_y) xm ym) == emulateMergeWithKey f keep_x keep_y
- where keep False _ = empty
- keep True m = m
-
- emulateMergeWithKey f keep_x keep_y
- = Maybe.mapMaybe combine (sort $ List.union (List.map fst xs') (List.map fst ys'))
- where combine k = case (List.lookup k xs', List.lookup k ys') of
- (Nothing, Just y) -> if keep_y then Just (k, y) else Nothing
- (Just x, Nothing) -> if keep_x then Just (k, x) else Nothing
- (Just x, Just y) -> (\v -> (k, v)) `fmap` f k x y
-
- -- We prevent inlining testMergeWithKey to disable the SpecConstr
- -- optimalization. There are too many call patterns here so several
- -- warnings are issued if testMergeWithKey gets inlined.
- {-# NOINLINE testMergeWithKey #-}
-
-----------------------------------------------------------------
-
-prop_ordered :: Property
-prop_ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromAscList xs == fromList xs
-
-prop_list :: [Int] -> Bool
-prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
-
-prop_descList :: [Int] -> Bool
-prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])])
-
-prop_ascDescList :: [Int] -> Bool
-prop_ascDescList xs = toAscList m == reverse (toDescList m)
- where m = fromList $ zip xs $ repeat ()
-
-prop_fromList :: [Int] -> Property
-prop_fromList xs
- = case fromList (zip xs xs) of
- t -> valid t .&&.
- t === fromAscList (zip sort_xs sort_xs) .&&.
- t === fromDistinctAscList (zip nub_sort_xs nub_sort_xs) .&&.
- t === List.foldr (uncurry insert) empty (zip xs xs)
- where sort_xs = sort xs
- nub_sort_xs = List.map List.head $ List.group sort_xs
-
-----------------------------------------------------------------
-
-prop_alter :: UMap -> Int -> Property
-prop_alter t k = valid t' .&&. case lookup k t of
- Just _ -> (size t - 1) == size t' && lookup k t' == Nothing
- Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing
- where
- t' = alter f k t
- f Nothing = Just ()
- f (Just ()) = Nothing
-
-------------------------------------------------------------------------
--- Compare against the list model (after nub on keys)
-
-prop_index :: [Int] -> Property
-prop_index xs = length xs > 0 ==>
- let m = fromList (zip xs xs)
- in xs == [ m ! i | i <- xs ]
-
-prop_index_lookup :: [Int] -> Property
-prop_index_lookup xs = length xs > 0 ==>
- let m = fromList (zip xs xs)
- in (Prelude.map Just xs) == [ m !? i | i <- xs ]
-
-prop_null :: IMap -> Bool
-prop_null m = null m == (size m == 0)
-
-prop_size :: UMap -> Property
-prop_size im = sz === foldl' (\i _ -> i + 1) (0 :: Int) im .&&.
- sz === List.length (toList im)
- where sz = size im
-
-prop_member :: [Int] -> Int -> Bool
-prop_member xs n =
- let m = fromList (zip xs xs)
- in all (\k -> k `member` m == (k `elem` xs)) (n : xs)
-
-prop_notmember :: [Int] -> Int -> Bool
-prop_notmember xs n =
- let m = fromList (zip xs xs)
- in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)
-
-prop_lookup :: [(Int, Int)] -> Int -> Bool
-prop_lookup xs n =
- let xs' = List.nubBy ((==) `on` fst) xs
- m = fromList xs'
- in all (\k -> lookup k m == List.lookup k xs') (n : List.map fst xs')
-
-prop_find :: [(Int, Int)] -> Bool
-prop_find xs =
- let xs' = List.nubBy ((==) `on` fst) xs
- m = fromList xs'
- in all (\(k, v) -> m ! k == v) xs'
-
-prop_findWithDefault :: [(Int, Int)] -> Int -> Int -> Bool
-prop_findWithDefault xs n x =
- let xs' = List.nubBy ((==) `on` fst) xs
- m = fromList xs'
- in all (\k -> findWithDefault x k m == maybe x id (List.lookup k xs')) (n : List.map fst xs')
-
-test_lookupSomething :: (Int -> IntMap Int -> Maybe (Int, Int)) -> (Int -> Int -> Bool) -> [(Int, Int)] -> Bool
-test_lookupSomething lookup' cmp xs =
- let odd_sorted_xs = filter_odd $ sort $ List.nubBy ((==) `on` fst) xs
- t = fromList odd_sorted_xs
- test k = case List.filter ((`cmp` k) . fst) odd_sorted_xs of
- [] -> lookup' k t == Nothing
- cs | 0 `cmp` 1 -> lookup' k t == Just (last cs) -- we want largest such element
- | otherwise -> lookup' k t == Just (head cs) -- we want smallest such element
- in all test (List.map fst xs)
-
- where filter_odd [] = []
- filter_odd [_] = []
- filter_odd (_ : o : xs) = o : filter_odd xs
-
-prop_lookupLT :: [(Int, Int)] -> Bool
-prop_lookupLT = test_lookupSomething lookupLT (<)
-
-prop_lookupGT :: [(Int, Int)] -> Bool
-prop_lookupGT = test_lookupSomething lookupGT (>)
-
-prop_lookupLE :: [(Int, Int)] -> Bool
-prop_lookupLE = test_lookupSomething lookupLE (<=)
-
-prop_lookupGE :: [(Int, Int)] -> Bool
-prop_lookupGE = test_lookupSomething lookupGE (>=)
-
-prop_lookupMin :: IntMap Int -> Property
-prop_lookupMin im = lookupMin im === listToMaybe (toAscList im)
-
-prop_lookupMax :: IntMap Int -> Property
-prop_lookupMax im = lookupMax im === listToMaybe (toDescList im)
-
-prop_findMin :: NonEmptyIntMap Int -> Property
-prop_findMin (NonEmptyIntMap im) = findMin im === head (toAscList im)
-
-prop_findMax :: NonEmptyIntMap Int -> Property
-prop_findMax (NonEmptyIntMap im) = findMax im === head (toDescList im)
-
-prop_deleteMinModel :: [(Int, Int)] -> Property
-prop_deleteMinModel ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in toAscList (deleteMin m) == tail (sort xs)
-
-prop_deleteMaxModel :: [(Int, Int)] -> Property
-prop_deleteMaxModel ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in toAscList (deleteMax m) == init (sort xs)
-
-prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property
-prop_filter p ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = filter (apply p) (fromList xs)
- in valid m .&&.
- m === fromList (List.filter (apply p . snd) xs)
-
-prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property
-prop_partition p ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m@(l, r) = partition (apply p) (fromList xs)
- in valid l .&&.
- valid r .&&.
- m === let (a,b) = (List.partition (apply p . snd) xs)
- in (fromList a, fromList b)
-
-prop_map :: Fun Int Int -> [(Int, Int)] -> Property
-prop_map f ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in map (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ]
-
-prop_fmap :: Fun Int Int -> [(Int, Int)] -> Property
-prop_fmap f ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in fmap (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ]
-
-prop_mapkeys :: Fun Int Int -> [(Int, Int)] -> Property
-prop_mapkeys f ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in mapKeys (apply f) m == (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs])
-
-prop_splitModel :: Int -> [(Int, Int)] -> Property
-prop_splitModel n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- (l, r) = split n $ fromList xs
- in valid l .&&.
- valid r .&&.
- toAscList l === sort [(k, v) | (k,v) <- xs, k < n] .&&.
- toAscList r === sort [(k, v) | (k,v) <- xs, k > n]
-
-prop_splitRoot :: IMap -> Bool
-prop_splitRoot s = loop ls && (s == unions ls)
- where
- ls = splitRoot s
- loop [] = True
- loop (s1:rst) = List.null
- [ (x,y) | x <- toList s1
- , y <- toList (unions rst)
- , x > y ]
-
-prop_foldr :: Int -> [(Int, Int)] -> Property
-prop_foldr n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldr (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldr (:) [] m == List.map snd (List.sort xs) &&
- foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldrWithKey (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldrWithKey (\k x xs -> (k,x):xs) [] m == List.sort xs
-
-
-prop_foldr' :: Int -> [(Int, Int)] -> Property
-prop_foldr' n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldr' (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldr' (:) [] m == List.map snd (List.sort xs) &&
- foldrWithKey' (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldrWithKey' (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldrWithKey' (\k x xs -> (k,x):xs) [] m == List.sort xs
-
-prop_foldl :: Int -> [(Int, Int)] -> Property
-prop_foldl n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldl (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&
- foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldlWithKey (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldlWithKey (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)
-
-prop_foldl' :: Int -> [(Int, Int)] -> Property
-prop_foldl' n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldl' (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldl' (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&
- foldlWithKey' (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)
-
-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
diff --git a/tests/intmap-strictness.hs b/tests/intmap-strictness.hs
deleted file mode 100644
index 735b181..0000000
--- a/tests/intmap-strictness.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Main (main) where
-
-import Test.ChasingBottoms.IsBottom
-import Test.Framework (Test, defaultMain, testGroup)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck (Arbitrary(arbitrary))
-import Test.QuickCheck.Function (Fun(..), apply)
-
-import Data.IntMap.Strict (IntMap)
-import qualified Data.IntMap.Strict as M
-
-instance Arbitrary v => Arbitrary (IntMap v) where
- arbitrary = M.fromList `fmap` arbitrary
-
-apply2 :: Fun (a, b) c -> a -> b -> c
-apply2 f a b = apply f (a, b)
-
-apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
-apply3 f a b c = apply f (a, b, c)
-
-------------------------------------------------------------------------
--- * Properties
-
-------------------------------------------------------------------------
--- ** Strict module
-
-pSingletonKeyStrict :: Int -> Bool
-pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v
-
-pSingletonValueStrict :: Int -> Bool
-pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))
-
-pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool
-pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m
-
-pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool
-pFindWithDefaultValueStrict k m =
- M.member k m || (isBottom $ M.findWithDefault bottom k m)
-
-pAdjustKeyStrict :: Fun Int Int -> IntMap Int -> Bool
-pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m
-
-pAdjustValueStrict :: Int -> IntMap Int -> Bool
-pAdjustValueStrict k m
- | k `M.member` m = isBottom $ M.adjust (const bottom) k m
- | otherwise = case M.keys m of
- [] -> True
- (k':_) -> isBottom $ M.adjust (const bottom) k' m
-
-pInsertKeyStrict :: Int -> IntMap Int -> Bool
-pInsertKeyStrict v m = isBottom $ M.insert bottom v m
-
-pInsertValueStrict :: Int -> IntMap Int -> Bool
-pInsertValueStrict k m = isBottom $ M.insert k bottom m
-
-pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> IntMap Int -> Bool
-pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m
-
-pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> IntMap Int
- -> Bool
-pInsertWithValueStrict f k v m
- | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&
- not (isBottom $ M.insertWith (const2 1) k bottom m)
- | otherwise = isBottom $ M.insertWith (apply2 f) k bottom m
-
-pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int -> IntMap Int
- -> Bool
-pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m
-
-pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int
- -> IntMap Int -> Bool
-pInsertLookupWithKeyValueStrict f k v m
- | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&
- not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
- | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
-
-------------------------------------------------------------------------
--- * Test list
-
-tests :: [Test]
-tests =
- [
- -- Basic interface
- testGroup "IntMap.Strict"
- [ testProperty "singleton is key-strict" pSingletonKeyStrict
- , testProperty "singleton is value-strict" pSingletonValueStrict
- , testProperty "member is key-strict" $ keyStrict M.member
- , testProperty "lookup is key-strict" $ keyStrict M.lookup
- , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict
- , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict
- , testProperty "! is key-strict" $ keyStrict (flip (M.!))
- , testProperty "!? is key-strict" $ keyStrict (flip (M.!?))
- , testProperty "delete is key-strict" $ keyStrict M.delete
- , testProperty "adjust is key-strict" pAdjustKeyStrict
- , testProperty "adjust is value-strict" pAdjustValueStrict
- , testProperty "insert is key-strict" pInsertKeyStrict
- , testProperty "insert is value-strict" pInsertValueStrict
- , testProperty "insertWith is key-strict" pInsertWithKeyStrict
- , testProperty "insertWith is value-strict" pInsertWithValueStrict
- , testProperty "insertLookupWithKey is key-strict"
- pInsertLookupWithKeyKeyStrict
- , testProperty "insertLookupWithKey is value-strict"
- pInsertLookupWithKeyValueStrict
- ]
- ]
-
-------------------------------------------------------------------------
--- * Test harness
-
-main :: IO ()
-main = defaultMain tests
-
-------------------------------------------------------------------------
--- * Utilities
-
-keyStrict :: (Int -> IntMap Int -> a) -> IntMap Int -> Bool
-keyStrict f m = isBottom $ f bottom m
-
-const2 :: a -> b -> c -> a
-const2 x _ _ = x
-
-const3 :: a -> b -> c -> d -> a
-const3 x _ _ _ = x
diff --git a/tests/intset-properties.hs b/tests/intset-properties.hs
deleted file mode 100644
index c2a7f0a..0000000
--- a/tests/intset-properties.hs
+++ /dev/null
@@ -1,400 +0,0 @@
-{-# LANGUAGE CPP #-}
-import Data.Bits ((.&.), popCount)
-import Data.Word (Word)
-import Data.IntSet
-import Data.List (nub,sort)
-import qualified Data.List as List
-import Data.Monoid (mempty)
-import qualified Data.Set as Set
-import IntSetValidity (valid)
-import Prelude hiding (lookup, null, map, filter, foldr, foldl)
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2
-import Test.HUnit hiding (Test, Testable)
-import Test.QuickCheck hiding ((.&.))
-
-main :: IO ()
-main = defaultMain [ testCase "lookupLT" test_lookupLT
- , testCase "lookupGT" test_lookupGT
- , testCase "lookupLE" test_lookupLE
- , testCase "lookupGE" test_lookupGE
- , testCase "split" test_split
- , testProperty "prop_Valid" prop_Valid
- , testProperty "prop_EmptyValid" prop_EmptyValid
- , testProperty "prop_SingletonValid" prop_SingletonValid
- , testProperty "prop_InsertIntoEmptyValid" prop_InsertIntoEmptyValid
- , testProperty "prop_Single" prop_Single
- , testProperty "prop_Member" prop_Member
- , testProperty "prop_NotMember" prop_NotMember
- , testProperty "prop_LookupLT" prop_LookupLT
- , testProperty "prop_LookupGT" prop_LookupGT
- , testProperty "prop_LookupLE" prop_LookupLE
- , testProperty "prop_LookupGE" prop_LookupGE
- , testProperty "prop_InsertDelete" prop_InsertDelete
- , testProperty "prop_MemberFromList" prop_MemberFromList
- , testProperty "prop_UnionInsert" prop_UnionInsert
- , testProperty "prop_UnionAssoc" prop_UnionAssoc
- , testProperty "prop_UnionComm" prop_UnionComm
- , testProperty "prop_Diff" prop_Diff
- , testProperty "prop_Int" prop_Int
- , testProperty "prop_Ordered" prop_Ordered
- , testProperty "prop_List" prop_List
- , testProperty "prop_DescList" prop_DescList
- , testProperty "prop_AscDescList" prop_AscDescList
- , testProperty "prop_fromList" prop_fromList
- , testProperty "prop_MaskPow2" prop_MaskPow2
- , testProperty "prop_Prefix" prop_Prefix
- , testProperty "prop_LeftRight" prop_LeftRight
- , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
- , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
- , testProperty "prop_isSubsetOf" prop_isSubsetOf
- , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
- , testProperty "prop_disjoint" prop_disjoint
- , testProperty "prop_size" prop_size
- , testProperty "prop_findMax" prop_findMax
- , testProperty "prop_findMin" prop_findMin
- , testProperty "prop_ord" prop_ord
- , testProperty "prop_readShow" prop_readShow
- , testProperty "prop_foldR" prop_foldR
- , testProperty "prop_foldR'" prop_foldR'
- , testProperty "prop_foldL" prop_foldL
- , testProperty "prop_foldL'" prop_foldL'
- , testProperty "prop_map" prop_map
- , testProperty "prop_maxView" prop_maxView
- , testProperty "prop_minView" prop_minView
- , testProperty "prop_split" prop_split
- , testProperty "prop_splitMember" prop_splitMember
- , testProperty "prop_splitRoot" prop_splitRoot
- , testProperty "prop_partition" prop_partition
- , testProperty "prop_filter" prop_filter
- , testProperty "prop_bitcount" prop_bitcount
- ]
-
-----------------------------------------------------------------
--- Unit tests
-----------------------------------------------------------------
-
-test_lookupLT :: Assertion
-test_lookupLT = do
- lookupLT 3 (fromList [3, 5]) @?= Nothing
- lookupLT 5 (fromList [3, 5]) @?= Just 3
-
-test_lookupGT :: Assertion
-test_lookupGT = do
- lookupGT 4 (fromList [3, 5]) @?= Just 5
- lookupGT 5 (fromList [3, 5]) @?= Nothing
-
-test_lookupLE :: Assertion
-test_lookupLE = do
- lookupLE 2 (fromList [3, 5]) @?= Nothing
- lookupLE 4 (fromList [3, 5]) @?= Just 3
- lookupLE 5 (fromList [3, 5]) @?= Just 5
-
-test_lookupGE :: Assertion
-test_lookupGE = do
- lookupGE 3 (fromList [3, 5]) @?= Just 3
- lookupGE 4 (fromList [3, 5]) @?= Just 5
- lookupGE 6 (fromList [3, 5]) @?= Nothing
-
-test_split :: Assertion
-test_split = do
- split 3 (fromList [1..5]) @?= (fromList [1,2], fromList [4,5])
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary IntSet where
- arbitrary = do{ xs <- arbitrary
- ; return (fromList xs)
- }
-
-{--------------------------------------------------------------------
- Valid IntMaps
---------------------------------------------------------------------}
-forValid :: Testable a => (IntSet -> a) -> Property
-forValid f = forAll arbitrary $ \t ->
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $ f t
-
-forValidUnitTree :: Testable a => (IntSet -> a) -> Property
-forValidUnitTree f = forValid f
-
-prop_Valid :: Property
-prop_Valid = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Construction validity
---------------------------------------------------------------------}
-
-prop_EmptyValid :: Property
-prop_EmptyValid =
- valid empty
-
-prop_SingletonValid :: Int -> Property
-prop_SingletonValid x =
- valid (singleton x)
-
-prop_InsertIntoEmptyValid :: Int -> Property
-prop_InsertIntoEmptyValid x =
- valid (insert x empty)
-
-{--------------------------------------------------------------------
- Single, Member, Insert, Delete, Member, FromList
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_Member :: [Int] -> Int -> Bool
-prop_Member xs n =
- let m = fromList xs
- in all (\k -> k `member` m == (k `elem` xs)) (n : xs)
-
-prop_NotMember :: [Int] -> Int -> Bool
-prop_NotMember xs n =
- let m = fromList xs
- in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)
-
-test_LookupSomething :: (Int -> IntSet -> Maybe Int) -> (Int -> Int -> Bool) -> [Int] -> Bool
-test_LookupSomething lookup' cmp xs =
- let odd_sorted_xs = filter_odd $ nub $ sort xs
- t = fromList odd_sorted_xs
- test x = case List.filter (`cmp` x) odd_sorted_xs of
- [] -> lookup' x t == Nothing
- cs | 0 `cmp` 1 -> lookup' x t == Just (last cs) -- we want largest such element
- | otherwise -> lookup' x t == Just (head cs) -- we want smallest such element
- in all test xs
-
- where filter_odd [] = []
- filter_odd [_] = []
- filter_odd (_ : o : xs) = o : filter_odd xs
-
-prop_LookupLT :: [Int] -> Bool
-prop_LookupLT = test_LookupSomething lookupLT (<)
-
-prop_LookupGT :: [Int] -> Bool
-prop_LookupGT = test_LookupSomething lookupGT (>)
-
-prop_LookupLE :: [Int] -> Bool
-prop_LookupLE = test_LookupSomething lookupLE (<=)
-
-prop_LookupGE :: [Int] -> Bool
-prop_LookupGE = test_LookupSomething lookupGE (>=)
-
-prop_InsertDelete :: Int -> IntSet -> Property
-prop_InsertDelete k t
- = not (member k t) ==>
- case delete k (insert k t) of
- t' -> valid t' .&&. t' === t
-
-prop_MemberFromList :: [Int] -> Bool
-prop_MemberFromList xs
- = all (`member` t) abs_xs && all ((`notMember` t) . negate) abs_xs
- where abs_xs = [abs x | x <- xs, x /= 0]
- t = fromList abs_xs
-
-{--------------------------------------------------------------------
- Union, Difference and Intersection
---------------------------------------------------------------------}
-prop_UnionInsert :: Int -> IntSet -> Property
-prop_UnionInsert x t =
- case union t (singleton x) of
- t' ->
- valid t' .&&.
- t' === insert x t
-
-prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: IntSet -> IntSet -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-prop_Diff :: [Int] -> [Int] -> Property
-prop_Diff xs ys =
- case difference (fromList xs) (fromList ys) of
- t ->
- valid t .&&.
- toAscList t === List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_Int :: [Int] -> [Int] -> Property
-prop_Int xs ys =
- case intersection (fromList xs) (fromList ys) of
- t ->
- valid t .&&.
- toAscList t === List.sort (nub ((List.intersect) (xs) (ys)))
-
-prop_disjoint :: IntSet -> IntSet -> Bool
-prop_disjoint a b = a `disjoint` b == null (a `intersection` b)
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toAscList (fromList xs))
-
-prop_DescList :: [Int] -> Bool
-prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs))
-
-prop_AscDescList :: [Int] -> Bool
-prop_AscDescList xs = toAscList s == reverse (toDescList s)
- where s = fromList xs
-
-prop_fromList :: [Int] -> Property
-prop_fromList xs
- = case fromList xs of
- t -> valid t .&&.
- t === fromAscList sort_xs .&&.
- t === fromDistinctAscList nub_sort_xs .&&.
- t === List.foldr insert empty xs
- where sort_xs = sort xs
- nub_sort_xs = List.map List.head $ List.group sort_xs
-
-{--------------------------------------------------------------------
- Bin invariants
---------------------------------------------------------------------}
-powersOf2 :: IntSet
-powersOf2 = fromList [2^i | i <- [0..63]]
-
--- Check the invariant that the mask is a power of 2.
-prop_MaskPow2 :: IntSet -> Bool
-prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right
-prop_MaskPow2 _ = True
-
--- Check that the prefix satisfies its invariant.
-prop_Prefix :: IntSet -> Bool
-prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right
-prop_Prefix _ = True
-
--- Check that the left elements don't have the mask bit set, and the right
--- ones do.
-prop_LeftRight :: IntSet -> Bool
-prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right]
-prop_LeftRight _ = True
-
-{--------------------------------------------------------------------
- IntSet operations are like Set operations
---------------------------------------------------------------------}
-toSet :: IntSet -> Set.Set Int
-toSet = Set.fromList . toList
-
--- Check that IntSet.isProperSubsetOf is the same as Set.isProperSubsetOf.
-prop_isProperSubsetOf :: IntSet -> IntSet -> Bool
-prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b)
-
--- In the above test, isProperSubsetOf almost always returns False (since a
--- random set is almost never a subset of another random set). So this second
--- test checks the True case.
-prop_isProperSubsetOf2 :: IntSet -> IntSet -> Bool
-prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where
- c = union a b
-
-prop_isSubsetOf :: IntSet -> IntSet -> Bool
-prop_isSubsetOf a b = isSubsetOf a b == Set.isSubsetOf (toSet a) (toSet b)
-
-prop_isSubsetOf2 :: IntSet -> IntSet -> Bool
-prop_isSubsetOf2 a b = isSubsetOf a (union a b)
-
-prop_size :: IntSet -> Property
-prop_size s = sz === foldl' (\i _ -> i + 1) (0 :: Int) s .&&.
- sz === List.length (toList s)
- where sz = size s
-
-prop_findMax :: IntSet -> Property
-prop_findMax s = not (null s) ==> findMax s == maximum (toList s)
-
-prop_findMin :: IntSet -> Property
-prop_findMin s = not (null s) ==> findMin s == minimum (toList s)
-
-prop_ord :: IntSet -> IntSet -> Bool
-prop_ord s1 s2 = s1 `compare` s2 == toList s1 `compare` toList s2
-
-prop_readShow :: IntSet -> Bool
-prop_readShow s = s == read (show s)
-
-prop_foldR :: IntSet -> Bool
-prop_foldR s = foldr (:) [] s == toList s
-
-prop_foldR' :: IntSet -> Bool
-prop_foldR' s = foldr' (:) [] s == toList s
-
-prop_foldL :: IntSet -> Bool
-prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s)
-
-prop_foldL' :: IntSet -> Bool
-prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s)
-
-prop_map :: IntSet -> Bool
-prop_map s = map id s == s
-
-prop_maxView :: IntSet -> Bool
-prop_maxView s = case maxView s of
- Nothing -> null s
- Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s'
-
-prop_minView :: IntSet -> Bool
-prop_minView s = case minView s of
- Nothing -> null s
- Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s'
-
-prop_split :: IntSet -> Int -> Property
-prop_split s i = case split i s of
- (s1,s2) -> valid s1 .&&.
- valid s2 .&&.
- all (<i) (toList s1) .&&.
- all (>i) (toList s2) .&&.
- i `delete` s === union s1 s2
-
-prop_splitMember :: IntSet -> Int -> Property
-prop_splitMember s i = case splitMember i s of
- (s1,t,s2) -> valid s1 .&&.
- valid s2 .&&.
- all (<i) (toList s1) .&&.
- all (>i) (toList s2) .&&.
- t === i `member` s .&&.
- i `delete` s === union s1 s2
-
-prop_splitRoot :: IntSet -> Bool
-prop_splitRoot s = loop ls && (s == unions ls)
- where
- ls = splitRoot s
- loop [] = True
- loop (s1:rst) = List.null
- [ (x,y) | x <- toList s1
- , y <- toList (unions rst)
- , x > y ]
-
-prop_partition :: IntSet -> Int -> Property
-prop_partition s i = case partition odd s of
- (s1,s2) -> valid s1 .&&.
- valid s2 .&&.
- all odd (toList s1) .&&.
- all even (toList s2) .&&.
- s === s1 `union` s2
-
-prop_filter :: IntSet -> Int -> Property
-prop_filter s i =
- let parts = partition odd s
- odds = filter odd s
- evens = filter even s
- in valid odds .&&.
- valid evens .&&.
- parts === (odds, evens)
-
-prop_bitcount :: Int -> Word -> Bool
-prop_bitcount a w = bitcount_orig a w == bitcount_new a w
- where
- bitcount_orig a0 x0 = go a0 x0
- where go a 0 = a
- go a x = go (a + 1) (x .&. (x-1))
- bitcount_new a x = a + popCount x
diff --git a/tests/intset-strictness.hs b/tests/intset-strictness.hs
deleted file mode 100644
index c31aca1..0000000
--- a/tests/intset-strictness.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module Main (main) where
-
-import Prelude hiding (foldl)
-
-import Test.ChasingBottoms.IsBottom
-import Test.Framework (Test, defaultMain, testGroup)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-
-import Data.IntSet
-
-------------------------------------------------------------------------
--- * Properties
-
-------------------------------------------------------------------------
--- ** Lazy module
-
-pFoldlAccLazy :: Int -> Bool
-pFoldlAccLazy k =
- isn'tBottom $ foldl (\_ x -> x) (bottom :: Int) (singleton k)
-
-------------------------------------------------------------------------
--- * Test list
-
-tests :: [Test]
-tests =
- [
- -- Basic interface
- testGroup "IntSet"
- [ testProperty "foldl is lazy in accumulator" pFoldlAccLazy
- ]
- ]
-
-------------------------------------------------------------------------
--- * Test harness
-
-main :: IO ()
-main = defaultMain tests
-
-------------------------------------------------------------------------
--- * Utilities
-
-isn'tBottom :: a -> Bool
-isn'tBottom = not . isBottom
diff --git a/tests/listutils-properties.hs b/tests/listutils-properties.hs
deleted file mode 100644
index 055c626..0000000
--- a/tests/listutils-properties.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-module Main where
-
-import Data.List (nub, nubBy)
-import Data.Containers.ListUtils
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Test.QuickCheck (Property, (===))
-import Test.QuickCheck.Function (Fun, apply)
-import Test.QuickCheck.Poly (A, OrdA, B, OrdB, C)
-
-main :: IO ()
-main = defaultMain
- [ testProperty "nubOrd" prop_nubOrd
- , testProperty "nubOrdOn" prop_nubOrdOn
- , testProperty "nubOrdOn fusion" prop_nubOrdOnFusion
- , testProperty "nubInt" prop_nubInt
- , testProperty "nubIntOn" prop_nubIntOn
- , testProperty "nubIntOn fusion" prop_nubIntOnFusion
- ]
-
-
-prop_nubOrd :: [OrdA] -> Property
-prop_nubOrd xs = nubOrd xs === nub xs
-
-prop_nubInt :: [Int] -> Property
-prop_nubInt xs = nubInt xs === nub xs
-
-prop_nubOrdOn :: Fun A OrdB -> [A] -> Property
-prop_nubOrdOn f' xs =
- nubOrdOn f xs === nubBy (\x y -> f x == f y) xs
- where f = apply f'
-
-prop_nubIntOn :: Fun A Int -> [A] -> Property
-prop_nubIntOn f' xs =
- nubIntOn f xs === nubBy (\x y -> f x == f y) xs
- where f = apply f'
-
-prop_nubOrdOnFusion :: Fun B C
- -> Fun B OrdB
- -> Fun A B
- -> [A] -> Property
-prop_nubOrdOnFusion f' g' h' xs =
- (map f . nubOrdOn g . map h $ xs)
- === (map f . nubBy (\x y -> g x == g y) . map h $ xs)
- where
- f = apply f'
- g = apply g'
- h = apply h'
-
-prop_nubIntOnFusion :: Fun B C
- -> Fun B Int
- -> Fun A B
- -> [A] -> Property
-prop_nubIntOnFusion f' g' h' xs =
- (map f . nubIntOn g . map h $ xs)
- === (map f . nubBy (\x y -> g x == g y) . map h $ xs)
- where
- f = apply f'
- g = apply g'
- h = apply h'
diff --git a/tests/map-properties.hs b/tests/map-properties.hs
deleted file mode 100644
index 59522f3..0000000
--- a/tests/map-properties.hs
+++ /dev/null
@@ -1,1400 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-#ifdef STRICT
-import Data.Map.Strict as Data.Map hiding (showTree, showTreeWith)
-import Data.Map.Merge.Strict
-#else
-import Data.Map.Lazy as Data.Map hiding (showTree, showTreeWith)
-import Data.Map.Merge.Lazy
-#endif
-import Data.Map.Internal (Map (..), link2, link, bin)
-import Data.Map.Internal.Debug (showTree, showTreeWith, balanced)
-
-import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>))
-import Data.Functor.Identity (Identity(runIdentity))
-import Data.Monoid
-import Data.Maybe hiding (mapMaybe)
-import qualified Data.Maybe as Maybe (mapMaybe)
-import Data.Ord
-import Data.Function
-import Prelude hiding (lookup, null, map, filter, foldr, foldl, take, drop, splitAt)
-import qualified Prelude
-
-import Data.List (nub,sort)
-import qualified Data.List as List
-import qualified Data.Set as Set
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2
-import Test.HUnit hiding (Test, Testable)
-import Test.QuickCheck
-import Test.QuickCheck.Function (Fun (..), apply)
-import Test.QuickCheck.Poly (A, B)
-import Control.Arrow (first)
-
-default (Int)
-
-apply3 :: Fun (a,b,c) d -> a -> b -> c -> d
-apply3 f a b c = apply f (a, b, c)
-
-apply2 :: Fun (a,b) c -> a -> b -> c
-apply2 f a b = apply f (a, b)
-
-main :: IO ()
-main = defaultMain
- [ testCase "ticket4242" test_ticket4242
- , testCase "index" test_index
- , testCase "size" test_size
- , testCase "size2" test_size2
- , testCase "member" test_member
- , testCase "notMember" test_notMember
- , testCase "lookup" test_lookup
- , testCase "findWithDefault" test_findWithDefault
- , testCase "lookupLT" test_lookupLT
- , testCase "lookupGT" test_lookupGT
- , testCase "lookupLE" test_lookupLE
- , testCase "lookupGE" test_lookupGE
- , testCase "empty" test_empty
- , testCase "mempty" test_mempty
- , testCase "singleton" test_singleton
- , testCase "insert" test_insert
- , testCase "insertWith" test_insertWith
- , testCase "insertWithKey" test_insertWithKey
- , testCase "insertLookupWithKey" test_insertLookupWithKey
- , testCase "delete" test_delete
- , testCase "adjust" test_adjust
- , testCase "adjustWithKey" test_adjustWithKey
- , testCase "update" test_update
- , testCase "updateWithKey" test_updateWithKey
- , testCase "updateLookupWithKey" test_updateLookupWithKey
- , testCase "alter" test_alter
- , testCase "at" test_at
- , testCase "union" test_union
- , testCase "mappend" test_mappend
- , testCase "unionWith" test_unionWith
- , testCase "unionWithKey" test_unionWithKey
- , testCase "unions" test_unions
- , testCase "mconcat" test_mconcat
- , testCase "unionsWith" test_unionsWith
- , testCase "difference" test_difference
- , testCase "differenceWith" test_differenceWith
- , testCase "differenceWithKey" test_differenceWithKey
- , testCase "intersection" test_intersection
- , testCase "intersectionWith" test_intersectionWith
- , testCase "intersectionWithKey" test_intersectionWithKey
- , testCase "map" test_map
- , testCase "mapWithKey" test_mapWithKey
- , testCase "mapAccum" test_mapAccum
- , testCase "mapAccumWithKey" test_mapAccumWithKey
- , testCase "mapAccumRWithKey" test_mapAccumRWithKey
- , testCase "mapKeys" test_mapKeys
- , testCase "mapKeysWith" test_mapKeysWith
- , testCase "mapKeysMonotonic" test_mapKeysMonotonic
- , testCase "elems" test_elems
- , testCase "keys" test_keys
- , testCase "assocs" test_assocs
- , testCase "keysSet" test_keysSet
- , testCase "fromSet" test_fromSet
- , testCase "toList" test_toList
- , testCase "fromList" test_fromList
- , testCase "fromListWith" test_fromListWith
- , testCase "fromListWithKey" test_fromListWithKey
- , testCase "toAscList" test_toAscList
- , testCase "toDescList" test_toDescList
- , testCase "showTree" test_showTree
- , testCase "showTree'" test_showTree'
- , testCase "fromAscList" test_fromAscList
- , testCase "fromAscListWith" test_fromAscListWith
- , testCase "fromAscListWithKey" test_fromAscListWithKey
- , testCase "fromDistinctAscList" test_fromDistinctAscList
- , testCase "fromDistinctDescList" test_fromDistinctDescList
- , testCase "filter" test_filter
- , testCase "filterWithKey" test_filteWithKey
- , testCase "partition" test_partition
- , testCase "partitionWithKey" test_partitionWithKey
- , testCase "mapMaybe" test_mapMaybe
- , testCase "mapMaybeWithKey" test_mapMaybeWithKey
- , testCase "mapEither" test_mapEither
- , testCase "mapEitherWithKey" test_mapEitherWithKey
- , testCase "split" test_split
- , testCase "splitLookup" test_splitLookup
- , testCase "isSubmapOfBy" test_isSubmapOfBy
- , testCase "isSubmapOf" test_isSubmapOf
- , testCase "isProperSubmapOfBy" test_isProperSubmapOfBy
- , testCase "isProperSubmapOf" test_isProperSubmapOf
- , testCase "lookupIndex" test_lookupIndex
- , testCase "findIndex" test_findIndex
- , testCase "elemAt" test_elemAt
- , testCase "updateAt" test_updateAt
- , testCase "deleteAt" test_deleteAt
- , testCase "findMin" test_findMin
- , testCase "findMax" test_findMax
- , testCase "deleteMin" test_deleteMin
- , testCase "deleteMax" test_deleteMax
- , testCase "deleteFindMin" test_deleteFindMin
- , testCase "deleteFindMax" test_deleteFindMax
- , testCase "updateMin" test_updateMin
- , testCase "updateMax" test_updateMax
- , testCase "updateMinWithKey" test_updateMinWithKey
- , testCase "updateMaxWithKey" test_updateMaxWithKey
- , testCase "minView" test_minView
- , testCase "maxView" test_maxView
- , testCase "minViewWithKey" test_minViewWithKey
- , testCase "maxViewWithKey" test_maxViewWithKey
- , testCase "valid" test_valid
- , testProperty "valid" prop_valid
- , testProperty "insert to singleton" prop_singleton
- , testProperty "insert" prop_insert
- , testProperty "insert then lookup" prop_insertLookup
- , testProperty "insert then delete" prop_insertDelete
- , testProperty "insert then delete2" prop_insertDelete2
- , testProperty "delete non member" prop_deleteNonMember
- , testProperty "deleteMin" prop_deleteMin
- , testProperty "deleteMax" prop_deleteMax
- , testProperty "split" prop_split
- , testProperty "splitRoot" prop_splitRoot
- , testProperty "split then link" prop_link
- , testProperty "split then link2" prop_link2
- , testProperty "union" prop_union
- , testProperty "union model" prop_unionModel
- , testProperty "union singleton" prop_unionSingleton
- , testProperty "union associative" prop_unionAssoc
- , testProperty "union+unionWith" prop_unionWith
- , testProperty "unionWith" prop_unionWith2
- , testProperty "union sum" prop_unionSum
- , testProperty "difference" prop_difference
- , testProperty "difference model" prop_differenceModel
- , testProperty "withoutKeys" prop_withoutKeys
- , testProperty "intersection" prop_intersection
- , testProperty "restrictKeys" prop_restrictKeys
- , testProperty "intersection model" prop_intersectionModel
- , testProperty "intersectionWith" prop_intersectionWith
- , testProperty "intersectionWithModel" prop_intersectionWithModel
- , testProperty "intersectionWithKey" prop_intersectionWithKey
- , testProperty "intersectionWithKeyModel" prop_intersectionWithKeyModel
- , testProperty "differenceMerge" prop_differenceMerge
- , testProperty "unionWithKeyMerge" prop_unionWithKeyMerge
- , testProperty "mergeWithKey model" prop_mergeWithKeyModel
- , testProperty "fromAscList" prop_ordered
- , testProperty "fromDescList" prop_rev_ordered
- , testProperty "fromDistinctDescList" prop_fromDistinctDescList
- , testProperty "fromList then toList" prop_list
- , testProperty "toDescList" prop_descList
- , testProperty "toAscList+toDescList" prop_ascDescList
- , testProperty "fromList" prop_fromList
- , testProperty "alter" prop_alter
- , testProperty "alterF/alter" prop_alterF_alter
- , testProperty "alterF/alter/noRULES" prop_alterF_alter_noRULES
- , testProperty "alterF/lookup" prop_alterF_lookup
- , testProperty "alterF/lookup/noRULES" prop_alterF_lookup_noRULES
- , testProperty "index" prop_index
- , testProperty "null" prop_null
- , testProperty "member" prop_member
- , testProperty "notmember" prop_notmember
- , testProperty "lookup" prop_lookup
- , testProperty "find" prop_find
- , testProperty "findWithDefault" prop_findWithDefault
- , testProperty "lookupLT" prop_lookupLT
- , testProperty "lookupGT" prop_lookupGT
- , testProperty "lookupLE" prop_lookupLE
- , testProperty "lookupGE" prop_lookupGE
- , testProperty "findIndex" prop_findIndex
- , testProperty "lookupIndex" prop_lookupIndex
- , testProperty "findMin" prop_findMin
- , testProperty "findMax" prop_findMax
- , testProperty "deleteMin" prop_deleteMinModel
- , testProperty "deleteMax" prop_deleteMaxModel
- , testProperty "filter" prop_filter
- , testProperty "partition" prop_partition
- , testProperty "map" prop_map
- , testProperty "fmap" prop_fmap
- , testProperty "mapkeys" prop_mapkeys
- , testProperty "split" prop_splitModel
- , testProperty "foldr" prop_foldr
- , testProperty "foldr'" prop_foldr'
- , testProperty "foldl" prop_foldl
- , testProperty "foldl'" prop_foldl'
- , testProperty "keysSet" prop_keysSet
- , testProperty "fromSet" prop_fromSet
- , testProperty "takeWhileAntitone" prop_takeWhileAntitone
- , testProperty "dropWhileAntitone" prop_dropWhileAntitone
- , testProperty "spanAntitone" prop_spanAntitone
- , testProperty "take" prop_take
- , testProperty "drop" prop_drop
- , testProperty "splitAt" prop_splitAt
- , testProperty "lookupMin" prop_lookupMin
- , testProperty "lookupMax" prop_lookupMax
- ]
-
-{--------------------------------------------------------------------
- Arbitrary trees
---------------------------------------------------------------------}
-instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
- arbitrary = sized (arbtree 0 maxkey)
- where maxkey = 10^(5 :: Int)
-
- arbtree :: (Enum k, Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
- arbtree lo hi n = do t <- gentree lo hi n
- if balanced t then return t else arbtree lo hi n
- where gentree lo hi n
- | n <= 0 = return Tip
- | lo >= hi = return Tip
- | otherwise = do{ x <- arbitrary
- ; i <- choose (lo,hi)
- ; m <- choose (1,70)
- ; let (ml,mr) | m==(1::Int)= (1,2)
- | m==2 = (2,1)
- | m==3 = (1,1)
- | otherwise = (2,2)
- ; l <- gentree lo (i-1) (n `div` ml)
- ; r <- gentree (i+1) hi (n `div` mr)
- ; return (bin (toEnum i) x l r)
- }
-
--- A type with a peculiar Eq instance designed to make sure keys
--- come from where they're supposed to.
-data OddEq a = OddEq a Bool deriving (Show)
-getOddEq :: OddEq a -> (a, Bool)
-getOddEq (OddEq a b) = (a, b)
-instance Arbitrary a => Arbitrary (OddEq a) where
- arbitrary = OddEq <$> arbitrary <*> arbitrary
-instance Eq a => Eq (OddEq a) where
- OddEq x _ == OddEq y _ = x == y
-instance Ord a => Ord (OddEq a) where
- OddEq x _ `compare` OddEq y _ = x `compare` y
-
-------------------------------------------------------------------------
-
-type UMap = Map Int ()
-type IMap = Map Int Int
-type SMap = Map Int String
-
-----------------------------------------------------------------
--- Unit tests
-----------------------------------------------------------------
-
-test_ticket4242 :: Assertion
-test_ticket4242 = (valid $ deleteMin $ deleteMin $ fromList [ (i, ()) | i <- [0,2,5,1,6,4,8,9,7,11,10,3] :: [Int] ]) @?= True
-
-----------------------------------------------------------------
--- Operators
-
-test_index :: Assertion
-test_index = fromList [(5,'a'), (3,'b')] ! 5 @?= 'a'
-
-----------------------------------------------------------------
--- Query
-
-test_size :: Assertion
-test_size = do
- null (empty) @?= True
- null (singleton 1 'a') @?= False
-
-test_size2 :: Assertion
-test_size2 = do
- size empty @?= 0
- size (singleton 1 'a') @?= 1
- size (fromList([(1,'a'), (2,'c'), (3,'b')])) @?= 3
-
-test_member :: Assertion
-test_member = do
- member 5 (fromList [(5,'a'), (3,'b')]) @?= True
- member 1 (fromList [(5,'a'), (3,'b')]) @?= False
-
-test_notMember :: Assertion
-test_notMember = do
- notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False
- notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True
-
-test_lookup :: Assertion
-test_lookup = do
- employeeCurrency "John" @?= Just "Euro"
- employeeCurrency "Pete" @?= Nothing
- where
- employeeDept = fromList([("John","Sales"), ("Bob","IT")])
- deptCountry = fromList([("IT","USA"), ("Sales","France")])
- countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
- employeeCurrency :: String -> Maybe String
- employeeCurrency name = do
- dept <- lookup name employeeDept
- country <- lookup dept deptCountry
- lookup country countryCurrency
-
-test_findWithDefault :: Assertion
-test_findWithDefault = do
- findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x'
- findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a'
-
-test_lookupLT :: Assertion
-test_lookupLT = do
- lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing
- lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')
-
-test_lookupGT :: Assertion
-test_lookupGT = do
- lookupGT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')
- lookupGT 5 (fromList [(3,'a'), (5,'b')]) @?= Nothing
-
-test_lookupLE :: Assertion
-test_lookupLE = do
- lookupLE 2 (fromList [(3,'a'), (5,'b')]) @?= Nothing
- lookupLE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')
- lookupLE 5 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')
-
-test_lookupGE :: Assertion
-test_lookupGE = do
- lookupGE 3 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')
- lookupGE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')
- lookupGE 6 (fromList [(3,'a'), (5,'b')]) @?= Nothing
-
-----------------------------------------------------------------
--- Construction
-
-test_empty :: Assertion
-test_empty = do
- (empty :: UMap) @?= fromList []
- size empty @?= 0
-
-test_mempty :: Assertion
-test_mempty = do
- (mempty :: UMap) @?= fromList []
- size (mempty :: UMap) @?= 0
-
-test_singleton :: Assertion
-test_singleton = do
- singleton 1 'a' @?= fromList [(1, 'a')]
- size (singleton 1 'a') @?= 1
-
-test_insert :: Assertion
-test_insert = do
- insert 5 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'x')]
- insert 7 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'a'), (7, 'x')]
- insert 5 'x' empty @?= singleton 5 'x'
-
-test_insertWith :: Assertion
-test_insertWith = do
- insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "xxxa")]
- insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")]
- insertWith (++) 5 "xxx" empty @?= singleton 5 "xxx"
-
-test_insertWithKey :: Assertion
-test_insertWithKey = do
- insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:xxx|a")]
- insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")]
- insertWithKey f 5 "xxx" empty @?= singleton 5 "xxx"
- where
- f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
-
-test_insertLookupWithKey :: Assertion
-test_insertLookupWithKey = do
- insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
- insertLookupWithKey f 2 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing,fromList [(2,"xxx"),(3,"b"),(5,"a")])
- insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
- insertLookupWithKey f 5 "xxx" empty @?= (Nothing, singleton 5 "xxx")
- where
- f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
-
-----------------------------------------------------------------
--- Delete/Update
-
-test_delete :: Assertion
-test_delete = do
- delete 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- delete 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- delete 5 empty @?= (empty :: IMap)
-
-test_adjust :: Assertion
-test_adjust = do
- adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")]
- adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- adjust ("new " ++) 7 empty @?= empty
-
-test_adjustWithKey :: Assertion
-test_adjustWithKey = do
- adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")]
- adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- adjustWithKey f 7 empty @?= empty
- where
- f key x = (show key) ++ ":new " ++ x
-
-test_update :: Assertion
-test_update = do
- update f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")]
- update f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- update f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
- where
- f x = if x == "a" then Just "new a" else Nothing
-
-test_updateWithKey :: Assertion
-test_updateWithKey = do
- updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")]
- updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
- where
- f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
-
-test_updateLookupWithKey :: Assertion
-test_updateLookupWithKey = do
- updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
- updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a")])
- updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= (Just "b", singleton 5 "a")
- where
- f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
-
-test_alter :: Assertion
-test_alter = do
- alter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- alter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")]
- alter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")]
- where
- f _ = Nothing
- g _ = Just "c"
-
-test_at :: Assertion
-test_at = do
- employeeCurrency "John" @?= Just "Euro"
- employeeCurrency "Pete" @?= Nothing
- atAlter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]
- atAlter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- atAlter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")]
- atAlter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")]
- where
- f _ = Nothing
- g _ = Just "c"
- employeeDept = fromList([("John","Sales"), ("Bob","IT")])
- deptCountry = fromList([("IT","USA"), ("Sales","France")])
- countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
- employeeCurrency :: String -> Maybe String
- employeeCurrency name = do
- dept <- atLookup name employeeDept
- country <- atLookup dept deptCountry
- atLookup country countryCurrency
-
--- This version of atAlter will rewrite to alterFIdentity
--- if the rules fire.
-atAlter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
-atAlter f k m = runIdentity (alterF (pure . f) k m)
-
--- A version of atAlter that uses a private copy of Identity
--- to ensure that the adjustF/Identity rules don't fire and
--- we use the basic implementation.
-atAlterNoRULES :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
-atAlterNoRULES f k m = runIdent (alterF (Ident . f) k m)
-
-newtype Ident a = Ident { runIdent :: a }
-instance Functor Ident where
- fmap f (Ident a) = Ident (f a)
-
-atLookup :: Ord k => k -> Map k a -> Maybe a
-atLookup k m = getConst (alterF Const k m)
-
-atLookupNoRULES :: Ord k => k -> Map k a -> Maybe a
-atLookupNoRULES k m = getConsty (alterF Consty k m)
-
-newtype Consty a b = Consty { getConsty :: a}
-instance Functor (Consty a) where
- fmap _ (Consty a) = Consty a
-
-----------------------------------------------------------------
--- Combine
-
-test_union :: Assertion
-test_union = union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]
-
-test_mappend :: Assertion
-test_mappend = mappend (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]
-
-test_unionWith :: Assertion
-test_unionWith = unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")]
-
-test_unionWithKey :: Assertion
-test_unionWithKey = unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
- where
- f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
-
-test_unions :: Assertion
-test_unions = do
- unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
- @?= fromList [(3, "b"), (5, "a"), (7, "C")]
- unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
- @?= fromList [(3, "B3"), (5, "A3"), (7, "C")]
-
-test_mconcat :: Assertion
-test_mconcat = do
- mconcat [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
- @?= fromList [(3, "b"), (5, "a"), (7, "C")]
- mconcat [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
- @?= fromList [(3, "B3"), (5, "A3"), (7, "C")]
-
-test_unionsWith :: Assertion
-test_unionsWith = unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
- @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
-
-test_difference :: Assertion
-test_difference = difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b"
-
-test_differenceWith :: Assertion
-test_differenceWith = differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
- @?= singleton 3 "b:B"
- where
- f al ar = if al== "b" then Just (al ++ ":" ++ ar) else Nothing
-
-test_differenceWithKey :: Assertion
-test_differenceWithKey = differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
- @?= singleton 3 "3:b|B"
- where
- f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
-
-test_intersection :: Assertion
-test_intersection = intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a"
-
-
-test_intersectionWith :: Assertion
-test_intersectionWith = intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA"
-
-test_intersectionWithKey :: Assertion
-test_intersectionWithKey = intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A"
- where
- f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
-
-----------------------------------------------------------------
--- Traversal
-
-test_map :: Assertion
-test_map = map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")]
-
-test_mapWithKey :: Assertion
-test_mapWithKey = mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")]
- where
- f key x = (show key) ++ ":" ++ x
-
-test_mapAccum :: Assertion
-test_mapAccum = mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
- where
- f a b = (a ++ b, b ++ "X")
-
-test_mapAccumWithKey :: Assertion
-test_mapAccumWithKey = mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
- where
- f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
-
-test_mapAccumRWithKey :: Assertion
-test_mapAccumRWithKey = mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")])
- where
- f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
-
-test_mapKeys :: Assertion
-test_mapKeys = do
- mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")]
- mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "c"
- mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "c"
-
-test_mapKeysWith :: Assertion
-test_mapKeysWith = do
- mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "cdab"
- mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "cdab"
-
-test_mapKeysMonotonic :: Assertion
-test_mapKeysMonotonic = do
- mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")]
- mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")]
- valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) @?= True
- valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) @?= False
-
-----------------------------------------------------------------
--- Conversion
-
-test_elems :: Assertion
-test_elems = do
- elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"]
- elems (empty :: UMap) @?= []
-
-test_keys :: Assertion
-test_keys = do
- keys (fromList [(5,"a"), (3,"b")]) @?= [3,5]
- keys (empty :: UMap) @?= []
-
-test_assocs :: Assertion
-test_assocs = do
- assocs (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]
- assocs (empty :: UMap) @?= []
-
-test_keysSet :: Assertion
-test_keysSet = do
- keysSet (fromList [(5,"a"), (3,"b")]) @?= Set.fromList [3,5]
- keysSet (empty :: UMap) @?= Set.empty
-
-test_fromSet :: Assertion
-test_fromSet = do
- fromSet (\k -> replicate k 'a') (Set.fromList [3, 5]) @?= fromList [(5,"aaaaa"), (3,"aaa")]
- fromSet undefined Set.empty @?= (empty :: IMap)
-
-----------------------------------------------------------------
--- Lists
-
-test_toList :: Assertion
-test_toList = do
- toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]
- toList (empty :: SMap) @?= []
-
-test_fromList :: Assertion
-test_fromList = do
- fromList [] @?= (empty :: SMap)
- fromList [(5,"a"), (3,"b"), (5, "c")] @?= fromList [(5,"c"), (3,"b")]
- fromList [(5,"c"), (3,"b"), (5, "a")] @?= fromList [(5,"a"), (3,"b")]
-
-test_fromListWith :: Assertion
-test_fromListWith = do
- fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "ab"), (5, "aba")]
- fromListWith (++) [] @?= (empty :: SMap)
-
-test_fromListWithKey :: Assertion
-test_fromListWithKey = do
- fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "3ab"), (5, "5a5ba")]
- fromListWithKey f [] @?= (empty :: SMap)
- where
- f k a1 a2 = (show k) ++ a1 ++ a2
-
-----------------------------------------------------------------
--- Ordered lists
-
-test_toAscList :: Assertion
-test_toAscList = toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]
-
-test_toDescList :: Assertion
-test_toDescList = toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")]
-
-test_showTree :: Assertion
-test_showTree =
- (let t = fromDistinctAscList [(x,()) | x <- [1..5]]
- in showTree t) @?= "4:=()\n+--2:=()\n| +--1:=()\n| +--3:=()\n+--5:=()\n"
-
-test_showTree' :: Assertion
-test_showTree' =
- (let t = fromDistinctAscList [(x,()) | x <- [1..5]]
- in s t ) @?= "+--5:=()\n|\n4:=()\n|\n| +--3:=()\n| |\n+--2:=()\n |\n +--1:=()\n"
- where
- showElem k x = show k ++ ":=" ++ show x
-
- s = showTreeWith showElem False True
-
-
-test_fromAscList :: Assertion
-test_fromAscList = do
- fromAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")]
- fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")]
- valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) @?= True
- valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) @?= False
-
-test_fromAscListWith :: Assertion
-test_fromAscListWith = do
- fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")]
- valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) @?= True
- valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) @?= False
-
-test_fromAscListWithKey :: Assertion
-test_fromAscListWithKey = do
- fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b5:ba")]
- valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) @?= True
- valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) @?= False
- where
- f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
-
-test_fromDistinctAscList :: Assertion
-test_fromDistinctAscList = do
- fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")]
- valid (fromDistinctAscList [(3,"b"), (5,"a")]) @?= True
- valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) @?= False
-
-test_fromDistinctDescList :: Assertion
-test_fromDistinctDescList = do
- fromDistinctDescList [(5,"a"), (3,"b")] @?= fromList [(3, "b"), (5, "a")]
- valid (fromDistinctDescList [(5,"a"), (3,"b")]) @?= True
- valid (fromDistinctDescList [(3,"b"), (5,"a"), (5,"b")]) @?= False
-
-----------------------------------------------------------------
--- Filter
-
-test_filter :: Assertion
-test_filter = do
- filter (> "a") (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
- filter (> "x") (fromList [(5,"a"), (3,"b")]) @?= empty
- filter (< "a") (fromList [(5,"a"), (3,"b")]) @?= empty
-
-test_filteWithKey :: Assertion
-test_filteWithKey = filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
-
-test_partition :: Assertion
-test_partition = do
- partition (> "a") (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a")
- partition (< "x") (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty)
- partition (> "x") (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")])
-
-test_partitionWithKey :: Assertion
-test_partitionWithKey = do
- partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) @?= (singleton 5 "a", singleton 3 "b")
- partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty)
- partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")])
-
-test_mapMaybe :: Assertion
-test_mapMaybe = mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a"
- where
- f x = if x == "a" then Just "new a" else Nothing
-
-test_mapMaybeWithKey :: Assertion
-test_mapMaybeWithKey = mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3"
- where
- f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
-
-test_mapEither :: Assertion
-test_mapEither = do
- mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
- mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= ((empty :: SMap), fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- where
- f a = if a < "c" then Left a else Right a
-
-test_mapEitherWithKey :: Assertion
-test_mapEitherWithKey = do
- mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
- mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
- @?= ((empty :: SMap), fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
- where
- f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
-
-test_split :: Assertion
-test_split = do
- split 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3,"b"), (5,"a")])
- split 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, singleton 5 "a")
- split 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a")
- split 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", empty)
- split 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], empty)
-
-test_splitLookup :: Assertion
-test_splitLookup = do
- splitLookup 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, Nothing, fromList [(3,"b"), (5,"a")])
- splitLookup 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, Just "b", singleton 5 "a")
- splitLookup 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Nothing, singleton 5 "a")
- splitLookup 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Just "a", empty)
- splitLookup 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], Nothing, empty)
-
-----------------------------------------------------------------
--- Submap
-
-test_isSubmapOfBy :: Assertion
-test_isSubmapOfBy = do
- isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= True
- isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= True
- isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) @?= True
- isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) @?= False
- isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= False
- isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) @?= False
-
-test_isSubmapOf :: Assertion
-test_isSubmapOf = do
- isSubmapOf (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= True
- isSubmapOf (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) @?= True
- isSubmapOf (fromList [('a',2)]) (fromList [('a',1),('b',2)]) @?= False
- isSubmapOf (fromList [('a',1),('b',2)]) (fromList [('a',1)]) @?= False
-
-test_isProperSubmapOfBy :: Assertion
-test_isProperSubmapOfBy = do
- isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
- isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
- isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False
- isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False
- isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= False
-
-test_isProperSubmapOf :: Assertion
-test_isProperSubmapOf = do
- isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
- isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False
- isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False
-
-----------------------------------------------------------------
--- Indexed
-
-test_lookupIndex :: Assertion
-test_lookupIndex = do
- isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) @?= False
- fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) @?= 0
- fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) @?= 1
- isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) @?= False
-
-test_findIndex :: Assertion
-test_findIndex = do
- findIndex 3 (fromList [(5,"a"), (3,"b")]) @?= 0
- findIndex 5 (fromList [(5,"a"), (3,"b")]) @?= 1
-
-test_elemAt :: Assertion
-test_elemAt = do
- elemAt 0 (fromList [(5,"a"), (3,"b")]) @?= (3,"b")
- elemAt 1 (fromList [(5,"a"), (3,"b")]) @?= (5, "a")
-
-test_updateAt :: Assertion
-test_updateAt = do
- updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "x"), (5, "a")]
- updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "x")]
- updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
- updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
--- updateAt (\_ _ -> Nothing) 7 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
-
-test_deleteAt :: Assertion
-test_deleteAt = do
- deleteAt 0 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
- deleteAt 1 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
-
-----------------------------------------------------------------
--- Min/Max
-
-test_findMin :: Assertion
-test_findMin = findMin (fromList [(5,"a"), (3,"b")]) @?= (3,"b")
-
-test_findMax :: Assertion
-test_findMax = findMax (fromList [(5,"a"), (3,"b")]) @?= (5,"a")
-
-test_deleteMin :: Assertion
-test_deleteMin = do
- deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(5,"a"), (7,"c")]
- deleteMin (empty :: SMap) @?= empty
-
-test_deleteMax :: Assertion
-test_deleteMax = do
- deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(3,"b"), (5,"a")]
- deleteMax (empty :: SMap) @?= empty
-
-test_deleteFindMin :: Assertion
-test_deleteFindMin = deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((3,"b"), fromList[(5,"a"), (10,"c")])
-
-test_deleteFindMax :: Assertion
-test_deleteFindMax = deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((10,"c"), fromList [(3,"b"), (5,"a")])
-
-test_updateMin :: Assertion
-test_updateMin = do
- updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "Xb"), (5, "a")]
- updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
-
-test_updateMax :: Assertion
-test_updateMax = do
- updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "Xa")]
- updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
-
-test_updateMinWithKey :: Assertion
-test_updateMinWithKey = do
- updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"3:b"), (5,"a")]
- updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"
-
-test_updateMaxWithKey :: Assertion
-test_updateMaxWithKey = do
- updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"b"), (5,"5:a")]
- updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"
-
-test_minView :: Assertion
-test_minView = do
- minView (fromList [(5,"a"), (3,"b")]) @?= Just ("b", singleton 5 "a")
- minView (empty :: SMap) @?= Nothing
-
-test_maxView :: Assertion
-test_maxView = do
- maxView (fromList [(5,"a"), (3,"b")]) @?= Just ("a", singleton 3 "b")
- maxView (empty :: SMap) @?= Nothing
-
-test_minViewWithKey :: Assertion
-test_minViewWithKey = do
- minViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((3,"b"), singleton 5 "a")
- minViewWithKey (empty :: SMap) @?= Nothing
-
-test_maxViewWithKey :: Assertion
-test_maxViewWithKey = do
- maxViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((5,"a"), singleton 3 "b")
- maxViewWithKey (empty :: SMap) @?= Nothing
-
-----------------------------------------------------------------
--- Debug
-
-test_valid :: Assertion
-test_valid = do
- valid (fromAscList [(3,"b"), (5,"a")]) @?= True
- valid (fromAscList [(5,"a"), (3,"b")]) @?= False
-
-----------------------------------------------------------------
--- QuickCheck
-----------------------------------------------------------------
-
-prop_differenceMerge :: Fun (Int, A, B) (Maybe A) -> Map Int A -> Map Int B -> Property
-prop_differenceMerge f m1 m2 =
- differenceWithKey (apply3 f) m1 m2 === merge preserveMissing dropMissing (zipWithMaybeMatched (apply3 f)) m1 m2
-
-prop_unionWithKeyMerge :: Fun (Int, A, A) A -> Map Int A -> Map Int A -> Property
-prop_unionWithKeyMerge f m1 m2 =
- unionWithKey (apply3 f) m1 m2 === unionWithKey' (apply3 f) m1 m2
-
-unionWithKey' :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWithKey' f = merge preserveMissing preserveMissing $
- zipWithMatched (\k a b -> f k a b)
-
-prop_valid :: UMap -> Bool
-prop_valid t = valid t
-
-prop_singleton :: Int -> Int -> Bool
-prop_singleton k x = insert k x empty == singleton k x
-
-prop_insert :: Int -> UMap -> Bool
-prop_insert k t = valid $ insert k () t
-
-prop_insertLookup :: Int -> UMap -> Bool
-prop_insertLookup k t = lookup k (insert k () t) /= Nothing
-
-prop_insertDelete :: Int -> UMap -> Bool
-prop_insertDelete k t = valid $ delete k (insert k () t)
-
-prop_insertDelete2 :: Int -> UMap -> Property
-prop_insertDelete2 k t = (lookup k t == Nothing) ==> (delete k (insert k () t) == t)
-
-prop_deleteNonMember :: Int -> UMap -> Property
-prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t)
-
-prop_deleteMin :: UMap -> Bool
-prop_deleteMin t = valid $ deleteMin $ deleteMin t
-
-prop_deleteMax :: UMap -> Bool
-prop_deleteMax t = valid $ deleteMax $ deleteMax t
-
-prop_lookupMin :: IMap -> Property
-prop_lookupMin m = lookupMin m === (fst <$> minViewWithKey m)
-
-prop_lookupMax :: IMap -> Property
-prop_lookupMax m = lookupMax m === (fst <$> maxViewWithKey m)
-
-----------------------------------------------------------------
-
-prop_split :: Int -> UMap -> Bool
-prop_split k t = let (r,l) = split k t
- in (valid r, valid l) == (True, True)
-
-prop_splitRoot :: UMap -> Bool
-prop_splitRoot s = loop ls && (s == unions ls)
- where
- ls = splitRoot s
- loop [] = True
- loop (s1:rst) = List.null
- [ (x,y) | x <- toList s1
- , y <- toList (unions rst)
- , x > y ]
-
-prop_link :: Int -> UMap -> Bool
-prop_link k t = let (l,r) = split k t
- in valid (link k () l r)
-
-prop_link2 :: Int -> UMap -> Bool
-prop_link2 k t = let (l,r) = split k t
- in valid (link2 l r)
-
-----------------------------------------------------------------
-
-prop_union :: UMap -> UMap -> Bool
-prop_union t1 t2 = valid (union t1 t2)
-
-prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_unionModel xs ys
- = sort (keys (union (fromList xs) (fromList ys)))
- == sort (nub (Prelude.map fst xs ++ Prelude.map fst ys))
-
-prop_unionSingleton :: IMap -> Int -> Int -> Bool
-prop_unionSingleton t k x = union (singleton k x) t == insert k x t
-
-prop_unionAssoc :: IMap -> IMap -> IMap -> Bool
-prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_unionWith :: IMap -> IMap -> Bool
-prop_unionWith t1 t2 = (union t1 t2 == unionWith (\_ y -> y) t2 t1)
-
-prop_unionWith2 :: IMap -> IMap -> Bool
-prop_unionWith2 t1 t2 = valid (unionWithKey (\_ x y -> x+y) t1 t2)
-
-prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_unionSum xs ys
- = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
- == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
-
-prop_difference :: IMap -> IMap -> Bool
-prop_difference t1 t2 = valid (difference t1 t2)
-
-prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_differenceModel xs ys
- = sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
- == sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
-
-prop_restrictKeys :: IMap -> IMap -> Property
-prop_restrictKeys m s0 = valid restricted .&&. (m `restrictKeys` s === filterWithKey (\k _ -> k `Set.member` s) m)
- where
- s = keysSet s0
- restricted = restrictKeys m s
-
-prop_withoutKeys :: IMap -> IMap -> Property
-prop_withoutKeys m s0 = valid reduced .&&. (m `withoutKeys` s === filterWithKey (\k _ -> k `Set.notMember` s) m)
- where
- s = keysSet s0
- reduced = withoutKeys m s
-
-prop_intersection :: IMap -> IMap -> Bool
-prop_intersection t1 t2 = valid (intersection t1 t2)
-
-prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_intersectionModel xs ys
- = sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
- == sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
-
-prop_intersectionWith :: Fun (Int, Int) (Maybe Int) -> IMap -> IMap -> Bool
-prop_intersectionWith f t1 t2 = valid (intersectionWith (apply2 f) t1 t2)
-
-prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_intersectionWithModel xs ys
- = toList (intersectionWith f (fromList xs') (fromList ys'))
- == [(kx, f vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]
- where xs' = List.nubBy ((==) `on` fst) xs
- ys' = List.nubBy ((==) `on` fst) ys
- f l r = l + 2 * r
-
-prop_intersectionWithKey :: Fun (Int, Int, Int) (Maybe Int) -> IMap -> IMap -> Bool
-prop_intersectionWithKey f t1 t2 = valid (intersectionWithKey (apply3 f) t1 t2)
-
-prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_intersectionWithKeyModel xs ys
- = toList (intersectionWithKey f (fromList xs') (fromList ys'))
- == [(kx, f kx vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]
- where xs' = List.nubBy ((==) `on` fst) xs
- ys' = List.nubBy ((==) `on` fst) ys
- f k l r = k + 2 * l + 3 * r
-
-prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool
-prop_mergeWithKeyModel xs ys
- = and [ testMergeWithKey f keep_x keep_y
- | f <- [ \_k x1 _x2 -> Just x1
- , \_k _x1 x2 -> Just x2
- , \_k _x1 _x2 -> Nothing
- , \k x1 x2 -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2)
- ]
- , keep_x <- [ True, False ]
- , keep_y <- [ True, False ]
- ]
-
- where xs' = List.nubBy ((==) `on` fst) xs
- ys' = List.nubBy ((==) `on` fst) ys
-
- xm = fromList xs'
- ym = fromList ys'
-
- testMergeWithKey f keep_x keep_y
- = toList (mergeWithKey f (keep keep_x) (keep keep_y) xm ym) == emulateMergeWithKey f keep_x keep_y
- where keep False _ = empty
- keep True m = m
-
- emulateMergeWithKey f keep_x keep_y
- = Maybe.mapMaybe combine (sort $ List.union (List.map fst xs') (List.map fst ys'))
- where combine k = case (List.lookup k xs', List.lookup k ys') of
- (Nothing, Just y) -> if keep_y then Just (k, y) else Nothing
- (Just x, Nothing) -> if keep_x then Just (k, x) else Nothing
- (Just x, Just y) -> (\v -> (k, v)) `fmap` f k x y
-
- -- We prevent inlining testMergeWithKey to disable the SpecConstr
- -- optimalization. There are too many call patterns here so several
- -- warnings are issued if testMergeWithKey gets inlined.
- {-# NOINLINE testMergeWithKey #-}
-
-----------------------------------------------------------------
-
-prop_ordered :: Property
-prop_ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromAscList xs == fromList xs
-
-prop_rev_ordered :: Property
-prop_rev_ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]]
- in fromDescList (reverse xs) == fromList xs
-
-prop_list :: [Int] -> Bool
-prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
-
-prop_descList :: [Int] -> Bool
-prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])])
-
-prop_fromDistinctDescList :: Int -> [A] -> Property
-prop_fromDistinctDescList top lst = valid converted .&&. (toList converted === reverse original) where
- original = zip [top, (top-1)..0] lst
- converted = fromDistinctDescList original
-
-prop_ascDescList :: [Int] -> Bool
-prop_ascDescList xs = toAscList m == reverse (toDescList m)
- where m = fromList $ zip xs $ repeat ()
-
-prop_fromList :: [Int] -> Bool
-prop_fromList xs
- = case fromList (zip xs xs) of
- t -> t == fromAscList (zip sort_xs sort_xs) &&
- t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&
- t == List.foldr (uncurry insert) empty (zip xs xs)
- where sort_xs = sort xs
- nub_sort_xs = List.map List.head $ List.group sort_xs
-
-----------------------------------------------------------------
-
-prop_alter :: UMap -> Int -> Bool
-prop_alter t k = balanced t' && case lookup k t of
- Just _ -> (size t - 1) == size t' && lookup k t' == Nothing
- Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing
- where
- t' = alter f k t
- f Nothing = Just ()
- f (Just ()) = Nothing
-
-prop_alterF_alter :: Fun (Maybe Int) (Maybe Int) -> Int -> IMap -> Bool
-prop_alterF_alter f k m = valid altered && altered == alter (apply f) k m
- where altered = atAlter (apply f) k m
-
-prop_alterF_alter_noRULES :: Fun (Maybe Int) (Maybe Int) -> Int -> IMap -> Bool
-prop_alterF_alter_noRULES f k m = valid altered &&
- altered == alter (apply f) k m
- where altered = atAlterNoRULES (apply f) k m
-
-prop_alterF_lookup :: Int -> IMap -> Bool
-prop_alterF_lookup k m = atLookup k m == lookup k m
-
-prop_alterF_lookup_noRULES :: Int -> IMap -> Bool
-prop_alterF_lookup_noRULES k m = atLookupNoRULES k m == lookup k m
-
-------------------------------------------------------------------------
--- Compare against the list model (after nub on keys)
-
-prop_index :: [Int] -> Property
-prop_index xs = length xs > 0 ==>
- let m = fromList (zip xs xs)
- in xs == [ m ! i | i <- xs ]
-
-prop_null :: IMap -> Bool
-prop_null m = null m == (size m == 0)
-
-prop_member :: [Int] -> Int -> Bool
-prop_member xs n =
- let m = fromList (zip xs xs)
- in all (\k -> k `member` m == (k `elem` xs)) (n : xs)
-
-prop_notmember :: [Int] -> Int -> Bool
-prop_notmember xs n =
- let m = fromList (zip xs xs)
- in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)
-
-prop_lookup :: [(Int, Int)] -> Int -> Bool
-prop_lookup xs n =
- let xs' = List.nubBy ((==) `on` fst) xs
- m = fromList xs'
- in all (\k -> lookup k m == List.lookup k xs') (n : List.map fst xs')
-
-prop_find :: [(Int, Int)] -> Bool
-prop_find xs =
- let xs' = List.nubBy ((==) `on` fst) xs
- m = fromList xs'
- in all (\(k, v) -> m ! k == v) xs'
-
-prop_findWithDefault :: [(Int, Int)] -> Int -> Int -> Bool
-prop_findWithDefault xs n x =
- let xs' = List.nubBy ((==) `on` fst) xs
- m = fromList xs'
- in all (\k -> findWithDefault x k m == maybe x id (List.lookup k xs')) (n : List.map fst xs')
-
-test_lookupSomething :: (Int -> Map Int Int -> Maybe (Int, Int)) -> (Int -> Int -> Bool) -> [(Int, Int)] -> Bool
-test_lookupSomething lookup' cmp xs =
- let odd_sorted_xs = filter_odd $ sort $ List.nubBy ((==) `on` fst) xs
- t = fromList odd_sorted_xs
- test k = case List.filter ((`cmp` k) . fst) odd_sorted_xs of
- [] -> lookup' k t == Nothing
- cs | 0 `cmp` 1 -> lookup' k t == Just (last cs) -- we want largest such element
- | otherwise -> lookup' k t == Just (head cs) -- we want smallest such element
- in all test (List.map fst xs)
-
- where filter_odd [] = []
- filter_odd [_] = []
- filter_odd (_ : o : xs) = o : filter_odd xs
-
-prop_lookupLT :: [(Int, Int)] -> Bool
-prop_lookupLT = test_lookupSomething lookupLT (<)
-
-prop_lookupGT :: [(Int, Int)] -> Bool
-prop_lookupGT = test_lookupSomething lookupGT (>)
-
-prop_lookupLE :: [(Int, Int)] -> Bool
-prop_lookupLE = test_lookupSomething lookupLE (<=)
-
-prop_lookupGE :: [(Int, Int)] -> Bool
-prop_lookupGE = test_lookupSomething lookupGE (>=)
-
-prop_findIndex :: [(Int, Int)] -> Property
-prop_findIndex ys = length ys > 0 ==>
- let m = fromList ys
- in findIndex (fst (head ys)) m `seq` True
-
-prop_lookupIndex :: [(Int, Int)] -> Property
-prop_lookupIndex ys = length ys > 0 ==>
- let m = fromList ys
- in isJust (lookupIndex (fst (head ys)) m)
-
-prop_findMin :: [(Int, Int)] -> Property
-prop_findMin ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in findMin m == List.minimumBy (comparing fst) xs
-
-prop_findMax :: [(Int, Int)] -> Property
-prop_findMax ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in findMax m == List.maximumBy (comparing fst) xs
-
-prop_deleteMinModel :: [(Int, Int)] -> Property
-prop_deleteMinModel ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in toAscList (deleteMin m) == tail (sort xs)
-
-prop_deleteMaxModel :: [(Int, Int)] -> Property
-prop_deleteMaxModel ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in toAscList (deleteMax m) == init (sort xs)
-
-prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property
-prop_filter p ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in filter (apply p) m == fromList (List.filter (apply p . snd) xs)
-
-prop_take :: Int -> Map Int Int -> Property
-prop_take n xs = valid taken .&&.
- taken === fromDistinctAscList (List.take n (toList xs))
- where
- taken = take n xs
-
-prop_drop :: Int -> Map Int Int -> Property
-prop_drop n xs = valid dropped .&&.
- dropped === fromDistinctAscList (List.drop n (toList xs))
- where
- dropped = drop n xs
-
-prop_splitAt :: Int -> Map Int Int -> Property
-prop_splitAt n xs = valid taken .&&.
- valid dropped .&&.
- taken === take n xs .&&.
- dropped === drop n xs
- where
- (taken, dropped) = splitAt n xs
-
-prop_takeWhileAntitone :: [(Either Int Int, Int)] -> Property
-prop_takeWhileAntitone xs' = valid tw .&&. (tw === filterWithKey (\k _ -> isLeft k) xs)
- where
- xs = fromList xs'
- tw = takeWhileAntitone isLeft xs
-
-prop_dropWhileAntitone :: [(Either Int Int, Int)] -> Property
-prop_dropWhileAntitone xs' = valid tw .&&. (tw === filterWithKey (\k _ -> not (isLeft k)) xs)
- where
- xs = fromList xs'
- tw = dropWhileAntitone isLeft xs
-
-prop_spanAntitone :: [(Either Int Int, Int)] -> Property
-prop_spanAntitone xs' = valid tw .&&. valid dw
- .&&. (tw === takeWhileAntitone isLeft xs)
- .&&. (dw === dropWhileAntitone isLeft xs)
- where
- xs = fromList xs'
- (tw, dw) = spanAntitone isLeft xs
-
-isLeft :: Either a b -> Bool
-isLeft (Left _) = True
-isLeft _ = False
-
-prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property
-prop_partition p ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in partition (apply p) m == let (a,b) = (List.partition (apply p . snd) xs) in (fromList a, fromList b)
-
-prop_map :: Fun Int Int -> [(Int, Int)] -> Property
-prop_map f ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in map (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ]
-
-prop_fmap :: Fun Int Int -> [(Int, Int)] -> Property
-prop_fmap f ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in fmap (apply f) m == fromList [ (a, (apply f) b) | (a,b) <- xs ]
-
-prop_mapkeys :: Fun Int Int -> [(Int, Int)] -> Property
-prop_mapkeys f ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in mapKeys (apply f) m == (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs])
-
-prop_splitModel :: Int -> [(Int, Int)] -> Property
-prop_splitModel n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- (l, r) = split n $ fromList xs
- in toAscList l == sort [(k, v) | (k,v) <- xs, k < n] &&
- toAscList r == sort [(k, v) | (k,v) <- xs, k > n]
-
-prop_foldr :: Int -> [(Int, Int)] -> Property
-prop_foldr n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldr (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldr (:) [] m == List.map snd (List.sort xs) &&
- foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldrWithKey (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldrWithKey (\k x xs -> (k,x):xs) [] m == List.sort xs
-
-
-prop_foldr' :: Int -> [(Int, Int)] -> Property
-prop_foldr' n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldr' (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldr' (:) [] m == List.map snd (List.sort xs) &&
- foldrWithKey' (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldrWithKey' (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldrWithKey' (\k x xs -> (k,x):xs) [] m == List.sort xs
-
-prop_foldl :: Int -> [(Int, Int)] -> Property
-prop_foldl n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldl (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&
- foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldlWithKey (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldlWithKey (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)
-
-prop_foldl' :: Int -> [(Int, Int)] -> Property
-prop_foldl' n ys = length ys > 0 ==>
- let xs = List.nubBy ((==) `on` fst) ys
- m = fromList xs
- in foldl' (+) n m == List.foldr (+) n (List.map snd xs) &&
- foldl' (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&
- foldlWithKey' (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&
- foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
- foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)
-
-prop_keysSet :: [(Int, Int)] -> Bool
-prop_keysSet xs =
- keysSet (fromList xs) == Set.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) (Set.fromList $ List.map fst xs) == fromList xs
diff --git a/tests/map-strictness.hs b/tests/map-strictness.hs
deleted file mode 100644
index 6bc317f..0000000
--- a/tests/map-strictness.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Main (main) where
-
-import Test.ChasingBottoms.IsBottom
-import Test.Framework (Test, defaultMain, testGroup)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck (Arbitrary(arbitrary))
-import Test.QuickCheck.Function (Fun(..), apply)
-
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-
-instance (Arbitrary k, Arbitrary v, Ord k) =>
- Arbitrary (Map k v) where
- arbitrary = M.fromList `fmap` arbitrary
-
-apply2 :: Fun (a, b) c -> a -> b -> c
-apply2 f a b = apply f (a, b)
-
-apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
-apply3 f a b c = apply f (a, b, c)
-
-------------------------------------------------------------------------
--- * Properties
-
-------------------------------------------------------------------------
--- ** Strict module
-
-pSingletonKeyStrict :: Int -> Bool
-pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v
-
-pSingletonValueStrict :: Int -> Bool
-pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))
-
-pFindWithDefaultKeyStrict :: Int -> Map Int Int -> Bool
-pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m
-
-pFindWithDefaultValueStrict :: Int -> Map Int Int -> Bool
-pFindWithDefaultValueStrict k m =
- M.member k m || (isBottom $ M.findWithDefault bottom k m)
-
-pAdjustKeyStrict :: Fun Int Int -> Map Int Int -> Bool
-pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m
-
-pAdjustValueStrict :: Int -> Map Int Int -> Bool
-pAdjustValueStrict k m
- | k `M.member` m = isBottom $ M.adjust (const bottom) k m
- | otherwise = case M.keys m of
- [] -> True
- (k':_) -> isBottom $ M.adjust (const bottom) k' m
-
-pInsertKeyStrict :: Int -> Map Int Int -> Bool
-pInsertKeyStrict v m = isBottom $ M.insert bottom v m
-
-pInsertValueStrict :: Int -> Map Int Int -> Bool
-pInsertValueStrict k m = isBottom $ M.insert k bottom m
-
-pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> Map Int Int -> Bool
-pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m
-
-pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> Map Int Int
- -> Bool
-pInsertWithValueStrict f k v m
- | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&
- not (isBottom $ M.insertWith (const2 1) k bottom m)
- | otherwise = isBottom $ M.insertWith (apply2 f) k bottom m
-
-pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int
- -> Map Int Int -> Bool
-pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m
-
-pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int
- -> Map Int Int -> Bool
-pInsertLookupWithKeyValueStrict f k v m
- | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&
- not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
- | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
-
-------------------------------------------------------------------------
--- * Test list
-
-tests :: [Test]
-tests =
- [
- -- Basic interface
- testGroup "Map.Strict"
- [ testProperty "singleton is key-strict" pSingletonKeyStrict
- , testProperty "singleton is value-strict" pSingletonValueStrict
- , testProperty "member is key-strict" $ keyStrict M.member
- , testProperty "lookup is key-strict" $ keyStrict M.lookup
- , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict
- , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict
- , testProperty "! is key-strict" $ keyStrict (flip (M.!))
- , testProperty "delete is key-strict" $ keyStrict M.delete
- , testProperty "adjust is key-strict" pAdjustKeyStrict
- , testProperty "adjust is value-strict" pAdjustValueStrict
- , testProperty "insert is key-strict" pInsertKeyStrict
- , testProperty "insert is value-strict" pInsertValueStrict
- , testProperty "insertWith is key-strict" pInsertWithKeyStrict
- , testProperty "insertWith is value-strict" pInsertWithValueStrict
- , testProperty "insertLookupWithKey is key-strict"
- pInsertLookupWithKeyKeyStrict
- , testProperty "insertLookupWithKey is value-strict"
- pInsertLookupWithKeyValueStrict
- ]
- ]
-
-------------------------------------------------------------------------
--- * Test harness
-
-main :: IO ()
-main = defaultMain tests
-
-------------------------------------------------------------------------
--- * Utilities
-
-keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool
-keyStrict f m = isBottom $ f bottom m
-
-const2 :: a -> b -> c -> a
-const2 x _ _ = x
-
-const3 :: a -> b -> c -> d -> a
-const3 x _ _ _ = x
diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs
deleted file mode 100644
index 7f29ade..0000000
--- a/tests/seq-properties.hs
+++ /dev/null
@@ -1,919 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
-
-#include "containers.h"
-
-import Data.Sequence.Internal
- ( Sized (..)
- , Seq (Seq)
- , FingerTree(..)
- , Node(..)
- , Elem(..)
- , Digit (..)
- , node2
- , node3
- , deep )
-
-import Data.Sequence
-
-import Control.Applicative (Applicative(..), liftA2)
-import Control.Arrow ((***))
-import Control.Monad.Trans.State.Strict
-import Data.Array (listArray)
-import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, fold), toList, all, sum, foldl', foldr')
-import Data.Functor ((<$>), (<$))
-import Data.Maybe
-import Data.Function (on)
-import Data.Monoid (Monoid(..), All(..), Endo(..), Dual(..))
-import Data.Traversable (Traversable(traverse), sequenceA)
-import Prelude hiding (
- lookup, null, length, take, drop, splitAt,
- foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1,
- filter, reverse, replicate, zip, zipWith, zip3, zipWith3,
- all, sum)
-import qualified Prelude
-import qualified Data.List
-import Test.QuickCheck hiding ((><))
-import Test.QuickCheck.Poly
-#if __GLASGOW_HASKELL__ >= 800
-import Test.QuickCheck.Property
-#endif
-import Test.QuickCheck.Function
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Control.Monad.Zip (MonadZip (..))
-import Control.DeepSeq (deepseq)
-import Control.Monad.Fix (MonadFix (..))
-
-
-main :: IO ()
-main = defaultMain
- [ testProperty "fmap" prop_fmap
- , testProperty "(<$)" prop_constmap
- , testProperty "foldr" prop_foldr
- , testProperty "foldr'" prop_foldr'
- , testProperty "lazy foldr'" prop_lazyfoldr'
- , testProperty "foldr1" prop_foldr1
- , testProperty "foldl" prop_foldl
- , testProperty "foldl'" prop_foldl'
- , testProperty "lazy foldl'" prop_lazyfoldl'
- , testProperty "foldl1" prop_foldl1
- , testProperty "(==)" prop_equals
- , testProperty "compare" prop_compare
- , testProperty "mappend" prop_mappend
- , testProperty "singleton" prop_singleton
- , testProperty "(<|)" prop_cons
- , testProperty "(|>)" prop_snoc
- , testProperty "(><)" prop_append
- , testProperty "fromList" prop_fromList
- , testProperty "fromFunction" prop_fromFunction
- , testProperty "fromArray" prop_fromArray
- , testProperty "replicate" prop_replicate
- , testProperty "replicateA" prop_replicateA
- , testProperty "replicateM" prop_replicateM
- , testProperty "iterateN" prop_iterateN
- , testProperty "unfoldr" prop_unfoldr
- , testProperty "unfoldl" prop_unfoldl
- , testProperty "null" prop_null
- , testProperty "length" prop_length
- , testProperty "viewl" prop_viewl
- , testProperty "viewr" prop_viewr
- , testProperty "scanl" prop_scanl
- , testProperty "scanl1" prop_scanl1
- , testProperty "scanr" prop_scanr
- , testProperty "scanr1" prop_scanr1
- , testProperty "tails" prop_tails
- , testProperty "inits" prop_inits
- , testProperty "takeWhileL" prop_takeWhileL
- , testProperty "takeWhileR" prop_takeWhileR
- , testProperty "dropWhileL" prop_dropWhileL
- , testProperty "dropWhileR" prop_dropWhileR
- , testProperty "spanl" prop_spanl
- , testProperty "spanr" prop_spanr
- , testProperty "breakl" prop_breakl
- , testProperty "breakr" prop_breakr
- , testProperty "partition" prop_partition
- , testProperty "filter" prop_filter
- , testProperty "sort" prop_sort
- , testProperty "sortStable" prop_sortStable
- , testProperty "sortBy" prop_sortBy
- , testProperty "sortOn" prop_sortOn
- , testProperty "sortOnStable" prop_sortOnStable
- , testProperty "unstableSort" prop_unstableSort
- , testProperty "unstableSortBy" prop_unstableSortBy
- , testProperty "unstableSortOn" prop_unstableSortOn
- , testProperty "index" prop_index
- , testProperty "(!?)" prop_safeIndex
- , testProperty "adjust" prop_adjust
- , testProperty "insertAt" prop_insertAt
- , testProperty "deleteAt" prop_deleteAt
- , testProperty "update" prop_update
- , testProperty "take" prop_take
- , testProperty "drop" prop_drop
- , testProperty "splitAt" prop_splitAt
- , testProperty "chunksOf" prop_chunksOf
- , testProperty "elemIndexL" prop_elemIndexL
- , testProperty "elemIndicesL" prop_elemIndicesL
- , testProperty "elemIndexR" prop_elemIndexR
- , testProperty "elemIndicesR" prop_elemIndicesR
- , testProperty "findIndexL" prop_findIndexL
- , testProperty "findIndicesL" prop_findIndicesL
- , testProperty "findIndexR" prop_findIndexR
- , testProperty "findIndicesR" prop_findIndicesR
- , testProperty "foldlWithIndex" prop_foldlWithIndex
- , testProperty "foldrWithIndex" prop_foldrWithIndex
- , testProperty "mapWithIndex" prop_mapWithIndex
- , testProperty "foldMapWithIndex/foldlWithIndex" prop_foldMapWithIndexL
- , testProperty "foldMapWithIndex/foldrWithIndex" prop_foldMapWithIndexR
- , testProperty "traverseWithIndex" prop_traverseWithIndex
- , testProperty "reverse" prop_reverse
- , testProperty "zip" prop_zip
- , testProperty "zipWith" prop_zipWith
- , testProperty "zip3" prop_zip3
- , testProperty "zipWith3" prop_zipWith3
- , testProperty "zip4" prop_zip4
- , testProperty "zipWith4" prop_zipWith4
- , testProperty "mzip-naturality" prop_mzipNaturality
- , testProperty "mzip-preservation" prop_mzipPreservation
- , testProperty "munzip-lazy" prop_munzipLazy
- , testProperty "<*>" prop_ap
- , testProperty "<*> NOINLINE" prop_ap_NOINLINE
- , testProperty "liftA2" prop_liftA2
- , testProperty "*>" prop_then
- , testProperty "cycleTaking" prop_cycleTaking
- , testProperty "intersperse" prop_intersperse
- , testProperty ">>=" prop_bind
- , testProperty "mfix" test_mfix
-#if __GLASGOW_HASKELL__ >= 800
- , testProperty "Empty pattern" prop_empty_pat
- , testProperty "Empty constructor" prop_empty_con
- , testProperty "Left view pattern" prop_viewl_pat
- , testProperty "Left view constructor" prop_viewl_con
- , testProperty "Right view pattern" prop_viewr_pat
- , testProperty "Right view constructor" prop_viewr_con
-#endif
- ]
-
-------------------------------------------------------------------------
--- Arbitrary
-------------------------------------------------------------------------
-
-instance Arbitrary a => Arbitrary (Seq a) where
- arbitrary = Seq <$> arbitrary
- shrink (Seq x) = map Seq (shrink x)
-
-instance Arbitrary a => Arbitrary (Elem a) where
- arbitrary = Elem <$> arbitrary
-
-instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
- arbitrary = sized arb
- where
- arb :: (Arbitrary b, Sized b) => Int -> Gen (FingerTree b)
- arb 0 = return EmptyT
- arb 1 = Single <$> arbitrary
- arb n = do
- pr <- arbitrary
- sf <- arbitrary
- let n_pr = Prelude.length (toList pr)
- let n_sf = Prelude.length (toList sf)
- -- adding n `div` 7 ensures that n_m >= 0, and makes more Singles
- let n_m = max (n `div` 7) ((n - n_pr - n_sf) `div` 3)
- m <- arb n_m
- return $ deep pr m sf
-
- shrink (Deep _ (One a) EmptyT (One b)) = [Single a, Single b]
- shrink (Deep _ pr m sf) =
- [deep pr' m sf | pr' <- shrink pr] ++
- [deep pr m' sf | m' <- shrink m] ++
- [deep pr m sf' | sf' <- shrink sf]
- shrink (Single x) = map Single (shrink x)
- shrink EmptyT = []
-
-instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
- arbitrary = oneof [
- node2 <$> arbitrary <*> arbitrary,
- node3 <$> arbitrary <*> arbitrary <*> arbitrary]
-
- shrink (Node2 _ a b) =
- [node2 a' b | a' <- shrink a] ++
- [node2 a b' | b' <- shrink b]
- shrink (Node3 _ a b c) =
- [node2 a b, node2 a c, node2 b c] ++
- [node3 a' b c | a' <- shrink a] ++
- [node3 a b' c | b' <- shrink b] ++
- [node3 a b c' | c' <- shrink c]
-
-instance Arbitrary a => Arbitrary (Digit a) where
- arbitrary = oneof [
- One <$> arbitrary,
- Two <$> arbitrary <*> arbitrary,
- Three <$> arbitrary <*> arbitrary <*> arbitrary,
- Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]
-
- shrink (One a) = map One (shrink a)
- shrink (Two a b) = [One a, One b]
- shrink (Three a b c) = [Two a b, Two a c, Two b c]
- shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
-
-------------------------------------------------------------------------
--- Valid trees
-------------------------------------------------------------------------
-
-class Valid a where
- valid :: a -> Bool
-
-instance Valid (Elem a) where
- valid _ = True
-
-instance Valid (Seq a) where
- valid (Seq xs) = valid xs
-
-instance (Sized a, Valid a) => Valid (FingerTree a) where
- valid EmptyT = True
- valid (Single x) = valid x
- valid (Deep s pr m sf) =
- s == size pr + size m + size sf && valid pr && valid m && valid sf
-
-instance (Sized a, Valid a) => Valid (Node a) where
- valid node = size node == sum (fmap size node) && all valid node
-
-instance Valid a => Valid (Digit a) where
- valid = all valid
-
-{--------------------------------------------------------------------
- The general plan is to compare each function with a list equivalent.
- Each operation should produce a valid tree representing the same
- sequence as produced by its list counterpart on corresponding inputs.
- (The list versions are often lazier, but these properties ignore
- strictness.)
---------------------------------------------------------------------}
-
--- utilities for partial conversions
-
-infix 4 ~=
-
-(~=) :: Eq a => Maybe a -> a -> Bool
-(~=) = maybe (const False) (==)
-
--- Partial conversion of an output sequence to a list.
-toList' :: Seq a -> Maybe [a]
-toList' xs
- | valid xs = Just (toList xs)
- | otherwise = Nothing
-
-toListList' :: Seq (Seq a) -> Maybe [[a]]
-toListList' xss = toList' xss >>= mapM toList'
-
-toListPair' :: (Seq a, Seq b) -> Maybe ([a], [b])
-toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys
-
--- Extra "polymorphic" test type
-newtype D = D{ unD :: Integer }
- deriving ( Eq )
-
-instance Show D where
- showsPrec n (D x) = showsPrec n x
-
-instance Arbitrary D where
- arbitrary = (D . (+1) . abs) `fmap` arbitrary
- shrink (D x) = [ D x' | x' <- shrink x, x' > 0 ]
-
-instance CoArbitrary D where
- coarbitrary = coarbitrary . unD
-
--- instances
-
-prop_fmap :: Seq Int -> Bool
-prop_fmap xs =
- toList' (fmap f xs) ~= map f (toList xs)
- where f = (+100)
-
-prop_constmap :: A -> Seq A -> Bool
-prop_constmap x xs =
- toList' (x <$ xs) ~= map (const x) (toList xs)
-
-prop_foldr :: Seq A -> Property
-prop_foldr xs =
- foldr f z xs === Prelude.foldr f z (toList xs)
- where
- f = (:)
- z = []
-
-prop_foldr' :: Seq A -> Property
-prop_foldr' xs =
- foldr' f z xs === foldr' f z (toList xs)
- where
- f = (:)
- z = []
-
-prop_lazyfoldr' :: Seq () -> Property
-prop_lazyfoldr' xs =
- not (null xs) ==>
- foldr'
- (\e _ ->
- e)
- (error "Data.Sequence.foldr': should be lazy in initial accumulator")
- xs ===
- ()
-
-prop_foldr1 :: Seq Int -> Property
-prop_foldr1 xs =
- not (null xs) ==> foldr1 f xs == Data.List.foldr1 f (toList xs)
- where f = (-)
-
-prop_foldl :: Seq A -> Property
-prop_foldl xs =
- foldl f z xs === Prelude.foldl f z (toList xs)
- where
- f = flip (:)
- z = []
-
-prop_foldl' :: Seq A -> Property
-prop_foldl' xs =
- foldl' f z xs === foldl' f z (toList xs)
- where
- f = flip (:)
- z = []
-
-prop_lazyfoldl' :: Seq () -> Property
-prop_lazyfoldl' xs =
- not (null xs) ==>
- foldl'
- (\_ e ->
- e)
- (error "Data.Sequence.foldl': should be lazy in initial accumulator")
- xs ===
- ()
-
-prop_foldl1 :: Seq Int -> Property
-prop_foldl1 xs =
- not (null xs) ==> foldl1 f xs == Data.List.foldl1 f (toList xs)
- where f = (-)
-
-prop_equals :: Seq OrdA -> Seq OrdA -> Bool
-prop_equals xs ys =
- (xs == ys) == (toList xs == toList ys)
-
-prop_compare :: Seq OrdA -> Seq OrdA -> Bool
-prop_compare xs ys =
- compare xs ys == compare (toList xs) (toList ys)
-
-prop_mappend :: Seq A -> Seq A -> Bool
-prop_mappend xs ys =
- toList' (mappend xs ys) ~= toList xs ++ toList ys
-
--- * Construction
-
-{-
- toList' empty ~= []
--}
-
-prop_singleton :: A -> Bool
-prop_singleton x =
- toList' (singleton x) ~= [x]
-
-prop_cons :: A -> Seq A -> Bool
-prop_cons x xs =
- toList' (x <| xs) ~= x : toList xs
-
-prop_snoc :: Seq A -> A -> Bool
-prop_snoc xs x =
- toList' (xs |> x) ~= toList xs ++ [x]
-
-prop_append :: Seq A -> Seq A -> Bool
-prop_append xs ys =
- toList' (xs >< ys) ~= toList xs ++ toList ys
-
-prop_fromList :: [A] -> Bool
-prop_fromList xs =
- toList' (fromList xs) ~= xs
-
-prop_fromFunction :: [A] -> Bool
-prop_fromFunction xs =
- toList' (fromFunction (Prelude.length xs) (xs!!)) ~= xs
-
-prop_fromArray :: [A] -> Bool
-prop_fromArray xs =
- toList' (fromArray (listArray (42, 42+Prelude.length xs-1) xs)) ~= xs
-
--- ** Repetition
-
-prop_replicate :: NonNegative Int -> A -> Bool
-prop_replicate (NonNegative m) x =
- toList' (replicate n x) ~= Prelude.replicate n x
- where n = m `mod` 10000
-
-prop_replicateA :: NonNegative Int -> Bool
-prop_replicateA (NonNegative m) =
- traverse toList' (replicateA n a) ~= sequenceA (Prelude.replicate n a)
- where
- n = m `mod` 10000
- a = Action 1 0 :: M Int
-
-prop_replicateM :: NonNegative Int -> Bool
-prop_replicateM (NonNegative m) =
- traverse toList' (replicateM n a) ~= sequence (Prelude.replicate n a)
- where
- n = m `mod` 10000
- a = Action 1 0 :: M Int
-
--- ** Iterative construction
-
-prop_iterateN :: NonNegative Int -> Int -> Bool
-prop_iterateN (NonNegative m) x =
- toList' (iterateN n f x) ~= Prelude.take n (Prelude.iterate f x)
- where
- n = m `mod` 10000
- f = (+1)
-
-prop_unfoldr :: [A] -> Bool
-prop_unfoldr z =
- toList' (unfoldr f z) ~= Data.List.unfoldr f z
- where
- f [] = Nothing
- f (x:xs) = Just (x, xs)
-
-prop_unfoldl :: [A] -> Bool
-prop_unfoldl z =
- toList' (unfoldl f z) ~= Data.List.reverse (Data.List.unfoldr (fmap swap . f) z)
- where
- f [] = Nothing
- f (x:xs) = Just (xs, x)
- swap (x,y) = (y,x)
-
--- * Deconstruction
-
--- ** Queries
-
-prop_null :: Seq A -> Bool
-prop_null xs =
- null xs == Prelude.null (toList xs)
-
-prop_length :: Seq A -> Bool
-prop_length xs =
- length xs == Prelude.length (toList xs)
-
--- ** Views
-
-prop_viewl :: Seq A -> Bool
-prop_viewl xs =
- case viewl xs of
- EmptyL -> Prelude.null (toList xs)
- x :< xs' -> valid xs' && toList xs == x : toList xs'
-
-prop_viewr :: Seq A -> Bool
-prop_viewr xs =
- case viewr xs of
- EmptyR -> Prelude.null (toList xs)
- xs' :> x -> valid xs' && toList xs == toList xs' ++ [x]
-
--- * Scans
-
-prop_scanl :: [A] -> Seq A -> Bool
-prop_scanl z xs =
- toList' (scanl f z xs) ~= Data.List.scanl f z (toList xs)
- where f = flip (:)
-
-prop_scanl1 :: Seq Int -> Property
-prop_scanl1 xs =
- not (null xs) ==> toList' (scanl1 f xs) ~= Data.List.scanl1 f (toList xs)
- where f = (-)
-
-prop_scanr :: [A] -> Seq A -> Bool
-prop_scanr z xs =
- toList' (scanr f z xs) ~= Data.List.scanr f z (toList xs)
- where f = (:)
-
-prop_scanr1 :: Seq Int -> Property
-prop_scanr1 xs =
- not (null xs) ==> toList' (scanr1 f xs) ~= Data.List.scanr1 f (toList xs)
- where f = (-)
-
--- * Sublists
-
-prop_tails :: Seq A -> Bool
-prop_tails xs =
- toListList' (tails xs) ~= Data.List.tails (toList xs)
-
-prop_inits :: Seq A -> Bool
-prop_inits xs =
- toListList' (inits xs) ~= Data.List.inits (toList xs)
-
--- ** Sequential searches
--- We use predicates with varying density.
-
-prop_takeWhileL :: Positive Int -> Seq Int -> Bool
-prop_takeWhileL (Positive n) xs =
- toList' (takeWhileL p xs) ~= Prelude.takeWhile p (toList xs)
- where p x = x `mod` n == 0
-
-prop_takeWhileR :: Positive Int -> Seq Int -> Bool
-prop_takeWhileR (Positive n) xs =
- toList' (takeWhileR p xs) ~= Prelude.reverse (Prelude.takeWhile p (Prelude.reverse (toList xs)))
- where p x = x `mod` n == 0
-
-prop_dropWhileL :: Positive Int -> Seq Int -> Bool
-prop_dropWhileL (Positive n) xs =
- toList' (dropWhileL p xs) ~= Prelude.dropWhile p (toList xs)
- where p x = x `mod` n == 0
-
-prop_dropWhileR :: Positive Int -> Seq Int -> Bool
-prop_dropWhileR (Positive n) xs =
- toList' (dropWhileR p xs) ~= Prelude.reverse (Prelude.dropWhile p (Prelude.reverse (toList xs)))
- where p x = x `mod` n == 0
-
-prop_spanl :: Positive Int -> Seq Int -> Bool
-prop_spanl (Positive n) xs =
- toListPair' (spanl p xs) ~= Data.List.span p (toList xs)
- where p x = x `mod` n == 0
-
-prop_spanr :: Positive Int -> Seq Int -> Bool
-prop_spanr (Positive n) xs =
- toListPair' (spanr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.span p (Prelude.reverse (toList xs)))
- where p x = x `mod` n == 0
-
-prop_breakl :: Positive Int -> Seq Int -> Bool
-prop_breakl (Positive n) xs =
- toListPair' (breakl p xs) ~= Data.List.break p (toList xs)
- where p x = x `mod` n == 0
-
-prop_breakr :: Positive Int -> Seq Int -> Bool
-prop_breakr (Positive n) xs =
- toListPair' (breakr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.break p (Prelude.reverse (toList xs)))
- where p x = x `mod` n == 0
-
-prop_partition :: Positive Int -> Seq Int -> Bool
-prop_partition (Positive n) xs =
- toListPair' (partition p xs) ~= Data.List.partition p (toList xs)
- where p x = x `mod` n == 0
-
-prop_filter :: Positive Int -> Seq Int -> Bool
-prop_filter (Positive n) xs =
- toList' (filter p xs) ~= Prelude.filter p (toList xs)
- where p x = x `mod` n == 0
-
--- * Sorting
-
-prop_sort :: Seq OrdA -> Bool
-prop_sort xs =
- toList' (sort xs) ~= Data.List.sort (toList xs)
-
-data UnstableOrd = UnstableOrd
- { ordKey :: OrdA
- , _ignored :: A
- } deriving (Show)
-
-instance Eq UnstableOrd where
- x == y = compare x y == EQ
-
-instance Ord UnstableOrd where
- compare (UnstableOrd x _) (UnstableOrd y _) = compare x y
-
-instance Arbitrary UnstableOrd where
- arbitrary = liftA2 UnstableOrd arbitrary arbitrary
- shrink (UnstableOrd x y) =
- [ UnstableOrd x' y'
- | (x',y') <- shrink (x, y) ]
-
-prop_sortStable :: Seq UnstableOrd -> Bool
-prop_sortStable xs =
- (fmap . fmap) unignore (toList' (sort xs)) ~=
- fmap unignore (Data.List.sort (toList xs))
- where
- unignore (UnstableOrd x y) = (x, y)
-
-prop_sortBy :: Seq (OrdA, B) -> Bool
-prop_sortBy xs =
- toList' (sortBy f xs) ~= Data.List.sortBy f (toList xs)
- where f (x1, _) (x2, _) = compare x1 x2
-
-prop_sortOn :: Fun A OrdB -> Seq A -> Bool
-prop_sortOn (Fun _ f) xs =
- toList' (sortOn f xs) ~= listSortOn f (toList xs)
- where
-#if MIN_VERSION_base(4,8,0)
- listSortOn = Data.List.sortOn
-#else
- listSortOn k = Data.List.sortBy (compare `on` k)
-#endif
-
-prop_sortOnStable :: Fun A UnstableOrd -> Seq A -> Bool
-prop_sortOnStable (Fun _ f) xs =
- toList' (sortOn f xs) ~= listSortOn f (toList xs)
- where
-#if MIN_VERSION_base(4,8,0)
- listSortOn = Data.List.sortOn
-#else
- listSortOn k = Data.List.sortBy (compare `on` k)
-#endif
-
-prop_unstableSort :: Seq OrdA -> Bool
-prop_unstableSort xs =
- toList' (unstableSort xs) ~= Data.List.sort (toList xs)
-
-prop_unstableSortBy :: Seq OrdA -> Bool
-prop_unstableSortBy xs =
- toList' (unstableSortBy compare xs) ~= Data.List.sort (toList xs)
-
-prop_unstableSortOn :: Fun A OrdB -> Seq A -> Property
-prop_unstableSortOn (Fun _ f) xs =
- toList' (unstableSortBy (compare `on` f) xs) === toList' (unstableSortOn f xs)
-
--- * Indexing
-
-prop_index :: Seq A -> Property
-prop_index xs =
- not (null xs) ==> forAll (choose (0, length xs-1)) $ \ i ->
- index xs i == toList xs !! i
-
-prop_safeIndex :: Seq A -> Property
-prop_safeIndex xs =
- forAll (choose (-3, length xs + 3)) $ \i ->
- ((i < 0 || i >= length xs) .&&. lookup i xs === Nothing) .||.
- lookup i xs === Just (toList xs !! i)
-
-prop_insertAt :: A -> Seq A -> Property
-prop_insertAt x xs =
- forAll (choose (-3, length xs + 3)) $ \i ->
- let res = insertAt i x xs
- in valid res .&&. res === case splitAt i xs of (front, back) -> front >< x <| back
-
-prop_deleteAt :: Seq A -> Property
-prop_deleteAt xs =
- forAll (choose (-3, length xs + 3)) $ \i ->
- let res = deleteAt i xs
- in valid res .&&.
- (((0 <= i && i < length xs) .&&. res === case splitAt i xs of (front, back) -> front >< drop 1 back)
- .||. ((i < 0 || i >= length xs) .&&. res === xs))
-
-prop_adjust :: Int -> Int -> Seq Int -> Bool
-prop_adjust n i xs =
- toList' (adjust f i xs) ~= adjustList f i (toList xs)
- where f = (+n)
-
-prop_update :: Int -> A -> Seq A -> Bool
-prop_update i x xs =
- toList' (update i x xs) ~= adjustList (const x) i (toList xs)
-
-prop_take :: Int -> Seq A -> Bool
-prop_take n xs =
- toList' (take n xs) ~= Prelude.take n (toList xs)
-
-prop_drop :: Int -> Seq A -> Bool
-prop_drop n xs =
- toList' (drop n xs) ~= Prelude.drop n (toList xs)
-
-prop_splitAt :: Int -> Seq A -> Bool
-prop_splitAt n xs =
- toListPair' (splitAt n xs) ~= Prelude.splitAt n (toList xs)
-
-prop_chunksOf :: Seq A -> Property
-prop_chunksOf xs =
- forAll (choose (1, length xs + 3)) $ \n ->
- let chunks = chunksOf n xs
- in valid chunks .&&.
- conjoin [valid c .&&. 1 <= length c && length c <= n | c <- toList chunks] .&&.
- fold chunks === xs
-
-adjustList :: (a -> a) -> Int -> [a] -> [a]
-adjustList f i xs =
- [if j == i then f x else x | (j, x) <- Prelude.zip [0..] xs]
-
--- ** Indexing with predicates
--- The elem* tests have poor coverage, but for find* we use predicates
--- of varying density.
-
-prop_elemIndexL :: A -> Seq A -> Bool
-prop_elemIndexL x xs =
- elemIndexL x xs == Data.List.elemIndex x (toList xs)
-
-prop_elemIndicesL :: A -> Seq A -> Bool
-prop_elemIndicesL x xs =
- elemIndicesL x xs == Data.List.elemIndices x (toList xs)
-
-prop_elemIndexR :: A -> Seq A -> Bool
-prop_elemIndexR x xs =
- elemIndexR x xs == listToMaybe (Prelude.reverse (Data.List.elemIndices x (toList xs)))
-
-prop_elemIndicesR :: A -> Seq A -> Bool
-prop_elemIndicesR x xs =
- elemIndicesR x xs == Prelude.reverse (Data.List.elemIndices x (toList xs))
-
-prop_findIndexL :: Positive Int -> Seq Int -> Bool
-prop_findIndexL (Positive n) xs =
- findIndexL p xs == Data.List.findIndex p (toList xs)
- where p x = x `mod` n == 0
-
-prop_findIndicesL :: Positive Int -> Seq Int -> Bool
-prop_findIndicesL (Positive n) xs =
- findIndicesL p xs == Data.List.findIndices p (toList xs)
- where p x = x `mod` n == 0
-
-prop_findIndexR :: Positive Int -> Seq Int -> Bool
-prop_findIndexR (Positive n) xs =
- findIndexR p xs == listToMaybe (Prelude.reverse (Data.List.findIndices p (toList xs)))
- where p x = x `mod` n == 0
-
-prop_findIndicesR :: Positive Int -> Seq Int -> Bool
-prop_findIndicesR (Positive n) xs =
- findIndicesR p xs == Prelude.reverse (Data.List.findIndices p (toList xs))
- where p x = x `mod` n == 0
-
--- * Folds
-
-prop_foldlWithIndex :: [(Int, A)] -> Seq A -> Bool
-prop_foldlWithIndex z xs =
- foldlWithIndex f z xs == Data.List.foldl (uncurry . f) z (Data.List.zip [0..] (toList xs))
- where f ys n y = (n,y):ys
-
-prop_foldrWithIndex :: [(Int, A)] -> Seq A -> Bool
-prop_foldrWithIndex z xs =
- foldrWithIndex f z xs == Data.List.foldr (uncurry f) z (Data.List.zip [0..] (toList xs))
- where f n y ys = (n,y):ys
-
-prop_foldMapWithIndexL :: (Fun (B, Int, A) B) -> B -> Seq A -> Bool
-prop_foldMapWithIndexL (Fun _ f) z t = foldlWithIndex f' z t ==
- appEndo (getDual (foldMapWithIndex (\i -> Dual . Endo . flip (flip f' i)) t)) z
- where f' b i a = f (b, i, a)
-
-prop_foldMapWithIndexR :: (Fun (Int, A, B) B) -> B -> Seq A -> Bool
-prop_foldMapWithIndexR (Fun _ f) z t = foldrWithIndex f' z t ==
- appEndo (foldMapWithIndex (\i -> Endo . f' i) t) z
- where f' i a b = f (i, a, b)
-
--- * Transformations
-
-prop_mapWithIndex :: Seq A -> Bool
-prop_mapWithIndex xs =
- toList' (mapWithIndex f xs) ~= map (uncurry f) (Data.List.zip [0..] (toList xs))
- where f = (,)
-
-prop_traverseWithIndex :: Seq Int -> Bool
-prop_traverseWithIndex xs =
- runState (traverseWithIndex (\i x -> modify ((i,x) :)) xs) [] ==
- runState (sequenceA . mapWithIndex (\i x -> modify ((i,x) :)) $ xs) []
-
-prop_reverse :: Seq A -> Bool
-prop_reverse xs =
- toList' (reverse xs) ~= Prelude.reverse (toList xs)
-
--- ** Zips
-
-prop_zip :: Seq A -> Seq B -> Bool
-prop_zip xs ys =
- toList' (zip xs ys) ~= Prelude.zip (toList xs) (toList ys)
-
-prop_zipWith :: Seq A -> Seq B -> Bool
-prop_zipWith xs ys =
- toList' (zipWith f xs ys) ~= Prelude.zipWith f (toList xs) (toList ys)
- where f = (,)
-
-prop_zip3 :: Seq A -> Seq B -> Seq C -> Bool
-prop_zip3 xs ys zs =
- toList' (zip3 xs ys zs) ~= Prelude.zip3 (toList xs) (toList ys) (toList zs)
-
-prop_zipWith3 :: Seq A -> Seq B -> Seq C -> Bool
-prop_zipWith3 xs ys zs =
- toList' (zipWith3 f xs ys zs) ~= Prelude.zipWith3 f (toList xs) (toList ys) (toList zs)
- where f = (,,)
-
-prop_zip4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool
-prop_zip4 xs ys zs ts =
- toList' (zip4 xs ys zs ts) ~= Data.List.zip4 (toList xs) (toList ys) (toList zs) (toList ts)
-
-prop_zipWith4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool
-prop_zipWith4 xs ys zs ts =
- toList' (zipWith4 f xs ys zs ts) ~= Data.List.zipWith4 f (toList xs) (toList ys) (toList zs) (toList ts)
- where f = (,,,)
-
--- This comes straight from the MonadZip documentation
-prop_mzipNaturality :: Fun A C -> Fun B D -> Seq A -> Seq B -> Property
-prop_mzipNaturality f g sa sb =
- fmap (apply f *** apply g) (mzip sa sb) ===
- mzip (apply f <$> sa) (apply g <$> sb)
-
--- This is a slight optimization of the MonadZip preservation
--- law that works because sequences don't have any decorations.
-prop_mzipPreservation :: Fun A B -> Seq A -> Property
-prop_mzipPreservation f sa =
- let sb = fmap (apply f) sa
- in munzip (mzip sa sb) === (sa, sb)
-
--- We want to ensure that
---
--- munzip xs = xs `seq` (fmap fst x, fmap snd x)
---
--- even in the presence of bottoms (alternatives are all balance-
--- fragile).
-prop_munzipLazy :: Seq (Integer, B) -> Bool
-prop_munzipLazy pairs = deepseq ((`seq` ()) <$> repaired) True
- where
- partialpairs = mapWithIndex (\i a -> update i err pairs) pairs
- firstPieces = fmap (fst . munzip) partialpairs
- repaired = mapWithIndex (\i s -> update i 10000 s) firstPieces
- err = error "munzip isn't lazy enough"
-
--- Applicative operations
-
-prop_ap :: Seq A -> Seq B -> Bool
-prop_ap xs ys =
- toList' ((,) <$> xs <*> ys) ~= ( (,) <$> toList xs <*> toList ys )
-
-prop_ap_NOINLINE :: Seq A -> Seq B -> Bool
-prop_ap_NOINLINE xs ys =
- toList' (((,) <$> xs) `apNOINLINE` ys) ~= ( (,) <$> toList xs <*> toList ys )
-
-{-# NOINLINE apNOINLINE #-}
-apNOINLINE :: Seq (a -> b) -> Seq a -> Seq b
-apNOINLINE fs xs = fs <*> xs
-
-prop_liftA2 :: Seq A -> Seq B -> Property
-prop_liftA2 xs ys = valid q .&&.
- toList q === liftA2 (,) (toList xs) (toList ys)
- where
- q = liftA2 (,) xs ys
-
-prop_then :: Seq A -> Seq B -> Bool
-prop_then xs ys =
- toList' (xs *> ys) ~= (toList xs *> toList ys)
-
-prop_intersperse :: A -> Seq A -> Bool
-prop_intersperse x xs =
- toList' (intersperse x xs) ~= Data.List.intersperse x (toList xs)
-
-prop_cycleTaking :: Int -> Seq A -> Property
-prop_cycleTaking n xs =
- (n <= 0 || not (null xs)) ==> toList' (cycleTaking n xs) ~= Data.List.take n (Data.List.cycle (toList xs))
-
-#if __GLASGOW_HASKELL__ >= 800
-prop_empty_pat :: Seq A -> Bool
-prop_empty_pat xs@Empty = null xs
-prop_empty_pat xs = not (null xs)
-
-prop_empty_con :: Bool
-prop_empty_con = null Empty
-
-prop_viewl_pat :: Seq A -> Property
-prop_viewl_pat xs@(y :<| ys)
- | z :< zs <- viewl xs = y === z .&&. ys === zs
- | otherwise = property failed
-prop_viewl_pat xs = property . liftBool $ null xs
-
-prop_viewl_con :: A -> Seq A -> Property
-prop_viewl_con x xs = x :<| xs === x <| xs
-
-prop_viewr_pat :: Seq A -> Property
-prop_viewr_pat xs@(ys :|> y)
- | zs :> z <- viewr xs = y === z .&&. ys === zs
- | otherwise = property failed
-prop_viewr_pat xs = property . liftBool $ null xs
-
-prop_viewr_con :: Seq A -> A -> Property
-prop_viewr_con xs x = xs :|> x === xs |> x
-#endif
-
--- Monad operations
-
-prop_bind :: Seq A -> Fun A (Seq B) -> Bool
-prop_bind xs (Fun _ f) =
- toList' (xs >>= f) ~= (toList xs >>= toList . f)
-
--- MonadFix operation
-
--- It's exceedingly difficult to construct a proper QuickCheck
--- property for mfix because the function passed to it must be
--- lazy. The following property is really just a unit test in
--- disguise, and not a terribly meaningful one.
-test_mfix :: Property
-test_mfix = toList resS === resL
- where
- facty :: (Int -> Int) -> Int -> Int
- facty _ 0 = 1; facty f n = n * f (n - 1)
-
- resS :: Seq Int
- resS = fmap ($ 12) $ mfix (\f -> fromList [facty f, facty (+1), facty (+2)])
-
- resL :: [Int]
- resL = fmap ($ 12) $ mfix (\f -> [facty f, facty (+1), facty (+2)])
-
--- Simple test monad
-
-data M a = Action Int a
- deriving (Eq, Show)
-
-instance Functor M where
- fmap f (Action n x) = Action n (f x)
-
-instance Applicative M where
- pure x = Action 0 x
- Action m f <*> Action n x = Action (m+n) (f x)
-
-instance Monad M where
- return x = Action 0 x
- Action m x >>= f = let Action n y = f x in Action (m+n) y
-
-instance Foldable M where
- foldMap f (Action _ x) = f x
-
-instance Traversable M where
- traverse f (Action n x) = Action n <$> f x
diff --git a/tests/set-properties.hs b/tests/set-properties.hs
deleted file mode 100644
index e235c0a..0000000
--- a/tests/set-properties.hs
+++ /dev/null
@@ -1,637 +0,0 @@
-{-# LANGUAGE CPP #-}
-import qualified Data.IntSet as IntSet
-import Data.List (nub,sort)
-import qualified Data.List as List
-import Data.Monoid (mempty)
-import Data.Maybe
-import Data.Set
-import Prelude hiding (lookup, null, map, filter, foldr, foldl, all, take, drop, splitAt)
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2
-import Test.HUnit hiding (Test, Testable)
-import Test.QuickCheck
-import Test.QuickCheck.Function
-import Test.QuickCheck.Poly
-import Control.Monad.Trans.State.Strict
-import Control.Monad.Trans.Class
-import Control.Monad (liftM, liftM3)
-import Data.Functor.Identity
-import Data.Foldable (all)
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative (Applicative (..), (<$>))
-#endif
-import Control.Applicative (liftA2)
-
-main :: IO ()
-main = defaultMain [ testCase "lookupLT" test_lookupLT
- , testCase "lookupGT" test_lookupGT
- , testCase "lookupLE" test_lookupLE
- , testCase "lookupGE" test_lookupGE
- , testCase "lookupIndex" test_lookupIndex
- , testCase "findIndex" test_findIndex
- , testCase "elemAt" test_elemAt
- , testCase "deleteAt" test_deleteAt
- , testProperty "prop_Valid" prop_Valid
- , testProperty "prop_Single" prop_Single
- , testProperty "prop_Member" prop_Member
- , testProperty "prop_NotMember" prop_NotMember
- , testProperty "prop_LookupLT" prop_LookupLT
- , testProperty "prop_LookupGT" prop_LookupGT
- , testProperty "prop_LookupLE" prop_LookupLE
- , testProperty "prop_LookupGE" prop_LookupGE
- , testProperty "prop_InsertValid" prop_InsertValid
- , testProperty "prop_InsertDelete" prop_InsertDelete
- , testProperty "prop_InsertBiased" prop_InsertBiased
- , testProperty "prop_DeleteValid" prop_DeleteValid
- , testProperty "prop_Link" prop_Link
- , testProperty "prop_Merge" prop_Merge
- , testProperty "prop_UnionValid" prop_UnionValid
- , testProperty "prop_UnionInsert" prop_UnionInsert
- , testProperty "prop_UnionAssoc" prop_UnionAssoc
- , testProperty "prop_UnionComm" prop_UnionComm
- , testProperty "prop_UnionBiased" prop_UnionBiased
- , testProperty "prop_DiffValid" prop_DiffValid
- , testProperty "prop_Diff" prop_Diff
- , testProperty "prop_IntValid" prop_IntValid
- , testProperty "prop_Int" prop_Int
- , testProperty "prop_IntBiased" prop_IntBiased
- , testProperty "prop_Ordered" prop_Ordered
- , testProperty "prop_DescendingOrdered" prop_DescendingOrdered
- , testProperty "prop_List" prop_List
- , testProperty "prop_DescList" prop_DescList
- , testProperty "prop_AscDescList" prop_AscDescList
- , testProperty "prop_fromList" prop_fromList
- , testProperty "prop_fromListDesc" prop_fromListDesc
- , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
- , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
- , testProperty "prop_isSubsetOf" prop_isSubsetOf
- , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
- , testProperty "prop_disjoint" prop_disjoint
- , testProperty "prop_size" prop_size
- , testProperty "prop_lookupMax" prop_lookupMax
- , testProperty "prop_lookupMin" prop_lookupMin
- , testProperty "prop_findMax" prop_findMax
- , testProperty "prop_findMin" prop_findMin
- , testProperty "prop_ord" prop_ord
- , testProperty "prop_readShow" prop_readShow
- , testProperty "prop_foldR" prop_foldR
- , testProperty "prop_foldR'" prop_foldR'
- , testProperty "prop_foldL" prop_foldL
- , testProperty "prop_foldL'" prop_foldL'
- , testProperty "prop_map" prop_map
- , testProperty "prop_map2" prop_map2
- , testProperty "prop_mapMonotonic" prop_mapMonotonic
- , testProperty "prop_maxView" prop_maxView
- , testProperty "prop_minView" prop_minView
- , testProperty "prop_split" prop_split
- , testProperty "prop_splitMember" prop_splitMember
- , testProperty "prop_splitRoot" prop_splitRoot
- , testProperty "prop_partition" prop_partition
- , testProperty "prop_filter" prop_filter
- , testProperty "takeWhileAntitone" prop_takeWhileAntitone
- , testProperty "dropWhileAntitone" prop_dropWhileAntitone
- , testProperty "spanAntitone" prop_spanAntitone
- , testProperty "take" prop_take
- , testProperty "drop" prop_drop
- , testProperty "splitAt" prop_splitAt
- , testProperty "powerSet" prop_powerSet
- , testProperty "cartesianProduct" prop_cartesianProduct
- , testProperty "disjointUnion" prop_disjointUnion
- ]
-
--- A type with a peculiar Eq instance designed to make sure keys
--- come from where they're supposed to.
-data OddEq a = OddEq a Bool deriving (Show)
-
-getOddEq :: OddEq a -> (a, Bool)
-getOddEq (OddEq b a) = (b, a)
-instance Arbitrary a => Arbitrary (OddEq a) where
- arbitrary = OddEq <$> arbitrary <*> arbitrary
-instance Eq a => Eq (OddEq a) where
- OddEq x _ == OddEq y _ = x == y
-instance Ord a => Ord (OddEq a) where
- OddEq x _ `compare` OddEq y _ = x `compare` y
-
-----------------------------------------------------------------
--- Unit tests
-----------------------------------------------------------------
-
-test_lookupLT :: Assertion
-test_lookupLT = do
- lookupLT 3 (fromList [3, 5]) @?= Nothing
- lookupLT 5 (fromList [3, 5]) @?= Just 3
-
-test_lookupGT :: Assertion
-test_lookupGT = do
- lookupGT 4 (fromList [3, 5]) @?= Just 5
- lookupGT 5 (fromList [3, 5]) @?= Nothing
-
-test_lookupLE :: Assertion
-test_lookupLE = do
- lookupLE 2 (fromList [3, 5]) @?= Nothing
- lookupLE 4 (fromList [3, 5]) @?= Just 3
- lookupLE 5 (fromList [3, 5]) @?= Just 5
-
-test_lookupGE :: Assertion
-test_lookupGE = do
- lookupGE 3 (fromList [3, 5]) @?= Just 3
- lookupGE 4 (fromList [3, 5]) @?= Just 5
- lookupGE 6 (fromList [3, 5]) @?= Nothing
-
-{--------------------------------------------------------------------
- Indexed
---------------------------------------------------------------------}
-
-test_lookupIndex :: Assertion
-test_lookupIndex = do
- isJust (lookupIndex 2 (fromList [5,3])) @?= False
- fromJust (lookupIndex 3 (fromList [5,3])) @?= 0
- fromJust (lookupIndex 5 (fromList [5,3])) @?= 1
- isJust (lookupIndex 6 (fromList [5,3])) @?= False
-
-test_findIndex :: Assertion
-test_findIndex = do
- findIndex 3 (fromList [5,3]) @?= 0
- findIndex 5 (fromList [5,3]) @?= 1
-
-test_elemAt :: Assertion
-test_elemAt = do
- elemAt 0 (fromList [5,3]) @?= 3
- elemAt 1 (fromList [5,3]) @?= 5
-
-test_deleteAt :: Assertion
-test_deleteAt = do
- deleteAt 0 (fromList [5,3]) @?= singleton 5
- deleteAt 1 (fromList [5,3]) @?= singleton 3
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-
--- | The IsInt class lets us constrain a type variable to be Int in an entirely
--- standard way. The constraint @ IsInt a @ is essentially equivalent to the
--- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention
--- to use. If ~ is ever standardized, we should certainly use it instead.
--- Earlier versions used an Enum constraint, but this is confusing because
--- not all Enum instances will work properly for the Arbitrary instance here.
-class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where
- fromIntF :: f Int -> f a
-
-instance IsInt Int where
- fromIntF = id
-
--- | Convert an Int to any instance of IsInt
-fromInt :: IsInt a => Int -> a
-fromInt = runIdentity . fromIntF . Identity
-
-{- We don't actually need this, but we can add it if we ever do
-toIntF :: IsInt a => g a -> g Int
-toIntF = unf . fromIntF . F $ id
-
-newtype F g a b = F {unf :: g b -> a}
-
-toInt :: IsInt a => a -> Int
-toInt = runIdentity . toIntF . Identity -}
-
-
--- How much the minimum value of an arbitrary set should vary
-positionFactor :: Int
-positionFactor = 1
-
--- How much the gap between consecutive elements in an arbitrary
--- set should vary
-gapRange :: Int
-gapRange = 5
-
-instance IsInt a => Arbitrary (Set a) where
- arbitrary = sized (\sz0 -> do
- sz <- choose (0, sz0)
- middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))
- let shift = (sz * (gapRange) + 1) `quot` 2
- start = middle - shift
- t <- evalStateT (mkArb step sz) start
- if valid t then pure t else error "Test generated invalid tree!")
- where
- step = do
- i <- get
- diff <- lift $ choose (1, gapRange)
- let i' = i + diff
- put i'
- pure (fromInt i')
-
-class Monad m => MonadGen m where
- liftGen :: Gen a -> m a
-instance MonadGen Gen where
- liftGen = id
-instance MonadGen m => MonadGen (StateT s m) where
- liftGen = lift . liftGen
-
--- | Given an action that produces successively larger elements and
--- a size, produce a set of arbitrary shape with exactly that size.
-mkArb :: MonadGen m => m a -> Int -> m (Set a)
-mkArb step n
- | n <= 0 = return Tip
- | n == 1 = singleton `liftM` step
- | n == 2 = do
- dir <- liftGen arbitrary
- p <- step
- q <- step
- if dir
- then return (Bin 2 q (singleton p) Tip)
- else return (Bin 2 p Tip (singleton q))
- | otherwise = do
- -- This assumes a balance factor of delta = 3
- let upper = (3*(n - 1)) `quot` 4
- let lower = (n + 2) `quot` 4
- ln <- liftGen $ choose (lower, upper)
- let rn = n - ln - 1
- liftM3 (\lt x rt -> Bin n x lt rt) (mkArb step ln) step (mkArb step rn)
-
--- | Given a strictly increasing list of elements, produce an arbitrarily
--- shaped set with exactly those elements.
-setFromList :: [a] -> Gen (Set a)
-setFromList xs = flip evalStateT xs $ mkArb step (length xs)
- where
- step = do
- x : xs <- get
- put xs
- pure x
-
-data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show)
-
-data TwoLists a = TwoLists [a] [a]
-
-data Options2 = One2 | Two2 | Both2 deriving (Bounded, Enum)
-instance Arbitrary Options2 where
- arbitrary = arbitraryBoundedEnum
-
--- We produce two lists from a simple "universe". This instance
--- is intended to give good results when the two lists are then
--- combined with each other; if other elements are used with them,
--- they may or may not behave particularly well.
-instance IsInt a => Arbitrary (TwoLists a) where
- arbitrary = sized $ \sz0 -> do
- sz <- choose (0, sz0)
- let universe = [0,3..3*(fromInt sz - 1)]
- divide2Gen universe
-
-instance Arbitrary TwoSets where
- arbitrary = do
- TwoLists l r <- arbitrary
- TwoSets <$> setFromList l <*> setFromList r
-
-divide2Gen :: [a] -> Gen (TwoLists a)
-divide2Gen [] = pure (TwoLists [] [])
-divide2Gen (x : xs) = do
- way <- arbitrary
- TwoLists ls rs <- divide2Gen xs
- case way of
- One2 -> pure (TwoLists (x : ls) rs)
- Two2 -> pure (TwoLists ls (x : rs))
- Both2 -> pure (TwoLists (x : ls) (x : rs))
-
-{--------------------------------------------------------------------
- Valid trees
---------------------------------------------------------------------}
-forValid :: (IsInt a,Testable b) => (Set a -> b) -> Property
-forValid f = forAll arbitrary $ \t ->
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $ f t
-
-forValidUnitTree :: Testable a => (Set Int -> a) -> Property
-forValidUnitTree f = forValid f
-
-prop_Valid :: Property
-prop_Valid = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Single, Member, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x = (insert x empty == singleton x)
-
-prop_Member :: [Int] -> Int -> Bool
-prop_Member xs n =
- let m = fromList xs
- in all (\k -> k `member` m == (k `elem` xs)) (n : xs)
-
-prop_NotMember :: [Int] -> Int -> Bool
-prop_NotMember xs n =
- let m = fromList xs
- in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)
-
-test_LookupSomething :: (Int -> Set Int -> Maybe Int) -> (Int -> Int -> Bool) -> [Int] -> Bool
-test_LookupSomething lookup' cmp xs =
- let odd_sorted_xs = filter_odd $ nub $ sort xs
- t = fromList odd_sorted_xs
- test x = case List.filter (`cmp` x) odd_sorted_xs of
- [] -> lookup' x t == Nothing
- cs | 0 `cmp` 1 -> lookup' x t == Just (last cs) -- we want largest such element
- | otherwise -> lookup' x t == Just (head cs) -- we want smallest such element
- in all test xs
-
- where filter_odd [] = []
- filter_odd [_] = []
- filter_odd (_ : o : xs) = o : filter_odd xs
-
-prop_LookupLT :: [Int] -> Bool
-prop_LookupLT = test_LookupSomething lookupLT (<)
-
-prop_LookupGT :: [Int] -> Bool
-prop_LookupGT = test_LookupSomething lookupGT (>)
-
-prop_LookupLE :: [Int] -> Bool
-prop_LookupLE = test_LookupSomething lookupLE (<=)
-
-prop_LookupGE :: [Int] -> Bool
-prop_LookupGE = test_LookupSomething lookupGE (>=)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k = forValidUnitTree $ \t -> valid (insert k t)
-
-prop_InsertDelete :: Int -> Set Int -> Property
-prop_InsertDelete k t = not (member k t) ==> delete k (insert k t) == t
-
-prop_InsertBiased :: Int -> Set Int -> Bool
-prop_InsertBiased k t = (k, True) `member` kt
- where
- t' = mapMonotonic (`OddEq` False) t
- kt' = insert (OddEq k True) t'
- kt = mapMonotonic getOddEq kt'
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k = forValidUnitTree $ \t -> valid (delete k (insert k t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Link :: Int -> Property
-prop_Link x = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (link x l r)
-
-prop_Merge :: Int -> Property
-prop_Merge x = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (merge l r)
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Set Int -> Bool
-prop_UnionInsert x t = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
-prop_UnionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: TwoSets -> Bool
-prop_UnionComm (TwoSets t1 t2) = (union t1 t2 == union t2 t1)
-
-prop_UnionBiased :: TwoSets -> Property
-prop_UnionBiased (TwoSets l r) = union l' r' === union l' (difference r' l')
- where
- l' = mapMonotonic (`OddEq` False) l
- r' = mapMonotonic (`OddEq` True) r
-
-prop_IntBiased :: TwoSets -> Bool
-prop_IntBiased (TwoSets l r) = all (\(OddEq _ b) -> not b) l'r'
- where
- l' = mapMonotonic (`OddEq` False) l
- r' = mapMonotonic (`OddEq` True) r
- l'r' = intersection l' r'
-
-prop_DiffValid :: Property
-prop_DiffValid = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_IntValid :: Property
-prop_IntValid = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-prop_disjoint :: Set Int -> Set Int -> Bool
-prop_disjoint a b = a `disjoint` b == null (a `intersection` b)
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered :: Property
-prop_Ordered = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs === fromList xs
-
-prop_DescendingOrdered :: Property
-prop_DescendingOrdered = forAll (choose (5,100)) $ \n ->
- let xs = [n,n-1..0::Int]
- in fromDescList xs === fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs = (sort (nub xs) == toList (fromList xs))
-
-prop_DescList :: [Int] -> Bool
-prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs))
-
-prop_AscDescList :: [Int] -> Bool
-prop_AscDescList xs = toAscList s == reverse (toDescList s)
- where s = fromList xs
-
-prop_fromList :: [Int] -> Property
-prop_fromList xs =
- t === fromAscList sort_xs .&&.
- t === fromDistinctAscList nub_sort_xs .&&.
- t === List.foldr insert empty xs
- where t = fromList xs
- sort_xs = sort xs
- nub_sort_xs = List.map List.head $ List.group sort_xs
-
-prop_fromListDesc :: [Int] -> Property
-prop_fromListDesc xs =
- t === fromDescList sort_xs .&&.
- t === fromDistinctDescList nub_sort_xs .&&.
- t === List.foldr insert empty xs
- where t = fromList xs
- sort_xs = reverse (sort xs)
- nub_sort_xs = List.map List.head $ List.group sort_xs
-
-{--------------------------------------------------------------------
- Set operations are like IntSet operations
---------------------------------------------------------------------}
-toIntSet :: Set Int -> IntSet.IntSet
-toIntSet = IntSet.fromList . toList
-
--- Check that Set Int.isProperSubsetOf is the same as Set.isProperSubsetOf.
-prop_isProperSubsetOf :: TwoSets -> Bool
-prop_isProperSubsetOf (TwoSets a b) = isProperSubsetOf a b == IntSet.isProperSubsetOf (toIntSet a) (toIntSet b)
-
--- In the above test, isProperSubsetOf almost always returns False (since a
--- random set is almost never a subset of another random set). So this second
--- test checks the True case.
-prop_isProperSubsetOf2 :: TwoSets -> Bool
-prop_isProperSubsetOf2 (TwoSets a b) = isProperSubsetOf a c == (a /= c) where
- c = union a b
-
-prop_isSubsetOf :: TwoSets -> Bool
-prop_isSubsetOf (TwoSets a b) = isSubsetOf a b == IntSet.isSubsetOf (toIntSet a) (toIntSet b)
-
-prop_isSubsetOf2 :: TwoSets -> Bool
-prop_isSubsetOf2 (TwoSets a b) = isSubsetOf a (union a b)
-
-prop_size :: Set Int -> Bool
-prop_size s = size s == List.length (toList s)
-
-prop_findMax :: Set Int -> Property
-prop_findMax s = not (null s) ==> findMax s == maximum (toList s)
-
-prop_findMin :: Set Int -> Property
-prop_findMin s = not (null s) ==> findMin s == minimum (toList s)
-
-prop_lookupMin :: Set Int -> Property
-prop_lookupMin m = lookupMin m === (fst <$> minView m)
-
-prop_lookupMax :: Set Int -> Property
-prop_lookupMax m = lookupMax m === (fst <$> maxView m)
-
-prop_ord :: TwoSets -> Bool
-prop_ord (TwoSets s1 s2) = s1 `compare` s2 == toList s1 `compare` toList s2
-
-prop_readShow :: Set Int -> Bool
-prop_readShow s = s == read (show s)
-
-prop_foldR :: Set Int -> Bool
-prop_foldR s = foldr (:) [] s == toList s
-
-prop_foldR' :: Set Int -> Bool
-prop_foldR' s = foldr' (:) [] s == toList s
-
-prop_foldL :: Set Int -> Bool
-prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s)
-
-prop_foldL' :: Set Int -> Bool
-prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s)
-
-prop_map :: Set Int -> Bool
-prop_map s = map id s == s
-
-prop_map2 :: Fun Int Int -> Fun Int Int -> Set Int -> Property
-prop_map2 f g s = map (apply f) (map (apply g) s) === map (apply f . apply g) s
-
-prop_mapMonotonic :: Set Int -> Property
-prop_mapMonotonic s = mapMonotonic id s === s
-
-prop_maxView :: Set Int -> Bool
-prop_maxView s = case maxView s of
- Nothing -> null s
- Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s'
-
-prop_minView :: Set Int -> Bool
-prop_minView s = case minView s of
- Nothing -> null s
- Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s'
-
-prop_split :: Set Int -> Int -> Bool
-prop_split s i = case split i s of
- (s1,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && i `delete` s == union s1 s2
-
-prop_splitMember :: Set Int -> Int -> Bool
-prop_splitMember s i = case splitMember i s of
- (s1,t,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2
-
-prop_splitRoot :: Set Int -> Bool
-prop_splitRoot s = loop ls && (s == unions ls)
- where
- ls = splitRoot s
- loop [] = True
- loop (s1:rst) = List.null
- [ (x,y) | x <- toList s1
- , y <- toList (unions rst)
- , x > y ]
-
-prop_partition :: Set Int -> Int -> Bool
-prop_partition s i = case partition odd s of
- (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2
-
-prop_filter :: Set Int -> Int -> Bool
-prop_filter s i = partition odd s == (filter odd s, filter even s)
-
-prop_take :: Int -> Set Int -> Property
-prop_take n xs = valid taken .&&.
- taken === fromDistinctAscList (List.take n (toList xs))
- where
- taken = take n xs
-
-prop_drop :: Int -> Set Int -> Property
-prop_drop n xs = valid dropped .&&.
- dropped === fromDistinctAscList (List.drop n (toList xs))
- where
- dropped = drop n xs
-
-prop_splitAt :: Int -> Set Int -> Property
-prop_splitAt n xs = valid taken .&&.
- valid dropped .&&.
- taken === take n xs .&&.
- dropped === drop n xs
- where
- (taken, dropped) = splitAt n xs
-
-prop_takeWhileAntitone :: [Either Int Int] -> Property
-prop_takeWhileAntitone xs' = valid tw .&&. tw === filter isLeft xs
- where
- xs = fromList xs'
- tw = takeWhileAntitone isLeft xs
-
-prop_dropWhileAntitone :: [Either Int Int] -> Property
-prop_dropWhileAntitone xs' = valid tw .&&. tw === filter (not . isLeft) xs
- where
- xs = fromList xs'
- tw = dropWhileAntitone isLeft xs
-
-prop_spanAntitone :: [Either Int Int] -> Property
-prop_spanAntitone xs' = valid tw .&&. valid dw
- .&&. tw === takeWhileAntitone isLeft xs
- .&&. dw === dropWhileAntitone isLeft xs
- where
- xs = fromList xs'
- (tw, dw) = spanAntitone isLeft xs
-
-prop_powerSet :: Set Int -> Property
-prop_powerSet xs = valid ps .&&. ps === ps'
- where
- xs' = take 10 xs
-
- ps = powerSet xs'
- ps' = fromList . fmap fromList $ lps (toList xs')
-
- lps [] = [[]]
- lps (y : ys) = fmap (y:) (lps ys) ++ lps ys
-
-prop_cartesianProduct :: Set Int -> Set Int -> Property
-prop_cartesianProduct xs ys =
- valid cp .&&. toList cp === liftA2 (,) (toList xs) (toList ys)
- where cp = cartesianProduct xs ys
-
-prop_disjointUnion :: Set Int -> Set Int -> Property
-prop_disjointUnion xs ys =
- valid du .&&. du === union (mapMonotonic Left xs) (mapMonotonic Right ys)
- where du = disjointUnion xs ys
-
-isLeft :: Either a b -> Bool
-isLeft (Left _) = True
-isLeft _ = False
diff --git a/tests/tree-properties.hs b/tests/tree-properties.hs
deleted file mode 100644
index 0ba42d9..0000000
--- a/tests/tree-properties.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-import Data.Tree as T
-
-import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), liftA2)
-
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Test.QuickCheck
-import Test.QuickCheck.Function (Fun (..), apply)
-import Test.QuickCheck.Poly (A, B, C)
-import Control.Monad.Fix (MonadFix (..))
-import Control.Monad (ap)
-
-default (Int)
-
-main :: IO ()
-main = defaultMain
- [
- testProperty "monad_id1" prop_monad_id1
- , testProperty "monad_id2" prop_monad_id2
- , testProperty "monad_assoc" prop_monad_assoc
- , testProperty "ap_ap" prop_ap_ap
- , testProperty "ap_liftA2" prop_ap_liftA2
- , testProperty "monadFix_ls" prop_monadFix_ls
- ]
-
-{--------------------------------------------------------------------
- Arbitrary trees
---------------------------------------------------------------------}
-
-
--- This instance isn't balanced very well; the trees will probably tend
--- to lean left. But it's better than nothing and we can fix it later.
-instance Arbitrary a => Arbitrary (Tree a) where
- arbitrary = sized (fmap snd . arbtree)
- where
- arbtree :: Arbitrary a => Int -> Gen (Int, Tree a)
- arbtree 0 = fmap ((,) 1) $ Node <$> arbitrary <*> pure []
- arbtree n = do
- root <- arbitrary
- num_children <- choose (0, n - 1)
- (st, tl) <- go num_children
- return (1+st, Node root tl)
-
- go 0 = pure (0, [])
- go n = do
- (sh, hd) <- arbtree n
- (st, tl) <- go (n - sh)
- pure (sh + st, hd : tl)
-
-#if defined(__GLASGOW_HASKELL__)
- shrink = genericShrink
-#endif
-
-----------------------------------------------------------------
--- Unit tests
-----------------------------------------------------------------
-
-----------------------------------------------------------------
--- QuickCheck
-----------------------------------------------------------------
-
-apply2 :: Fun (a, b) c -> a -> b -> c
-apply2 f a b = apply f (a, b)
-
-prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property
-prop_ap_ap fs xs = (apply <$> fs <*> xs) === ((apply <$> fs) `ap` xs)
-
-prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property
-prop_ap_liftA2 f as bs = (apply2 f <$> as <*> bs) === liftA2 (apply2 f) as bs
-
-prop_monad_id1 :: Tree A -> Property
-prop_monad_id1 t = (t >>= pure) === t
-
-prop_monad_id2 :: A -> Fun A (Tree B) -> Property
-prop_monad_id2 a f = (pure a >>= apply f) === apply f a
-
-prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property
-prop_monad_assoc ta atb btc =
- ((ta >>= apply atb) >>= apply btc)
- ===
- (ta >>= \a -> apply atb a >>= apply btc)
-
--- The left shrinking law
---
--- This test is kind of wonky and unprincipled, because it's
--- rather tricky to construct test cases!
--- This is the most important MonadFix law to test because it's the
--- least intuitive by far, and because it's the only one that's
--- sensitive to the Monad instance.
-prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property
-prop_monadFix_ls val ta ti =
- fmap ($val) (mfix (\x -> ta >>= \y -> f x y))
- ===
- fmap ($val) (ta >>= \y -> mfix (\x -> f x y))
- where
- fact :: Int -> (Int -> Int) -> Int -> Int
- fact x _ 0 = x + 1
- fact x f n = x + n * f ((n - 1) `mod` 23)
-
- f :: (Int -> Int) -> Int -> Tree (Int -> Int)
- f q y = let t = apply ti y
- in fmap (\w -> fact w q) t