Add `alterF` for Data.Map
authorDavid Feuer <David.Feuer@gmail.com>
Mon, 2 May 2016 18:29:36 +0000 (14:29 -0400)
committerDavid Feuer <David.Feuer@gmail.com>
Wed, 18 May 2016 22:48:56 +0000 (18:48 -0400)
Use a bit queue to implement `alterF` for `Data.Map`. This is fairly
competitive with the simple implementation in `Control.Lens.At`
even with `Int` keys. For keys that are more expensive to compare,
it should be substantially better. In case of extremely large maps
that would overflow the bit queue, this falls back to a slower,
Yoneda-based, implementation. This code is disabled when the word
size is at least 61, as maps with nearly a quadrillion entries seem
somewhat unlikely.

Add rules to specialize to `Const` and `Identity` functors.

Add QuickCheck properties to supplement the unit tests, including
ones that should trigger the rewrite rules and ones that should not.

Remove some more pre-7.0 junk.

12 files changed:
.gitignore
Data/Map/Base.hs
Data/Map/Lazy.hs
Data/Map/Strict.hs
Data/Sequence.hs
Data/Utils/BitQueue.hs [new file with mode: 0644]
Data/Utils/BitUtil.hs
benchmarks/Map.hs
changelog.md
containers.cabal
tests/bitqueue-properties.hs [new file with mode: 0644]
tests/map-properties.hs

index fb03447..48d720b 100644 (file)
@@ -9,3 +9,8 @@ GNUmakefile
 dist-install
 ghc.mk
 .stack-work
+/benchmarks/bench-Map
+/benchmarks/bench-Set
+/benchmarks/bench-IntSet
+/benchmarks/bench-IntMap
+/benchmarks/bench-Sequence
index bd8140d..fb4b08d 100644 (file)
@@ -9,10 +9,20 @@
 #if __GLASGOW_HASKELL__ >= 708
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE TypeFamilies #-}
+#define USE_MAGIC_PROXY 1
+#endif
+
+#if USE_MAGIC_PROXY
+{-# LANGUAGE MagicHash #-}
 #endif
 
 #include "containers.h"
 
+#if !(WORD_SIZE_IN_BITS >= 61)
+#define DEFINE_ALTERF_FALLBACK 1
+#endif
+
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Map.Base
@@ -137,7 +147,7 @@ module Data.Map.Base (
     , updateWithKey
     , updateLookupWithKey
     , alter
-    , at
+    , alterF
 
     -- * Combine
 
@@ -255,14 +265,19 @@ module Data.Map.Base (
     , valid
 
     -- Used by the strict version
+    , AreWeStrict (..)
+    , atKeyImpl
+#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)
+    , atKeyPlain
+#endif
     , bin
     , balance
     , balanced
     , balanceL
     , balanceR
     , delta
-    , link
     , insertMax
+    , link
     , merge
     , glue
     , trim
@@ -272,7 +287,9 @@ module Data.Map.Base (
     , filterLt
     ) where
 
-#if !(MIN_VERSION_base(4,8,0))
+#if MIN_VERSION_base(4,8,0)
+import Data.Functor.Identity (Identity (..))
+#else
 import Control.Applicative (Applicative(..), (<$>))
 import Data.Monoid (Monoid(..))
 import Data.Traversable (Traversable(traverse))
@@ -280,7 +297,7 @@ import Data.Traversable (Traversable(traverse))
 #if MIN_VERSION_base(4,9,0)
 import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
 #endif
-
+import Control.Applicative (Const (..))
 import Control.DeepSeq (NFData(rnf))
 import Data.Bits (shiftL, shiftR)
 import qualified Data.Foldable as Foldable
@@ -290,9 +307,16 @@ import Prelude hiding (lookup, map, filter, foldr, foldl, null)
 import qualified Data.Set.Base as Set
 import Data.Utils.StrictFold
 import Data.Utils.StrictPair
+import Data.Utils.BitQueue
+#if DEFINE_ALTERF_FALLBACK
+import Data.Utils.BitUtil (wordSize)
+#endif
 
 #if __GLASGOW_HASKELL__
-import GHC.Exts ( build )
+import GHC.Exts (build)
+#if USE_MAGIC_PROXY
+import GHC.Exts (Proxy#, proxy# )
+#endif
 #if __GLASGOW_HASKELL__ >= 708
 import qualified GHC.Exts as GHCExts
 #endif
@@ -933,25 +957,267 @@ alter = go
 {-# INLINE alter #-}
 #endif
 
-at :: (Functor f, Ord k) =>
-      k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)
-at = go
+-- Used to choose the appropriate alterF implementation.
+data AreWeStrict = Strict | Lazy
+
+-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at
+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,
+-- or update a value in a 'Map'.  In short : @'lookup' k <$> 'alterF' f k m = f
+-- ('lookup' k m)@.
+--
+-- Example:
+-- @
+-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
+-- interactiveAlter k m = alterF f k m where
+--   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 ++
+--          ". Would you like to change or delete it?"
+--      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. When used with trivial
+-- functors like 'Identity' and 'Const', it is often slightly slower than
+-- more specialized combinators like 'lookup' and 'insert'. However, when
+-- the functor is non-trivial and key comparison is not particularly cheap,
+-- it is the fastest way.
+--
+-- Note on rewrite rules:
+--
+-- This module includes GHC rewrite rules to optimize 'alterF' for
+-- the 'Const' and 'Identity' functors. In general, these rules
+-- improve performance. The sole exception is that when using
+-- 'Identity', deleting a key that is already absent takes longer
+-- than it would without the rules. If you expect this to occur
+-- 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'.
+--
+-- @since 0.5.8
+alterF :: (Functor f, Ord k)
+       => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
+alterF f k m = atKeyImpl Lazy k f m
+
+#ifndef __GLASGOW_HASKELL__
+{-# INLINE alterF #-}
+#else
+{-# INLINABLE [2] alterF #-}
+
+-- We can save a little time by recognizing the special case of
+-- `Control.Applicative.Const` and just doing a lookup.
+{-# RULES
+"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m
+ #-}
+#if MIN_VERSION_base(4,8,0)
+-- base 4.8 and above include Data.Functor.Identity, so we can
+-- save a pretty decent amount of time by handling it specially.
+{-# RULES
+"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f
+ #-}
+#endif
+#endif
+
+atKeyImpl :: (Functor f, Ord k) =>
+      AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)
+#if DEFINE_ALTERF_FALLBACK
+atKeyImpl strict !k f m
+-- It doesn't seem sensible to worry about overflowing the queue
+-- if the word size is 61 or more. If I calculate it correctly,
+-- that would take a map with nearly a quadrillion entries.
+  | wordSize < 61 && size m >= alterFCutoff = alterFFallback strict k f m
+#endif
+atKeyImpl strict !k f m = case lookupTrace k m of
+  TraceResult mv q -> (<$> f mv) $ \ fres ->
+    case fres of
+      Nothing -> case mv of
+                   Nothing -> m
+                   Just old -> deleteAlong old q m
+      Just new -> case strict of
+         Strict -> new `seq` case mv of
+                      Nothing -> insertAlong q k new m
+                      Just _ -> replaceAlong q new m
+         Lazy -> case mv of
+                      Nothing -> insertAlong q k new m
+                      Just _ -> replaceAlong q new m
+
+{-# INLINE atKeyImpl #-}
+
+#if DEFINE_ALTERF_FALLBACK
+alterFCutoff :: Int
+#if WORD_SIZE_IN_BITS == 32
+alterFCutoff = 55744454
+#else
+alterFCutoff = case wordSize of
+      30 -> 17637893
+      31 -> 31356255
+      32 -> 55744454
+      x -> (4^(x*2-2)) `quot` (3^(x*2-2))  -- Unlikely
+#endif
+#endif
+
+data TraceResult a = TraceResult (Maybe a) {-# UNPACK #-} !BitQueue
+
+-- Look up a key and return a result indicating whether it was found
+-- and what path was taken.
+lookupTrace :: Ord k => k -> Map k a -> TraceResult a
+lookupTrace = go emptyQB
   where
-    STRICT_1_OF_3(go)
-    go k f Tip = (`fmap` f Nothing) $ \ mx -> case mx of
-               Nothing -> Tip
-               Just x  -> singleton k x
+    go :: Ord k => BitQueueB -> k -> Map k a -> TraceResult a
+    go !q !_ Tip = TraceResult Nothing (buildQ q)
+    go q k (Bin _ kx x l r) = case compare k kx of
+      LT -> (go $! q `snocQB` False) k l
+      GT -> (go $! q `snocQB` True) k r
+      EQ -> TraceResult (Just x) (buildQ q)
+
+-- GHC 7.8 doesn't manage to unbox the queue properly
+-- unless we explicitly inline this function. This stuff
+-- is a bit touchy, unfortunately.
+#if __GLASGOW_HASKELL__ >= 710
+{-# INLINABLE lookupTrace #-}
+#else
+{-# INLINE lookupTrace #-}
+#endif
+
+-- Insert at a location (which will always be a leaf)
+-- described by the path passed in.
+insertAlong :: BitQueue -> k -> a -> Map k a -> Map k a
+insertAlong !_ kx x Tip = singleton kx x
+insertAlong q kx x (Bin sz ky y l r) =
+  case unconsQ q of
+        Just (False, tl) -> balanceL ky y (insertAlong tl kx x l) r
+        Just (True,tl) -> balanceR ky y l (insertAlong tl kx x r)
+        Nothing -> Bin sz kx x l r  -- Shouldn't happen
+
+-- Delete from a location (which will always be a node)
+-- described by the path passed in.
+--
+-- This is fairly horrifying! We don't actually have any
+-- use for the old value we're deleting. But if GHC sees
+-- that, then it will allocate a thunk representing the
+-- Map with the key deleted before we have any reason to
+-- believe we'll actually want that. This transformation
+-- enhances sharing, but we don't care enough about that.
+-- So deleteAlong needs to take the old value, and we need
+-- to convince GHC somehow that it actually uses it. We
+-- can't NOINLINE deleteAlong, because that would prevent
+-- the BitQueue from being unboxed. So instead we pass the
+-- old value to a NOINLINE constant function and then
+-- convince GHC that we use the result throughout the
+-- computation. Doing the obvious thing and just passing
+-- the value itself through the recursion costs 3-4% time,
+-- so instead we convert the value to a magical zero-width
+-- proxy that's ultimately erased.
+deleteAlong :: any -> BitQueue -> Map k a -> Map k a
+deleteAlong old !q0 !m = go (bogus old) q0 m where
+#if USE_MAGIC_PROXY
+  go :: Proxy# () -> BitQueue -> Map k a -> Map k a
+#else
+  go :: any -> BitQueue -> Map k a -> Map k a
+#endif
+  go !_ !_ Tip = Tip
+  go foom q (Bin _ ky y l r) =
+      case unconsQ q of
+        Just (False, tl) -> balanceR ky y (go foom tl l) r
+        Just (True, tl) -> balanceL ky y l (go foom tl r)
+        Nothing -> glue l r
+
+#if USE_MAGIC_PROXY
+{-# NOINLINE bogus #-}
+bogus :: a -> Proxy# ()
+bogus _ = proxy#
+#else
+-- No point hiding in this case.
+{-# INLINE bogus #-}
+bogus :: a -> a
+bogus a = a
+#endif
+
+-- Replace the value found in the node described
+-- by the given path with a new one.
+replaceAlong :: BitQueue -> a -> Map k a -> Map k a
+replaceAlong !_ _ Tip = Tip -- Should not happen
+replaceAlong q  x (Bin sz ky y l r) =
+      case unconsQ q of
+        Just (False, tl) -> Bin sz ky y (replaceAlong tl x l) r
+        Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r)
+        Nothing -> Bin sz ky x l r
+
+#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)
+atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)
+atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t
+{-# INLINABLE atKeyIdentity #-}
+
+atKeyPlain :: Ord k => AreWeStrict -> k -> (Maybe a -> Maybe a) -> Map k a -> Map k a
+atKeyPlain strict k0 f0 t = case go k0 f0 t of
+    AltSmaller t' -> t'
+    AltBigger t' -> t'
+    AltAdj t' -> t'
+    AltSame -> t
+  where
+    go :: Ord k => k -> (Maybe a -> Maybe a) -> Map k a -> Altered k a
+    go !k f Tip = case f Nothing of
+                   Nothing -> AltSame
+                   Just x  -> case strict of
+                     Lazy -> AltBigger $ singleton k x
+                     Strict -> x `seq` (AltBigger $ singleton k x)
 
     go k f (Bin sx kx x l r) = case compare k kx of
-               LT -> (\ m -> balance kx x m r) `fmap` go k f l
-               GT -> (\ m -> balance kx x l m) `fmap` go k f r
-               EQ -> (`fmap` f (Just x)) $ \ mx' -> case mx' of
-                       Just x' -> Bin sx kx x' l r
-                       Nothing -> glue l r
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE at #-}
-#else
-{-# INLINE at #-}
+                   LT -> case go k f l of
+                           AltSmaller l' -> AltSmaller $ balanceR kx x l' r
+                           AltBigger l' -> AltBigger $ balanceL kx x l' r
+                           AltAdj l' -> AltAdj $ Bin sx kx x l' r
+                           AltSame -> AltSame
+                   GT -> case go k f r of
+                           AltSmaller r' -> AltSmaller $ balanceL kx x l r'
+                           AltBigger r' -> AltBigger $ balanceR kx x l r'
+                           AltAdj r' -> AltAdj $ Bin sx kx x l r'
+                           AltSame -> AltSame
+                   EQ -> case f (Just x) of
+                           Just x' -> case strict of
+                             Lazy -> AltAdj $ Bin sx kx x' l r
+                             Strict -> x' `seq` (AltAdj $ Bin sx kx x' l r)
+                           Nothing -> AltSmaller $ glue l r
+{-# INLINE atKeyPlain #-}
+
+data Altered k a = AltSmaller !(Map k a) | AltBigger !(Map k a) | AltAdj !(Map k a) | AltSame
+#endif
+
+#if DEFINE_ALTERF_FALLBACK
+-- When the map is too large to use a bit queue, we fall back to
+-- this much slower version which uses a more "natural" implementation
+-- improved with Yoneda to avoid repeated fmaps. This works okayish for
+-- some operations, but it's pretty lousy for lookups.
+alterFFallback :: (Functor f, Ord k)
+   => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)
+alterFFallback Lazy k f t = alterFYoneda k (\m q -> q <$> f m) t id
+alterFFallback Strict k f t = alterFYoneda k (\m q -> q . forceMaybe <$> f m) t id
+  where
+    forceMaybe Nothing = Nothing
+    forceMaybe may@(Just !_) = may
+{-# NOINLINE alterFFallback #-}
+
+alterFYoneda :: Ord k =>
+      k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b
+alterFYoneda = go
+  where
+    go :: Ord k =>
+      k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b
+    go !k f Tip g = f Nothing $ \ mx -> case mx of
+      Nothing -> g Tip
+      Just x -> g (singleton k x)
+    go k f (Bin sx kx x l r) g = case compare k kx of
+               LT -> go k f l (\m -> g (balance kx x m r))
+               GT -> go k f r (\m -> g (balance kx x l m))
+               EQ -> f (Just x) $ \ mx' -> case mx' of
+                       Just x' -> g (Bin sx kx x' l r)
+                       Nothing -> g (glue l r)
+{-# INLINE alterFYoneda #-}
 #endif
 
 {--------------------------------------------------------------------
index 7399501..09e4f39 100644 (file)
@@ -96,7 +96,7 @@ module Data.Map.Lazy (
     , updateWithKey
     , updateLookupWithKey
     , alter
-    , at
+    , alterF
 
     -- * Combine
 
index 84d513d..39775f7 100644 (file)
@@ -104,7 +104,7 @@ module Data.Map.Strict
     , updateWithKey
     , updateLookupWithKey
     , alter
-    , at
+    , alterF
 
     -- * Combine
 
@@ -245,6 +245,7 @@ import Data.Map.Base hiding
     , updateWithKey
     , updateLookupWithKey
     , alter
+    , alterF
     , unionWith
     , unionWithKey
     , unionsWith
@@ -277,6 +278,7 @@ import Data.Map.Base hiding
     , updateMinWithKey
     , updateMaxWithKey
     )
+import Control.Applicative (Const (..))
 import qualified Data.Set.Base as Set
 import Data.Utils.StrictFold
 import Data.Utils.StrictPair
@@ -286,6 +288,10 @@ import Data.Bits (shiftL, shiftR)
 import Data.Coerce
 #endif
 
+#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)
+import Data.Functor.Identity (Identity (..))
+#endif
+
 
 -- $strictness
 --
@@ -614,6 +620,70 @@ alter = go
 {-# INLINE alter #-}
 #endif
 
+-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof.
+-- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'.
+-- In short : @'lookup' k <$> 'alterF' f k m = f ('lookup' k m)@.
+--
+-- Example:
+-- @
+-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
+-- interactiveAlter k m = alterF f k m where
+--   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 ++
+--          ". Would you like to change or delete it?"
+--      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. When used with trivial
+-- functors like 'Identity' and 'Const', it is often slightly slower than
+-- more specialized combinators like 'lookup' and 'insert'. However, when
+-- the functor is non-trivial and key comparison is not particularly cheap,
+-- it is the fastest way.
+--
+-- Note on rewrite rules:
+--
+-- This module includes GHC rewrite rules to optimize 'alterF' for
+-- the 'Const' and 'Identity' functors. In general, these rules
+-- improve performance. The sole exception is that when using
+-- 'Identity', deleting a key that is already absent takes longer
+-- than it would without the rules. If you expect this to occur
+-- 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'.
+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
+
+#ifndef __GLASGOW_HASKELL__
+{-# INLINE alterF #-}
+#else
+{-# INLINABLE [2] alterF #-}
+
+-- We can save a little time by recognizing the special case of
+-- `Control.Applicative.Const` and just doing a lookup.
+{-# RULES
+"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m
+ #-}
+#if MIN_VERSION_base(4,8,0)
+-- base 4.8 and above include Data.Functor.Identity, so we can
+-- save a pretty decent amount of time by handling it specially.
+{-# RULES
+"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f
+ #-}
+
+atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)
+atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t
+{-# INLINABLE atKeyIdentity #-}
+#endif
+#endif
+
 {--------------------------------------------------------------------
   Indexing
 --------------------------------------------------------------------}
index 388bc46..0569acd 100644 (file)
@@ -574,6 +574,8 @@ thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two1
 -- > intersperse a (singleton x) = singleton x
 -- > intersperse a (fromList [x,y]) = fromList [x,a,y]
 -- > intersperse a (fromList [x,y,z]) = fromList [x,a,y,a,z]
+--
+-- @since 0.5.8
 intersperse :: a -> Seq a -> Seq a
 intersperse y xs = drop 1 $ xs <**> (const y <| singleton id)
 
@@ -1752,7 +1754,9 @@ mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)
 #endif
 
 -- | 'traverseWithIndex' is a version of 'traverse' that also offers
---   access to the index of each element.
+-- access to the index of each element.
+--
+-- @since 0.5.8
 traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
 traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) -> Elem <$> f' s a) 0 xs'
  where
diff --git a/Data/Utils/BitQueue.hs b/Data/Utils/BitQueue.hs
new file mode 100644 (file)
index 0000000..150ef4b
--- /dev/null
@@ -0,0 +1,130 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Utils.BitQueue
+-- Copyright   :  (c) David Feuer 2016
+-- License     :  BSD-style
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- An extremely light-weight, fast, and limited representation of a string of
+-- up to (2*WORDSIZE - 2) bits. In fact, there are two representations,
+-- misleadingly named bit queue builder and bit queue. The builder supports
+-- only `emptyQB`, creating an empty builder, and `snocQB`, enqueueing a bit.
+-- The bit queue builder is then turned into a bit queue using `buildQ`, after
+-- which bits can be removed one by one using `unconsQ`. If the size limit is
+-- exceeded, further operations will silently produce nonsense.
+-----------------------------------------------------------------------------
+
+module Data.Utils.BitQueue
+    ( BitQueue
+    , BitQueueB
+    , emptyQB
+    , snocQB
+    , buildQ
+    , unconsQ
+    , toListQ
+    ) where
+
+import Data.Word (Word)
+import Data.Utils.BitUtil (shiftLL, shiftRL, wordSize)
+import Data.Bits ((.|.), (.&.), testBit)
+#if MIN_VERSION_base(4,8,0)
+import Data.Bits (countTrailingZeros)
+#elif MIN_VERSION_base(4,5,0)
+import Data.Bits (popCount)
+#endif
+
+#if !MIN_VERSION_base(4,5,0)
+-- We could almost certainly improve this fall-back (copied straight from the
+-- default definition in Data.Bits), but it hardly seems worth the trouble
+-- to speed things up on GHC 7.4 and below.
+countTrailingZeros :: Word -> Int
+countTrailingZeros x = go 0
+      where
+        go i | i >= wordSize      = i
+             | testBit x i = i
+             | otherwise   = go (i+1)
+
+#elif !MIN_VERSION_base(4,8,0)
+countTrailingZeros :: Word -> Int
+countTrailingZeros x = popCount ((x .&. (-x)) - 1)
+{-# INLINE countTrailingZeros #-}
+#endif
+
+-- A bit queue builder. We represent a double word using two words
+-- because we don't currently have access to proper double words.
+data BitQueueB = BQB {-# UNPACK #-} !Word
+                     {-# UNPACK #-} !Word
+
+newtype BitQueue = BQ BitQueueB deriving Show
+
+-- Intended for debugging.
+instance Show BitQueueB where
+  show (BQB hi lo) = "BQ"++
+    show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0]
+            ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0])
+
+-- | Create an empty bit queue builder. This is represented as a single guard
+-- bit in the most significant position.
+emptyQB :: BitQueueB
+emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0
+{-# INLINE emptyQB #-}
+
+-- Shift the double word to the right by one bit.
+shiftQBR1 :: BitQueueB -> BitQueueB
+shiftQBR1 (BQB hi lo) = BQB hi' lo' where
+  lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
+  hi' = hi `shiftRL` 1
+{-# INLINE shiftQBR1 #-}
+
+-- | Enqueue a bit. This works by shifting the queue right one bit,
+-- then setting the most significant bit as requested.
+{-# INLINE snocQB #-}
+snocQB :: BitQueueB -> Bool -> BitQueueB
+snocQB bq b = case shiftQBR1 bq of
+  BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo
+
+-- | Convert a bit queue builder to a bit queue. This shifts in a new
+-- guard bit on the left, and shifts right until the old guard bit falls
+-- off.
+{-# INLINE buildQ #-}
+buildQ :: BitQueueB -> BitQueue
+buildQ (BQB hi 0) = BQ (BQB 0 lo') where
+  zeros = countTrailingZeros hi
+  lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros
+buildQ (BQB hi lo) = BQ (BQB hi' lo') where
+  zeros = countTrailingZeros lo
+  lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
+  hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))
+  lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros))
+  hi' = hi1 `shiftRL` zeros
+
+-- Test if the queue is empty, which occurs when theres
+-- nothing left but a guard bit in the least significant
+-- place.
+nullQ :: BitQueue -> Bool
+nullQ (BQ (BQB 0 1)) = True
+nullQ _ = False
+{-# INLINE nullQ #-}
+
+-- | Dequeue an element, or discover the queue is empty.
+unconsQ :: BitQueue -> Maybe (Bool, BitQueue)
+unconsQ q | nullQ q = Nothing
+unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl)
+  where
+    !hd = (lo .&. 1) /= 0
+    !tl = shiftQBR1 bq
+{-# INLINE unconsQ #-}
+
+-- | Convert a bit queue to a list of bits by unconsing.
+-- This is used to test that the queue functions properly.
+toListQ :: BitQueue -> [Bool]
+toListQ bq = case unconsQ bq of
+      Nothing -> []
+      Just (hd, tl) -> hd : toListQ tl
index 01457e2..b56c41b 100644 (file)
@@ -23,9 +23,16 @@ module Data.Utils.BitUtil
     ( highestBitMask
     , shiftLL
     , shiftRL
+    , wordSize
     ) where
 
 import Data.Bits ((.|.), xor)
+#if MIN_VERSION_base(4,7,0)
+import Data.Bits (finiteBitSize)
+#else
+import Data.Bits (bitSize)
+#endif
+
 
 #if __GLASGOW_HASKELL__
 import GHC.Exts (Word(..), Int(..))
@@ -61,9 +68,19 @@ shiftRL, shiftLL :: Word -> Int -> Word
 --------------------------------------------------------------------}
 shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i)
 shiftLL (W# x) (I# i) = W# (uncheckedShiftL#  x i)
+{-# INLINE CONLIKE shiftRL #-}
+{-# INLINE CONLIKE shiftLL #-}
 #else
 shiftRL x i   = shiftR x i
 shiftLL x i   = shiftL x i
-#endif
 {-# INLINE shiftRL #-}
 {-# INLINE shiftLL #-}
+#endif
+
+{-# INLINE wordSize #-}
+wordSize :: Int
+#if MIN_VERSION_base(4,7,0)
+wordSize = finiteBitSize (0 :: Word)
+#else
+wordSize = bitSize (0 :: Word)
+#endif
index 9d0e0e1..c7166b7 100644 (file)
@@ -1,15 +1,20 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
 module Main where
 
 import Control.Applicative (Const(Const, getConst), pure)
 import Control.DeepSeq
 import Control.Exception (evaluate)
-import Control.Monad.Trans (liftIO)
+import Control.Monad.IO.Class (liftIO)
 import Criterion.Main
-import Data.Functor.Identity (Identity(runIdentity))
+import Data.Functor.Identity (Identity(..))
 import Data.List (foldl')
 import qualified Data.Map as M
+import Data.Map (alterF)
 import Data.Maybe (fromMaybe)
+#if __GLASGOW_HASKELL__ >= 708
+import Data.Coerce
+#endif
 import Prelude hiding (lookup)
 
 main = do
@@ -20,16 +25,34 @@ main = do
     defaultMain
         [ bench "lookup absent" $ whnf (lookup evens) m_odd
         , bench "lookup present" $ whnf (lookup evens) m_even
-        , bench "at lookup absent" $ whnf (atLookup evens) m_odd
-        , bench "at lookup present" $ whnf (atLookup evens) m_even
-        , bench "atLens lookup absent" $ whnf (atLensLookup evens) m_odd
-        , bench "atLens lookup present" $ whnf (atLensLookup evens) m_even
+        , 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 "at insert absent" $ whnf (atIns elems_even) m_odd
-        , bench "at insert present" $ whnf (atIns elems_even) m_even
-        , bench "atLens insert absent" $ whnf (atLensIns elems_even) m_odd
-        , bench "atLens insert present" $ whnf (atLensIns 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
@@ -47,26 +70,12 @@ main = do
         , bench "foldlWithKey" $ whnf (ins elems) m
 --         , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m
         , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m
-        , bench "delete absent" $ whnf (del evens) m_odd
-        , bench "delete present" $ whnf (del evens) 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 "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 "at alter absent" $ whnf (atAlt id evens) m_odd
-        , bench "at alter insert" $ whnf (atAlt (const (Just 1)) evens) m_odd
-        , bench "at alter update" $ whnf (atAlt id evens) m_even
-        , bench "at alter delete" $ whnf (atAlt (const Nothing) evens) m
-        , bench "atLens alter absent" $ whnf (atLensAlt id evens) m_odd
-        , bench "atLens alter insert" $ whnf (atLensAlt (const (Just 1)) evens) m_odd
-        , bench "atLens alter update" $ whnf (atLensAlt id evens) m_even
-        , bench "atLens alter delete" $ whnf (atLensAlt (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
@@ -99,10 +108,14 @@ 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 (M.at k Const m))) 0 xs
+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
 
-atLensLookup :: [Int] -> M.Map Int Int -> Int
-atLensLookup xs m = foldl' (\n k -> fromMaybe n (getConst (atLens k Const m))) 0 xs
+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
@@ -111,10 +124,18 @@ 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 (M.at k (\_ -> pure (Just v)) m)) m xs
+atIns xs m = foldl' (\m (k, v) -> runIdentity (alterF (\_ -> Identity (Just v)) k m)) m xs
 
-atLensIns :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
-atLensIns xs m = foldl' (\m (k, v) -> runIdentity (atLens k (\_ -> pure (Just v)) 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
@@ -145,6 +166,12 @@ insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
 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
 
@@ -155,23 +182,10 @@ 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 (M.at k (pure . f) m)) m xs
-
-atLensAlt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
-atLensAlt f xs m = foldl' (\m k -> runIdentity (atLens k (pure . f) m)) m xs
-
--- implementation from Control.Lens.At for comparison
-atLens :: (Functor f, Ord k) =>
-          k -> (Maybe a -> f (Maybe a)) -> M.Map k a -> f (M.Map k a)
-atLens k f m = (`fmap` f mx) $ \ mx' ->
-  case mx' of
-    Just x' -> M.insert k x' m
-    Nothing ->
-      case mx of
-        Nothing -> m
-        Just x  -> M.delete k m
-  where mx = M.lookup k m
-{-# INLINE atLens #-}
+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
index 041fb08..9a7f28c 100644 (file)
@@ -8,13 +8,19 @@
   * Use `BangPatterns` throughout to reduce noise. This extension
     is now *required* to compile `containers`.
 
+  * Add `alterF` for `Data.Map`.
+
   * Add `Empty`, `:<|`, and `:|>` pattern synonyms for `Data.Sequence`.
 
   * Add `intersperse` and `traverseWithIndex` for `Data.Sequence`.
 
+  * Derive `Generic` and `Generic1` for `Data.Tree`.
+
   * Slightly optimize `replicateA` and `traverse` for `Data.Sequence`.
 
-  * Derive `Generic` and `Generic1` for `Data.Tree`.
+  * Speed up `adjust` for `Data.Map`.
+
+  * Speed up deletion and alteration functions for `Data.IntMap`.
 
 ## 0.5.7.1  *Dec 2015*
 
index b796a9f..f5411b9 100644 (file)
@@ -55,6 +55,7 @@ Library
         Data.IntSet.Base
         Data.Map.Base
         Data.Set.Base
+        Data.Utils.BitQueue
         Data.Utils.BitUtil
         Data.Utils.StrictFold
         Data.Utils.StrictPair
@@ -68,11 +69,6 @@ Library
 -- Every test-suite contains the build-depends and options of the library,
 -- plus the testing stuff.
 
--- Because the test-suites cannot contain conditionals in GHC 7.0, the extensions
--- are switched on for every compiler to allow GHC < 7.0 to compile the tests
--- (because GHC < 7.0 cannot handle conditional LANGUAGE pragmas).
--- When testing with GHC < 7.0 is not needed, the extensions should be removed.
-
 Test-suite map-lazy-properties
     hs-source-dirs: tests, .
     main-is: map-properties.hs
@@ -82,16 +78,16 @@ Test-suite map-lazy-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
-        -- only needed for base < 4.8 to get Identity
-        transformers,
         HUnit,
         QuickCheck,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2
+    if impl (ghc < 7.10)
+      -- only needed for base < 4.8 to get Identity
+      build-depends: transformers
 
 Test-suite map-strict-properties
     hs-source-dirs: tests, .
@@ -102,16 +98,32 @@ Test-suite map-strict-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         -- only needed for base < 4.8 to get Identity
-        transformers,
         HUnit,
         QuickCheck,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2
+    if impl (ghc < 7.10)
+      -- only needed for base < 4.8 to get Identity
+      build-depends: transformers
+
+Test-suite bitqueue-properties
+    hs-source-dirs: tests, .
+    main-is: bitqueue-properties.hs
+    type: exitcode-stdio-1.0
+    cpp-options: -DTESTING
+
+    build-depends: base >= 4.3 && < 5, ghc-prim
+    ghc-options: -O2
+    include-dirs: include
+
+    build-depends:
+        QuickCheck,
+        test-framework,
+        test-framework-quickcheck2
 
 Test-suite set-properties
     hs-source-dirs: tests, .
@@ -122,7 +134,6 @@ Test-suite set-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         HUnit,
@@ -140,7 +151,6 @@ Test-suite intmap-lazy-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         HUnit,
@@ -158,7 +168,6 @@ Test-suite intmap-strict-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         HUnit,
@@ -176,7 +185,6 @@ Test-suite intset-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         HUnit,
@@ -194,7 +202,6 @@ Test-suite deprecated-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         QuickCheck,
@@ -210,7 +217,6 @@ Test-suite seq-properties
     build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
     ghc-options: -O2
     include-dirs: include
-    extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types
 
     build-depends:
         QuickCheck,
diff --git a/tests/bitqueue-properties.hs b/tests/bitqueue-properties.hs
new file mode 100644 (file)
index 0000000..9554310
--- /dev/null
@@ -0,0 +1,33 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+
+import Control.Applicative ((<$>))
+import qualified Data.List as List
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Data.Utils.BitUtil (wordSize)
+import Data.Utils.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
index bb602df..e514429 100644 (file)
@@ -164,6 +164,10 @@ main = defaultMain
          , 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
@@ -417,8 +421,6 @@ test_at = do
     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
-    atAlter f k m = runIdentity (at k (pure . f) m)
-    atLookup k m = getConst (at k Const m)
     f _ = Nothing
     g _ = Just "c"
     employeeDept = fromList([("John","Sales"), ("Bob","IT")])
@@ -430,6 +432,31 @@ test_at = do
         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
 
@@ -1041,6 +1068,21 @@ prop_alter t k = balanced t' && case lookup k t of
     f Nothing   = Just ()
     f (Just ()) = Nothing
 
+prop_alterF_alter :: (Maybe Int -> Maybe Int) -> Int -> IMap -> Bool
+prop_alterF_alter f k m = valid altered && altered == alter f k m
+  where altered = atAlter f k m
+
+prop_alterF_alter_noRULES :: (Maybe Int -> Maybe Int) -> Int -> IMap -> Bool
+prop_alterF_alter_noRULES f k m = valid altered &&
+                                  altered == alter f k m
+  where altered = atAlterNoRULES 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)