packages feed

strict-containers (empty) → 0.1

raw patch · 65 files changed

+32510/−0 lines, 65 filesdep +ChasingBottomsdep +HUnitdep +QuickCheck

Dependencies added: ChasingBottoms, HUnit, QuickCheck, array, base, base-orphans, binary, containers, deepseq, hashable, indexed-traversable, primitive, random, semigroups, strict, strict-containers, tasty, tasty-hunit, tasty-quickcheck, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers, unordered-containers, vector, vector-binary-instances

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for strict-containers++## 0.1 -- 2021-04-20++- Initial release, defining strict versions of `Data.HashMap`, `Data.IntMap`,+  `Data.Map`, `Data.Sequence`, and `Data.Vector`.
+ LICENSE view
@@ -0,0 +1,24 @@+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ include/containers.h view
@@ -0,0 +1,41 @@+/*+ * Common macros for containers+ */++#ifndef HASKELL_CONTAINERS_H+#define HASKELL_CONTAINERS_H++/*+ * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+ */+#ifdef __GLASGOW_HASKELL__+#include "MachDeps.h"+#endif++/*+ * Define INSTANCE_TYPEABLE[0-2]+ */+#if __GLASGOW_HASKELL__ >= 707+#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon+#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable tycon+#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable tycon+#elif defined(__GLASGOW_HASKELL__)+#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon+#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable1 tycon+#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable2 tycon+#else+#define INSTANCE_TYPEABLE0(tycon)+#define INSTANCE_TYPEABLE1(tycon)+#define INSTANCE_TYPEABLE2(tycon)+#endif++#if __GLASGOW_HASKELL__ >= 800+#define DEFINE_PATTERN_SYNONYMS 1+#endif++#ifdef __GLASGOW_HASKELL__+# define USE_ST_MONAD 1+# define USE_UNBOXED_ARRAYS 1+#endif++#endif
+ src/Data/Strict/ContainersUtils/Autogen/BitQueue.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.ContainersUtils.Autogen.BitQueue+-- Copyright   :  (c) David Feuer 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- 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.Strict.ContainersUtils.Autogen.BitQueue+    ( BitQueue+    , BitQueueB+    , emptyQB+    , snocQB+    , buildQ+    , unconsQ+    , toListQ+    ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif+import Data.Strict.ContainersUtils.Autogen.BitUtil (shiftLL, shiftRL, wordSize)+import Data.Bits ((.|.), (.&.), testBit)+#if MIN_VERSION_base(4,8,0)+import Data.Bits (countTrailingZeros)+#else+import Data.Bits (popCount)+#endif++#if !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
+ src/Data/Strict/ContainersUtils/Autogen/BitUtil.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.ContainersUtils.Autogen.BitUtil+-- Copyright   :  (c) Clark Gaebel 2012+--                (c) Johan Tibel 2012+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+-----------------------------------------------------------------------------+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.++module Data.Strict.ContainersUtils.Autogen.BitUtil+    ( bitcount+    , highestBitMask+    , shiftLL+    , shiftRL+    , wordSize+    ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Bits ((.|.), xor)+#endif+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+import Data.Bits (bitSize)+#endif++#if !MIN_VERSION_base (4,8,0)+import Data.Word (Word)+#endif++{----------------------------------------------------------------------+  [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,+  based on the code on+  http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan,+  where the following source is given:+    Published in 1988, the C Programming Language 2nd Ed. (by Brian W.+    Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April+    19, 2006 Don Knuth pointed out to me that this method "was first published+    by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by+    Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"+----------------------------------------------------------------------}++bitcount :: Int -> Word -> Int+bitcount a x = a + popCount x+{-# INLINE bitcount #-}++-- The highestBitMask implementation is based on+-- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2+-- which has been put in the public domain.++-- | 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+                        x5 = x4 .|. x4 `shiftRL` 8+                        x6 = x5 .|. x5 `shiftRL` 16+#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)+                        x7 = x6 .|. x6 `shiftRL` 32+                     in x7 `xor` (x7 `shiftRL` 1)+#else+                     in x6 `xor` (x6 `shiftRL` 1)+#endif+#endif+{-# INLINE highestBitMask #-}++-- Right and left logical shifts.+shiftRL, shiftLL :: Word -> Int -> Word+shiftRL = unsafeShiftR+shiftLL = unsafeShiftL++{-# INLINE wordSize #-}+wordSize :: Int+#if MIN_VERSION_base(4,7,0)+wordSize = finiteBitSize (0 :: Word)+#else+wordSize = bitSize (0 :: Word)+#endif
+ src/Data/Strict/ContainersUtils/Autogen/Coercions.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}++#include "containers.h"++module Data.Strict.ContainersUtils.Autogen.Coercions where++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#endif++infixl 8 .#+#if __GLASGOW_HASKELL__ >= 708+(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c+(.#) f _ = coerce f+#else+(.#) :: (b -> c) -> (a -> b) -> a -> c+(.#) = (.)+#endif+{-# INLINE (.#) #-}++infix 9 .^#++-- | Coerce the second argument of a function. Conceptually,+-- can be thought of as:+--+-- @+--   (f .^# g) x y = f x (g y)+-- @+--+-- However it is most useful when coercing the arguments to+-- 'foldl':+--+-- @+--   foldl f b . fmap g = foldl (f .^# g) b+-- @+#if __GLASGOW_HASKELL__ >= 708+(.^#) :: Coercible c b => (a -> c -> d) -> (b -> c) -> (a -> b -> d)+(.^#) f _ = coerce f+#else+(.^#) :: (a -> c -> d) -> (b -> c) -> (a -> b -> d)+(f .^# g) x y = f x (g y)+#endif+{-# INLINE (.^#) #-}
+ src/Data/Strict/ContainersUtils/Autogen/PtrEquality.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif++{-# OPTIONS_HADDOCK hide #-}++-- | Really unsafe pointer equality+module Data.Strict.ContainersUtils.Autogen.PtrEquality (ptrEq, hetPtrEq) where++#ifdef __GLASGOW_HASKELL__+import GHC.Exts ( reallyUnsafePtrEquality# )+import Unsafe.Coerce ( unsafeCoerce )+#if __GLASGOW_HASKELL__ < 707+import GHC.Exts ( (==#) )+#else+import GHC.Exts ( isTrue# )+#endif+#endif++-- | Checks if two pointers are equal. Yes means yes;+-- no means maybe. The values should be forced to at least+-- WHNF before comparison to get moderately reliable results.+ptrEq :: a -> a -> Bool++-- | Checks if two pointers are equal, without requiring+-- them to have the same type. The values should be forced+-- to at least WHNF before comparison to get moderately+-- reliable results.+hetPtrEq :: a -> b -> Bool++#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ < 707+ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#+hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1#+#else+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)+hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y)+#endif++#else+-- Not GHC+ptrEq _ _ = False+hetPtrEq _ _ = False+#endif++{-# INLINE ptrEq #-}+{-# INLINE hetPtrEq #-}++infix 4 `ptrEq`+infix 4 `hetPtrEq`
+ src/Data/Strict/ContainersUtils/Autogen/State.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+#include "containers.h"+{-# OPTIONS_HADDOCK hide #-}++-- | A clone of Control.Monad.State.Strict.+module Data.Strict.ContainersUtils.Autogen.State where++import Prelude hiding (+#if MIN_VERSION_base(4,8,0)+    Applicative+#endif+    )++import Control.Monad (ap)+import Control.Applicative (Applicative(..), liftA)++newtype State s a = State {runState :: s -> (s, a)}++instance Functor (State s) where+    fmap = liftA++instance Monad (State s) where+    {-# INLINE return #-}+    {-# INLINE (>>=) #-}+    return = pure+    m >>= k = State $ \ s -> case runState m s of+        (s', x) -> runState (k x) s'++instance Applicative (State s) where+    {-# INLINE pure #-}+    pure x = State $ \ s -> (s, x)+    (<*>) = ap++execState :: State s a -> s -> a+execState m x = snd (runState m x)
+ src/Data/Strict/ContainersUtils/Autogen/StrictMaybe.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}++#include "containers.h"++{-# OPTIONS_HADDOCK hide #-}+-- | Strict 'Maybe'++module Data.Strict.ContainersUtils.Autogen.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable (..))+import Data.Monoid (Monoid (..))+#endif++data MaybeS a = NothingS | JustS !a++instance Foldable MaybeS where+  foldMap _ NothingS = mempty+  foldMap f (JustS a) = f a++maybeS :: r -> (a -> r) -> MaybeS a -> r+maybeS n _ NothingS = n+maybeS _ j (JustS a) = j a++toMaybe :: MaybeS a -> Maybe a+toMaybe NothingS = Nothing+toMaybe (JustS a) = Just a++toMaybeS :: Maybe a -> MaybeS a+toMaybeS Nothing = NothingS+toMaybeS (Just a) = JustS a
+ src/Data/Strict/ContainersUtils/Autogen/StrictPair.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-- | A strict pair++module Data.Strict.ContainersUtils.Autogen.StrictPair (StrictPair(..), toPair) where++-- | The same as a regular Haskell pair, but+--+-- @+-- (x :*: _|_) = (_|_ :*: y) = _|_+-- @+data StrictPair a b = !a :*: !b++infixr 1 :*:++-- | Convert a strict pair to a standard pair.+toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}
+ src/Data/Strict/ContainersUtils/Autogen/TypeError.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances,+     KindSignatures, TypeFamilies, CPP #-}++#if !defined(TESTING)+# if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+# else+{-# LANGUAGE Trustworthy #-}+#endif+#endif++-- | Unsatisfiable constraints for functions being removed.++module Data.Strict.ContainersUtils.Autogen.TypeError where+import GHC.TypeLits++-- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@.+-- Under GHC 8.0 and above, trying to use a function with a @Whoops s@+-- constraint will lead to a pretty type error explaining how to fix+-- the problem. Under earlier GHC versions, it will produce an extremely+-- ugly type error within which the desired message is buried.+--+-- ==== Example+--+-- @+-- oldFunction :: Whoops "oldFunction is gone now. Use newFunction."+--             => Int -> IntMap a -> IntMap a+-- @+class Whoops (a :: Symbol)++#if __GLASGOW_HASKELL__ >= 800+instance TypeError ('Text a) => Whoops a+#endif++-- Why don't we just use+--+-- type Whoops a = TypeError ('Text a) ?+--+-- When GHC sees the type signature of oldFunction, it will see that it+-- has an unsatisfiable constraint and reject it out of hand.+--+-- It seems possible to hack around that with a type family:+--+-- type family Whoops a where+--   Whoops a = TypeError ('Text a)+--+-- but I don't really trust that to work reliably. What we actually+-- do is pretty much guaranteed to work. Despite the fact that there+-- is a totally polymorphic instance in scope, GHC will refrain from+-- reducing the constraint because it knows someone could (theoretically)+-- define an overlapping instance of Whoops. It doesn't commit to+-- the polymorphic one until it has to, at the call site.
+ src/Data/Strict/HashMap.hs view
@@ -0,0 +1,21 @@+{- | Fully-strict version of "Data.HashMap.Strict".++Unlike @Data.HashMap.Strict@ t'Data.HashMap.Strict.HashMap' which is an alias+to @Data.HashMap.Lazy@ t'Data.HashMap.Lazy.HashMap', the instances of our {-+haddock #1251 -} t'Data.Strict.HashMap.HashMap' are all strict as well.++You should be able to switch from the former simply by changing your module+imports, and your package dependency from @containers@ to @strict-containers@.+If this doesn't work, please file a bug.++The documentation in the auto-generated modules have not been updated in a+particularly sophisticated way, so may sound weird or contradictory. In those+cases, please re-interpret such weird wording in the context of the above.+-}+module Data.Strict.HashMap+  ( module Data.Strict.HashMap.Autogen.Strict+  ) where++import Data.HashMap.Strict ()+import Data.Strict.HashMap.Internal+import Data.Strict.HashMap.Autogen.Strict
+ src/Data/Strict/HashMap/Autogen/Internal.hs view
@@ -0,0 +1,2305 @@+{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE LambdaCase #-}+#if __GLASGOW_HASKELL__ >= 802+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedSums #-}+#endif+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.++module Data.Strict.HashMap.Autogen.Internal+    (+      HashMap(..)+    , Leaf(..)++      -- * Construction+    , empty+    , singleton++      -- * Basic interface+    , null+    , size+    , member+    , lookup+    , (!?)+    , findWithDefault+    , lookupDefault+    , (!)+    , insert+    , insertWith+    , unsafeInsert+    , delete+    , adjust+    , update+    , alter+    , alterF+    , isSubmapOf+    , isSubmapOfBy++      -- * Combine+      -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions++    -- ** Compose+    , compose++      -- * Transformations+    , map+    , mapWithKey+    , traverseWithKey++      -- * Difference and intersection+    , difference+    , differenceWith+    , intersection+    , intersectionWith+    , intersectionWithKey++      -- * Folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++      -- * Filter+    , mapMaybe+    , mapMaybeWithKey+    , filter+    , filterWithKey++      -- * Conversions+    , keys+    , elems++      -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++      -- Internals used by the strict version+    , Hash+    , Bitmap+    , bitmapIndexedOrFull+    , collision+    , hash+    , mask+    , index+    , bitsPerSubkey+    , fullNodeMask+    , sparseIndex+    , two+    , unionArrayBy+    , update16+    , update16M+    , update16With'+    , updateOrConcatWith+    , updateOrConcatWithKey+    , filterMapAux+    , equalKeys+    , equalKeys1+    , lookupRecordCollision+    , LookupRes(..)+    , insert'+    , delete'+    , lookup'+    , insertNewKey+    , insertKeyExists+    , deleteKeyExists+    , insertModifying+    , ptrEq+    , adjust#+    ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), Applicative(pure))+import Data.Monoid (Monoid(mempty, mappend))+import Data.Traversable (Traversable(..))+import Data.Word (Word)+#endif+#if __GLASGOW_HASKELL__ >= 711+import Data.Semigroup (Semigroup((<>)))+#endif+import Control.DeepSeq (NFData(rnf))+import Control.Monad.ST (ST)+import Data.Bits ((.&.), (.|.), complement, popCount, unsafeShiftL, unsafeShiftR)+import Data.Data hiding (Typeable)+import qualified Data.Foldable as Foldable+#if MIN_VERSION_base(4,10,0)+import Data.Bifoldable+#endif+import qualified Data.List as L+import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, inline)+import Prelude hiding (filter, foldl, foldr, lookup, map, null, pred)+import Text.Read hiding (step)++import qualified Data.Strict.HashMap.Autogen.Internal.Array as A+import qualified Data.Hashable as H+import Data.Hashable (Hashable)+import Data.Strict.HashMap.Autogen.Internal.Unsafe (runST)+import Data.Strict.HashMap.Autogen.Internal.List (isPermutationBy, unorderedCompare)+import Data.Typeable (Typeable)++import GHC.Exts (isTrue#)+import qualified GHC.Exts as Exts++#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes+import GHC.Stack+#endif++#if MIN_VERSION_hashable(1,2,5)+import qualified Data.Hashable.Lifted as H+#endif++#if __GLASGOW_HASKELL__ >= 802+import GHC.Exts (TYPE, Int (..), Int#)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity (..))+#endif+import Control.Applicative (Const (..))+import Data.Coerce (coerce)++-- | A set of values.  A set cannot contain duplicate values.+------------------------------------------------------------------------++-- | Convenience function.  Compute a hash value for the given value.+hash :: H.Hashable a => a -> Hash+hash = fromIntegral . H.hash++data Leaf k v = L !k !v+  deriving (Eq)++instance (NFData k, NFData v) => NFData (Leaf k v) where+    rnf (L k v) = rnf k `seq` rnf v++-- Invariant: The length of the 1st argument to 'Full' is+-- 2^bitsPerSubkey++-- | A map from keys to values.  A map cannot contain duplicate keys;+-- each key can map to at most one value.+data HashMap k v+    = Empty+    | BitmapIndexed !Bitmap !(A.Array (HashMap k v))+    | Leaf !Hash !(Leaf k v)+    | Full !(A.Array (HashMap k v))+    | Collision !Hash !(A.Array (Leaf k v))+      deriving (Typeable)++type role HashMap nominal representational++instance (NFData k, NFData v) => NFData (HashMap k v) where+    rnf Empty                 = ()+    rnf (BitmapIndexed _ ary) = rnf ary+    rnf (Leaf _ l)            = rnf l+    rnf (Full ary)            = rnf ary+    rnf (Collision _ ary)     = rnf ary++instance Functor (HashMap k) where+    fmap = map++instance Foldable.Foldable (HashMap k) where+    foldMap f = foldMapWithKey (\ _k v -> f v)+    {-# INLINE foldMap #-}+    foldr = foldr+    {-# INLINE foldr #-}+    foldl = foldl+    {-# INLINE foldl #-}+    foldr' = foldr'+    {-# INLINE foldr' #-}+    foldl' = foldl'+    {-# INLINE foldl' #-}+#if MIN_VERSION_base(4,8,0)+    null = null+    {-# INLINE null #-}+    length = size+    {-# INLINE length #-}+#endif++#if MIN_VERSION_base(4,10,0)+-- | @since 0.2.11+instance Bifoldable HashMap where+    bifoldMap f g = foldMapWithKey (\ k v -> f k `mappend` g v)+    {-# INLINE bifoldMap #-}+    bifoldr f g = foldrWithKey (\ k v acc -> k `f` (v `g` acc))+    {-# INLINE bifoldr #-}+    bifoldl f g = foldlWithKey (\ acc k v -> (acc `f` k) `g` v)+    {-# INLINE bifoldl #-}+#endif++#if __GLASGOW_HASKELL__ >= 711+-- | '<>' = 'union'+--+-- If a key occurs in both maps, the mapping from the first will be the mapping in the result.+--+-- ==== __Examples__+--+-- >>> fromList [(1,'a'),(2,'b')] <> fromList [(2,'c'),(3,'d')]+-- fromList [(1,'a'),(2,'b'),(3,'d')]+instance (Eq k, Hashable k) => Semigroup (HashMap k v) where+  (<>) = union+  {-# INLINE (<>) #-}+#endif++-- | 'mempty' = 'empty'+--+-- 'mappend' = 'union'+--+-- If a key occurs in both maps, the mapping from the first will be the mapping in the result.+--+-- ==== __Examples__+--+-- >>> mappend (fromList [(1,'a'),(2,'b')]) (fromList [(2,'c'),(3,'d')])+-- fromList [(1,'a'),(2,'b'),(3,'d')]+instance (Eq k, Hashable k) => Monoid (HashMap k v) where+  mempty = empty+  {-# INLINE mempty #-}+#if __GLASGOW_HASKELL__ >= 711+  mappend = (<>)+#else+  mappend = union+#endif+  {-# INLINE mappend #-}++instance (Data k, Data v, Eq k, Hashable k) => Data (HashMap k v) where+    gfoldl f z m   = z fromList `f` toList m+    toConstr _     = fromListConstr+    gunfold k z c  = case constrIndex c of+        1 -> k (z fromList)+        _ -> error "gunfold"+    dataTypeOf _   = hashMapDataType+    dataCast2 f    = gcast2 f++fromListConstr :: Constr+fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix++hashMapDataType :: DataType+hashMapDataType = mkDataType "Data.Strict.HashMap.Autogen.Internal.HashMap" [fromListConstr]++type Hash   = Word+type Bitmap = Word+type Shift  = Int++#if MIN_VERSION_base(4,9,0)+instance Show2 HashMap where+    liftShowsPrec2 spk slk spv slv d m =+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)+      where+        sp = liftShowsPrec2 spk slk spv slv+        sl = liftShowList2 spk slk spv slv++instance Show k => Show1 (HashMap k) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++instance (Eq k, Hashable k, Read k) => Read1 (HashMap k) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl+#endif++instance (Eq k, Hashable k, Read k, Read e) => Read (HashMap k e) where+    readPrec = parens $ prec 10 $ do+      Ident "fromList" <- lexP+      xs <- readPrec+      return (fromList xs)++    readListPrec = readListPrecDefault++instance (Show k, Show v) => Show (HashMap k v) where+    showsPrec d m = showParen (d > 10) $+      showString "fromList " . shows (toList m)++instance Traversable (HashMap k) where+    traverse f = traverseWithKey (const f)+    {-# INLINABLE traverse #-}++#if MIN_VERSION_base(4,9,0)+instance Eq2 HashMap where+    liftEq2 = equal2++instance Eq k => Eq1 (HashMap k) where+    liftEq = equal1+#endif++-- | Note that, in the presence of hash collisions, equal @HashMap@s may+-- behave differently, i.e. substitutivity may be violated:+--+-- >>> data D = A | B deriving (Eq, Show)+-- >>> instance Hashable D where hashWithSalt salt _d = salt+--+-- >>> x = fromList [(A,1), (B,2)]+-- >>> y = fromList [(B,2), (A,1)]+--+-- >>> x == y+-- True+-- >>> toList x+-- [(A,1),(B,2)]+-- >>> toList y+-- [(B,2),(A,1)]+--+-- In general, the lack of substitutivity can be observed with any function+-- that depends on the key ordering, such as folds and traversals.+instance (Eq k, Eq v) => Eq (HashMap k v) where+    (==) = equal1 (==)++-- We rely on there being no Empty constructors in the tree!+-- This ensures that two equal HashMaps will have the same+-- shape, modulo the order of entries in Collisions.+equal1 :: Eq k+       => (v -> v' -> Bool)+       -> HashMap k v -> HashMap k v' -> Bool+equal1 eq = go+  where+    go Empty Empty = True+    go (BitmapIndexed bm1 ary1) (BitmapIndexed bm2 ary2)+      = bm1 == bm2 && A.sameArray1 go ary1 ary2+    go (Leaf h1 l1) (Leaf h2 l2) = h1 == h2 && leafEq l1 l2+    go (Full ary1) (Full ary2) = A.sameArray1 go ary1 ary2+    go (Collision h1 ary1) (Collision h2 ary2)+      = h1 == h2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2)+    go _ _ = False++    leafEq (L k1 v1) (L k2 v2) = k1 == k2 && eq v1 v2++equal2 :: (k -> k' -> Bool) -> (v -> v' -> Bool)+      -> HashMap k v -> HashMap k' v' -> Bool+equal2 eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 [])+  where+    -- If the two trees are the same, then their lists of 'Leaf's and+    -- 'Collision's read from left to right should be the same (modulo the+    -- order of elements in 'Collision').++    go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+      | k1 == k2 &&+        leafEq l1 l2+      = go tl1 tl2+    go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)+      | k1 == k2 &&+        A.length ary1 == A.length ary2 &&+        isPermutationBy leafEq (A.toList ary1) (A.toList ary2)+      = go tl1 tl2+    go [] [] = True+    go _  _  = False++    leafEq (L k v) (L k' v') = eqk k k' && eqv v v'++#if MIN_VERSION_base(4,9,0)+instance Ord2 HashMap where+    liftCompare2 = cmp++instance Ord k => Ord1 (HashMap k) where+    liftCompare = cmp compare+#endif++-- | The ordering is total and consistent with the `Eq` instance. However,+-- nothing else about the ordering is specified, and it may change from+-- version to version of either this package or of hashable.+instance (Ord k, Ord v) => Ord (HashMap k v) where+    compare = cmp compare compare++cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering)+    -> HashMap k v -> HashMap k' v' -> Ordering+cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 [])+  where+    go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+      = compare k1 k2 `mappend`+        leafCompare l1 l2 `mappend`+        go tl1 tl2+    go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)+      = compare k1 k2 `mappend`+        compare (A.length ary1) (A.length ary2) `mappend`+        unorderedCompare leafCompare (A.toList ary1) (A.toList ary2) `mappend`+        go tl1 tl2+    go (Leaf _ _ : _) (Collision _ _ : _) = LT+    go (Collision _ _ : _) (Leaf _ _ : _) = GT+    go [] [] = EQ+    go [] _  = LT+    go _  [] = GT+    go _ _ = error "cmp: Should never happen, toList' includes non Leaf / Collision"++    leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v'++-- Same as 'equal' but doesn't compare the values.+equalKeys1 :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool+equalKeys1 eq t1 t2 = go (toList' t1 []) (toList' t2 [])+  where+    go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+      | k1 == k2 && leafEq l1 l2+      = go tl1 tl2+    go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)+      | k1 == k2 && A.length ary1 == A.length ary2 &&+        isPermutationBy leafEq (A.toList ary1) (A.toList ary2)+      = go tl1 tl2+    go [] [] = True+    go _  _  = False++    leafEq (L k _) (L k' _) = eq k k'++-- Same as 'equal1' but doesn't compare the values.+equalKeys :: Eq k => HashMap k v -> HashMap k v' -> Bool+equalKeys = go+  where+    go :: Eq k => HashMap k v -> HashMap k v' -> Bool+    go Empty Empty = True+    go (BitmapIndexed bm1 ary1) (BitmapIndexed bm2 ary2)+      = bm1 == bm2 && A.sameArray1 go ary1 ary2+    go (Leaf h1 l1) (Leaf h2 l2) = h1 == h2 && leafEq l1 l2+    go (Full ary1) (Full ary2) = A.sameArray1 go ary1 ary2+    go (Collision h1 ary1) (Collision h2 ary2)+      = h1 == h2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2)+    go _ _ = False++    leafEq (L k1 _) (L k2 _) = k1 == k2++#if MIN_VERSION_hashable(1,2,5)+instance H.Hashable2 HashMap where+    liftHashWithSalt2 hk hv salt hm = go salt (toList' hm [])+      where+        -- go :: Int -> [HashMap k v] -> Int+        go s [] = s+        go s (Leaf _ l : tl)+          = s `hashLeafWithSalt` l `go` tl+        -- For collisions we hashmix hash value+        -- and then array of values' hashes sorted+        go s (Collision h a : tl)+          = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl+        go s (_ : tl) = s `go` tl++        -- hashLeafWithSalt :: Int -> Leaf k v -> Int+        hashLeafWithSalt s (L k v) = (s `hk` k) `hv` v++        -- hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int+        hashCollisionWithSalt s+          = L.foldl' H.hashWithSalt s . arrayHashesSorted s++        -- arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int]+        arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList++instance (Hashable k) => H.Hashable1 (HashMap k) where+    liftHashWithSalt = H.liftHashWithSalt2 H.hashWithSalt+#endif++instance (Hashable k, Hashable v) => Hashable (HashMap k v) where+    hashWithSalt salt hm = go salt hm+      where+        go :: Int -> HashMap k v -> Int+        go s Empty = s+        go s (BitmapIndexed _ a) = A.foldl' go s a+        go s (Leaf h (L _ v))+          = s `H.hashWithSalt` h `H.hashWithSalt` v+        -- For collisions we hashmix hash value+        -- and then array of values' hashes sorted+        go s (Full a) = A.foldl' go s a+        go s (Collision h a)+          = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a++        hashLeafWithSalt :: Int -> Leaf k v -> Int+        hashLeafWithSalt s (L k v) = s `H.hashWithSalt` k `H.hashWithSalt` v++        hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int+        hashCollisionWithSalt s+          = L.foldl' H.hashWithSalt s . arrayHashesSorted s++        arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int]+        arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList++  -- Helper to get 'Leaf's and 'Collision's as a list.+toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v]+toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary+toList' (Full ary)            a = A.foldr toList' a ary+toList' l@(Leaf _ _)          a = l : a+toList' c@(Collision _ _)     a = c : a+toList' Empty                 a = a++-- Helper function to detect 'Leaf's and 'Collision's.+isLeafOrCollision :: HashMap k v -> Bool+isLeafOrCollision (Leaf _ _)      = True+isLeafOrCollision (Collision _ _) = True+isLeafOrCollision _               = False++------------------------------------------------------------------------+-- * Construction++-- | /O(1)/ Construct an empty map.+empty :: HashMap k v+empty = Empty++-- | /O(1)/ Construct a map with a single element.+singleton :: (Hashable k) => k -> v -> HashMap k v+singleton k v = Leaf (hash k) (L k v)++------------------------------------------------------------------------+-- * Basic interface++-- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise.+null :: HashMap k v -> Bool+null Empty = True+null _   = False++-- | /O(n)/ Return the number of key-value mappings in this map.+size :: HashMap k v -> Int+size t = go t 0+  where+    go Empty                !n = n+    go (Leaf _ _)            n = n + 1+    go (BitmapIndexed _ ary) n = A.foldl' (flip go) n ary+    go (Full ary)            n = A.foldl' (flip go) n ary+    go (Collision _ ary)     n = n + A.length ary++-- | /O(log n)/ Return 'True' if the specified key is present in the+-- map, 'False' otherwise.+member :: (Eq k, Hashable k) => k -> HashMap k a -> Bool+member k m = case lookup k m of+    Nothing -> False+    Just _  -> True+{-# INLINABLE member #-}++-- | /O(log n)/ Return the value to which the specified key is mapped,+-- or 'Nothing' if this map contains no mapping for the key.+lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v+#if __GLASGOW_HASKELL__ >= 802+-- GHC does not yet perform a worker-wrapper transformation on+-- unboxed sums automatically. That seems likely to happen at some+-- point (possibly as early as GHC 8.6) but for now we do it manually.+lookup k m = case lookup# k m of+  (# (# #) | #) -> Nothing+  (# | a #) -> Just a+{-# INLINE lookup #-}++lookup# :: (Eq k, Hashable k) => k -> HashMap k v -> (# (# #) | v #)+lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash k) k 0 m+{-# INLINABLE lookup# #-}++#else++lookup k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) (hash k) k 0 m+{-# INLINABLE lookup #-}+#endif++-- | lookup' is a version of lookup that takes the hash separately.+-- It is used to implement alterF.+lookup' :: Eq k => Hash -> k -> HashMap k v -> Maybe v+#if __GLASGOW_HASKELL__ >= 802+-- GHC does not yet perform a worker-wrapper transformation on+-- unboxed sums automatically. That seems likely to happen at some+-- point (possibly as early as GHC 8.6) but for now we do it manually.+-- lookup' would probably prefer to be implemented in terms of its own+-- lookup'#, but it's not important enough and we don't want too much+-- code.+lookup' h k m = case lookupRecordCollision# h k m of+  (# (# #) | #) -> Nothing+  (# | (# a, _i #) #) -> Just a+{-# INLINE lookup' #-}+#else+lookup' h k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) h k 0 m+{-# INLINABLE lookup' #-}+#endif++-- The result of a lookup, keeping track of if a hash collision occured.+-- If a collision did not occur then it will have the Int value (-1).+data LookupRes a = Absent | Present a !Int++-- Internal helper for lookup. This version takes the precomputed hash so+-- that functions that make multiple calls to lookup and related functions+-- (insert, delete) only need to calculate the hash once.+--+-- It is used by 'alterF' so that hash computation and key comparison only needs+-- to be performed once. With this information you can use the more optimized+-- versions of insert ('insertNewKey', 'insertKeyExists') and delete+-- ('deleteKeyExists')+--+-- Outcomes:+--   Key not in map           => Absent+--   Key in map, no collision => Present v (-1)+--   Key in map, collision    => Present v position+lookupRecordCollision :: Eq k => Hash -> k -> HashMap k v -> LookupRes v+#if __GLASGOW_HASKELL__ >= 802+lookupRecordCollision h k m = case lookupRecordCollision# h k m of+  (# (# #) | #) -> Absent+  (# | (# a, i #) #) -> Present a (I# i) -- GHC will eliminate the I#+{-# INLINE lookupRecordCollision #-}++-- Why do we produce an Int# instead of an Int? Unfortunately, GHC is not+-- yet any good at unboxing things *inside* products, let alone sums. That+-- may be changing in GHC 8.6 or so (there is some work in progress), but+-- for now we use Int# explicitly here. We don't need to push the Int#+-- into lookupCont because inlining takes care of that.+lookupRecordCollision# :: Eq k => Hash -> k -> HashMap k v -> (# (# #) | (# v, Int# #) #)+lookupRecordCollision# h k m =+    lookupCont (\_ -> (# (# #) | #)) (\v (I# i) -> (# | (# v, i #) #)) h k 0 m+-- INLINABLE to specialize to the Eq instance.+{-# INLINABLE lookupRecordCollision# #-}++#else /* GHC < 8.2 so there are no unboxed sums */++lookupRecordCollision h k m = lookupCont (\_ -> Absent) Present h k 0 m+{-# INLINABLE lookupRecordCollision #-}+#endif++-- A two-continuation version of lookupRecordCollision. This lets us+-- share source code between lookup and lookupRecordCollision without+-- risking any performance degradation.+--+-- The absent continuation has type @((# #) -> r)@ instead of just @r@+-- so we can be representation-polymorphic in the result type. Since+-- this whole thing is always inlined, we don't have to worry about+-- any extra CPS overhead.+--+-- The @Int@ argument is the offset of the subkey in the hash. When looking up+-- keys at the top-level of a hashmap, the offset should be 0. When looking up+-- keys at level @n@ of a hashmap, the offset should be @n * bitsPerSubkey@.+lookupCont ::+#if __GLASGOW_HASKELL__ >= 802+  forall rep (r :: TYPE rep) k v.+#else+  forall r k v.+#endif+     Eq k+  => ((# #) -> r)    -- Absent continuation+  -> (v -> Int -> r) -- Present continuation+  -> Hash -- The hash of the key+  -> k+  -> Int -- The offset of the subkey in the hash.+  -> HashMap k v -> r+lookupCont absent present !h0 !k0 !s0 !m0 = go h0 k0 s0 m0+  where+    go :: Eq k => Hash -> k -> Int -> HashMap k v -> r+    go !_ !_ !_ Empty = absent (# #)+    go h k _ (Leaf hx (L kx x))+        | h == hx && k == kx = present x (-1)+        | otherwise          = absent (# #)+    go h k s (BitmapIndexed b v)+        | b .&. m == 0 = absent (# #)+        | otherwise    =+            go h k (s+bitsPerSubkey) (A.index v (sparseIndex b m))+      where m = mask h s+    go h k s (Full v) =+      go h k (s+bitsPerSubkey) (A.index v (index h s))+    go h k _ (Collision hx v)+        | h == hx   = lookupInArrayCont absent present k v+        | otherwise = absent (# #)+{-# INLINE lookupCont #-}++-- | /O(log n)/ Return the value to which the specified key is mapped,+-- or 'Nothing' if this map contains no mapping for the key.+--+-- This is a flipped version of 'lookup'.+--+-- @since 0.2.11+(!?) :: (Eq k, Hashable k) => HashMap k v -> k -> Maybe v+(!?) m k = lookup k m+{-# INLINE (!?) #-}+++-- | /O(log n)/ Return the value to which the specified key is mapped,+-- or the default value if this map contains no mapping for the key.+--+-- @since 0.2.11+findWithDefault :: (Eq k, Hashable k)+              => v          -- ^ Default value to return.+              -> k -> HashMap k v -> v+findWithDefault def k t = case lookup k t of+    Just v -> v+    _      -> def+{-# INLINABLE findWithDefault #-}+++-- | /O(log n)/ Return the value to which the specified key is mapped,+-- or the default value if this map contains no mapping for the key.+--+-- DEPRECATED: lookupDefault is deprecated as of version 0.2.11, replaced+-- by 'findWithDefault'.+lookupDefault :: (Eq k, Hashable k)+              => v          -- ^ Default value to return.+              -> k -> HashMap k v -> v+lookupDefault def k t = findWithDefault def k t+{-# INLINE lookupDefault #-}++-- | /O(log n)/ Return the value to which the specified key is mapped.+-- Calls 'error' if this map contains no mapping for the key.+#if MIN_VERSION_base(4,9,0)+(!) :: (Eq k, Hashable k, HasCallStack) => HashMap k v -> k -> v+#else+(!) :: (Eq k, Hashable k) => HashMap k v -> k -> v+#endif+(!) m k = case lookup k m of+    Just v  -> v+    Nothing -> error "Data.Strict.HashMap.Autogen.Internal.(!): key not found"+{-# INLINABLE (!) #-}++infixl 9 !++-- | Create a 'Collision' value with two 'Leaf' values.+collision :: Hash -> Leaf k v -> Leaf k v -> HashMap k v+collision h !e1 !e2 =+    let v = A.run $ do mary <- A.new 2 e1+                       A.write mary 1 e2+                       return mary+    in Collision h v+{-# INLINE collision #-}++-- | Create a 'BitmapIndexed' or 'Full' node.+bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap k v) -> HashMap k v+bitmapIndexedOrFull b ary+    | b == fullNodeMask = Full ary+    | otherwise         = BitmapIndexed b ary+{-# INLINE bitmapIndexedOrFull #-}++-- | /O(log n)/ Associate the specified value with the specified+-- key in this map.  If this map previously contained a mapping for+-- the key, the old value is replaced.+insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v+insert k v m = insert' (hash k) k v m+{-# INLINABLE insert #-}++insert' :: Eq k => Hash -> k -> v -> HashMap k v -> HashMap k v+insert' h0 k0 v0 m0 = go h0 k0 v0 0 m0+  where+    go !h !k x !_ Empty = Leaf h (L k x)+    go h k x s t@(Leaf hy l@(L ky y))+        | hy == h = if ky == k+                    then if x `ptrEq` y+                         then t+                         else Leaf h (L k x)+                    else collision h l (L k x)+        | otherwise = runST (two s h k x hy t)+    go h k x s t@(BitmapIndexed b ary)+        | b .&. m == 0 =+            let !ary' = A.insert ary i $! Leaf h (L k x)+            in bitmapIndexedOrFull (b .|. m) ary'+        | otherwise =+            let !st  = A.index ary i+                !st' = go h k x (s+bitsPerSubkey) st+            in if st' `ptrEq` st+               then t+               else BitmapIndexed b (A.update ary i st')+      where m = mask h s+            i = sparseIndex b m+    go h k x s t@(Full ary) =+        let !st  = A.index ary i+            !st' = go h k x (s+bitsPerSubkey) st+        in if st' `ptrEq` st+            then t+            else Full (update16 ary i st')+      where i = index h s+    go h k x s t@(Collision hy v)+        | h == hy   = Collision h (updateOrSnocWith (\a _ -> (# a #)) k x v)+        | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE insert' #-}++-- Insert optimized for the case when we know the key is not in the map.+--+-- It is only valid to call this when the key does not exist in the map.+--+-- We can skip:+--  - the key equality check on a Leaf+--  - check for its existence in the array for a hash collision+insertNewKey :: Hash -> k -> v -> HashMap k v -> HashMap k v+insertNewKey !h0 !k0 x0 !m0 = go h0 k0 x0 0 m0+  where+    go !h !k x !_ Empty = Leaf h (L k x)+    go h k x s t@(Leaf hy l)+      | hy == h = collision h l (L k x)+      | otherwise = runST (two s h k x hy t)+    go h k x s (BitmapIndexed b ary)+        | b .&. m == 0 =+            let !ary' = A.insert ary i $! Leaf h (L k x)+            in bitmapIndexedOrFull (b .|. m) ary'+        | otherwise =+            let !st  = A.index ary i+                !st' = go h k x (s+bitsPerSubkey) st+            in BitmapIndexed b (A.update ary i st')+      where m = mask h s+            i = sparseIndex b m+    go h k x s (Full ary) =+        let !st  = A.index ary i+            !st' = go h k x (s+bitsPerSubkey) st+        in Full (update16 ary i st')+      where i = index h s+    go h k x s t@(Collision hy v)+        | h == hy   = Collision h (snocNewLeaf (L k x) v)+        | otherwise =+            go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+      where+        snocNewLeaf :: Leaf k v -> A.Array (Leaf k v) -> A.Array (Leaf k v)+        snocNewLeaf leaf ary = A.run $ do+          let n = A.length ary+          mary <- A.new_ (n + 1)+          A.copy ary 0 mary 0 n+          A.write mary n leaf+          return mary+{-# NOINLINE insertNewKey #-}+++-- Insert optimized for the case when we know the key is in the map.+--+-- It is only valid to call this when the key exists in the map and you know the+-- hash collision position if there was one. This information can be obtained+-- from 'lookupRecordCollision'. If there is no collision pass (-1) as collPos+-- (first argument).+--+-- We can skip the key equality check on a Leaf because we know the leaf must be+-- for this key.+insertKeyExists :: Int -> Hash -> k -> v -> HashMap k v -> HashMap k v+insertKeyExists !collPos0 !h0 !k0 x0 !m0 = go collPos0 h0 k0 x0 0 m0+  where+    go !_collPos !h !k x !_s (Leaf _hy _kx)+        = Leaf h (L k x)+    go collPos h k x s (BitmapIndexed b ary)+        | b .&. m == 0 =+            let !ary' = A.insert ary i $ Leaf h (L k x)+            in bitmapIndexedOrFull (b .|. m) ary'+        | otherwise =+            let !st  = A.index ary i+                !st' = go collPos h k x (s+bitsPerSubkey) st+            in BitmapIndexed b (A.update ary i st')+      where m = mask h s+            i = sparseIndex b m+    go collPos h k x s (Full ary) =+        let !st  = A.index ary i+            !st' = go collPos h k x (s+bitsPerSubkey) st+        in Full (update16 ary i st')+      where i = index h s+    go collPos h k x _s (Collision _hy v)+        | collPos >= 0 = Collision h (setAtPosition collPos k x v)+        | otherwise = Empty -- error "Internal error: go {collPos negative}"+    go _ _ _ _ _ Empty = Empty -- error "Internal error: go Empty"++{-# NOINLINE insertKeyExists #-}++-- Replace the ith Leaf with Leaf k v.+--+-- This does not check that @i@ is within bounds of the array.+setAtPosition :: Int -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v)+setAtPosition i k x ary = A.update ary i (L k x)+{-# INLINE setAtPosition #-}+++-- | In-place update version of insert+unsafeInsert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v+unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0)+  where+    h0 = hash k0+    go !h !k x !_ Empty = return $! Leaf h (L k x)+    go h k x s t@(Leaf hy l@(L ky y))+        | hy == h = if ky == k+                    then if x `ptrEq` y+                         then return t+                         else return $! Leaf h (L k x)+                    else return $! collision h l (L k x)+        | otherwise = two s h k x hy t+    go h k x s t@(BitmapIndexed b ary)+        | b .&. m == 0 = do+            ary' <- A.insertM ary i $! Leaf h (L k x)+            return $! bitmapIndexedOrFull (b .|. m) ary'+        | otherwise = do+            st <- A.indexM ary i+            st' <- go h k x (s+bitsPerSubkey) st+            A.unsafeUpdateM ary i st'+            return t+      where m = mask h s+            i = sparseIndex b m+    go h k x s t@(Full ary) = do+        st <- A.indexM ary i+        st' <- go h k x (s+bitsPerSubkey) st+        A.unsafeUpdateM ary i st'+        return t+      where i = index h s+    go h k x s t@(Collision hy v)+        | h == hy   = return $! Collision h (updateOrSnocWith (\a _ -> (# a #)) k x v)+        | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE unsafeInsert #-}++-- | Create a map from two key-value pairs which hashes don't collide. To+-- enhance sharing, the second key-value pair is represented by the hash of its+-- key and a singleton HashMap pairing its key with its value.+--+-- Note: to avoid silly thunks, this function must be strict in the+-- key. See issue #232. We don't need to force the HashMap argument+-- because it's already in WHNF (having just been matched) and we+-- just put it directly in an array.+two :: Shift -> Hash -> k -> v -> Hash -> HashMap k v -> ST s (HashMap k v)+two = go+  where+    go s h1 k1 v1 h2 t2+        | bp1 == bp2 = do+            st <- go (s+bitsPerSubkey) h1 k1 v1 h2 t2+            ary <- A.singletonM st+            return $ BitmapIndexed bp1 ary+        | otherwise  = do+            mary <- A.new 2 $! Leaf h1 (L k1 v1)+            A.write mary idx2 t2+            ary <- A.unsafeFreeze mary+            return $ BitmapIndexed (bp1 .|. bp2) ary+      where+        bp1  = mask h1 s+        bp2  = mask h2 s+        idx2 | index h1 s < index h2 s = 1+             | otherwise               = 0+{-# INLINE two #-}++-- | /O(log n)/ Associate the value with the key in this map.  If+-- this map previously contained a mapping for the key, the old value+-- is replaced by the result of applying the given function to the new+-- and old value.  Example:+--+-- > insertWith f k v map+-- >   where f new old = new + old+insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v+            -> HashMap k v+-- We're not going to worry about allocating a function closure+-- to pass to insertModifying. See comments at 'adjust'.+insertWith f k new m = insertModifying new (\old -> (# f new old #)) k m+{-# INLINE insertWith #-}++-- | @insertModifying@ is a lot like insertWith; we use it to implement alterF.+-- It takes a value to insert when the key is absent and a function+-- to apply to calculate a new value when the key is present. Thanks+-- to the unboxed unary tuple, we avoid introducing any unnecessary+-- thunks in the tree.+insertModifying :: (Eq k, Hashable k) => v -> (v -> (# v #)) -> k -> HashMap k v+            -> HashMap k v+insertModifying x f k0 m0 = go h0 k0 0 m0+  where+    !h0 = hash k0+    go !h !k !_ Empty = Leaf h (L k x)+    go h k s t@(Leaf hy l@(L ky y))+        | hy == h = if ky == k+                    then case f y of+                      (# v' #) | ptrEq y v' -> t+                               | otherwise -> Leaf h (L k (v'))+                    else collision h l (L k x)+        | otherwise = runST (two s h k x hy t)+    go h k s t@(BitmapIndexed b ary)+        | b .&. m == 0 =+            let ary' = A.insert ary i $! Leaf h (L k x)+            in bitmapIndexedOrFull (b .|. m) ary'+        | otherwise =+            let !st   = A.index ary i+                !st'  = go h k (s+bitsPerSubkey) st+                ary'  = A.update ary i $! st'+            in if ptrEq st st'+               then t+               else BitmapIndexed b ary'+      where m = mask h s+            i = sparseIndex b m+    go h k s t@(Full ary) =+        let !st   = A.index ary i+            !st'  = go h k (s+bitsPerSubkey) st+            ary' = update16 ary i $! st'+        in if ptrEq st st'+           then t+           else Full ary'+      where i = index h s+    go h k s t@(Collision hy v)+        | h == hy   =+            let !v' = insertModifyingArr x f k v+            in if A.unsafeSameArray v v'+               then t+               else Collision h v'+        | otherwise = go h k s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE insertModifying #-}++-- Like insertModifying for arrays; used to implement insertModifying+insertModifyingArr :: Eq k => v -> (v -> (# v #)) -> k -> A.Array (Leaf k v)+                 -> A.Array (Leaf k v)+insertModifyingArr x f k0 ary0 = go k0 ary0 0 (A.length ary0)+  where+    go !k !ary !i !n+        | i >= n = A.run $ do+            -- Not found, append to the end.+            mary <- A.new_ (n + 1)+            A.copy ary 0 mary 0 n+            A.write mary n (L k x)+            return mary+        | otherwise = case A.index ary i of+            (L kx y) | k == kx   -> case f y of+                                      (# y' #) -> if ptrEq y y'+                                                  then ary+                                                  else A.update ary i (L k y')+                     | otherwise -> go k ary (i+1) n+{-# INLINE insertModifyingArr #-}++-- | In-place update version of insertWith+unsafeInsertWith :: forall k v. (Eq k, Hashable k)+                 => (v -> v -> v) -> k -> v -> HashMap k v+                 -> HashMap k v+unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0+{-# INLINABLE unsafeInsertWith #-}++unsafeInsertWithKey :: forall k v. (Eq k, Hashable k)+                 => (k -> v -> v -> v) -> k -> v -> HashMap k v+                 -> HashMap k v+unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0)+  where+    h0 = hash k0+    go :: Hash -> k -> v -> Shift -> HashMap k v -> ST s (HashMap k v)+    go !h !k x !_ Empty = return $! Leaf h (L k x)+    go h k x s t@(Leaf hy l@(L ky y))+        | hy == h = if ky == k+                    then return $! Leaf h (L k (f k x y))+                    else return $! collision h l (L k x)+        | otherwise = two s h k x hy t+    go h k x s t@(BitmapIndexed b ary)+        | b .&. m == 0 = do+            ary' <- A.insertM ary i $! Leaf h (L k x)+            return $! bitmapIndexedOrFull (b .|. m) ary'+        | otherwise = do+            st <- A.indexM ary i+            st' <- go h k x (s+bitsPerSubkey) st+            A.unsafeUpdateM ary i st'+            return t+      where m = mask h s+            i = sparseIndex b m+    go h k x s t@(Full ary) = do+        st <- A.indexM ary i+        st' <- go h k x (s+bitsPerSubkey) st+        A.unsafeUpdateM ary i st'+        return t+      where i = index h s+    go h k x s t@(Collision hy v)+        | h == hy   = return $! Collision h (updateOrSnocWithKey (\key a b -> (# f key a b #) ) k x v)+        | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE unsafeInsertWithKey #-}++-- | /O(log n)/ Remove the mapping for the specified key from this map+-- if present.+delete :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v+delete k m = delete' (hash k) k m+{-# INLINABLE delete #-}++delete' :: Eq k => Hash -> k -> HashMap k v -> HashMap k v+delete' h0 k0 m0 = go h0 k0 0 m0+  where+    go !_ !_ !_ Empty = Empty+    go h k _ t@(Leaf hy (L ky _))+        | hy == h && ky == k = Empty+        | otherwise          = t+    go h k s t@(BitmapIndexed b ary)+        | b .&. m == 0 = t+        | otherwise =+            let !st = A.index ary i+                !st' = go h k (s+bitsPerSubkey) st+            in if st' `ptrEq` st+                then t+                else case st' of+                Empty | A.length ary == 1 -> Empty+                      | A.length ary == 2 ->+                          case (i, A.index ary 0, A.index ary 1) of+                          (0, _, l) | isLeafOrCollision l -> l+                          (1, l, _) | isLeafOrCollision l -> l+                          _                               -> bIndexed+                      | otherwise -> bIndexed+                    where+                      bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i)+                l | isLeafOrCollision l && A.length ary == 1 -> l+                _ -> BitmapIndexed b (A.update ary i st')+      where m = mask h s+            i = sparseIndex b m+    go h k s t@(Full ary) =+        let !st   = A.index ary i+            !st' = go h k (s+bitsPerSubkey) st+        in if st' `ptrEq` st+            then t+            else case st' of+            Empty ->+                let ary' = A.delete ary i+                    bm   = fullNodeMask .&. complement (1 `unsafeShiftL` i)+                in BitmapIndexed bm ary'+            _ -> Full (A.update ary i st')+      where i = index h s+    go h k _ t@(Collision hy v)+        | h == hy = case indexOf k v of+            Just i+                | A.length v == 2 ->+                    if i == 0+                    then Leaf h (A.index v 1)+                    else Leaf h (A.index v 0)+                | otherwise -> Collision h (A.delete v i)+            Nothing -> t+        | otherwise = t+{-# INLINABLE delete' #-}++-- | Delete optimized for the case when we know the key is in the map.+--+-- It is only valid to call this when the key exists in the map and you know the+-- hash collision position if there was one. This information can be obtained+-- from 'lookupRecordCollision'. If there is no collision pass (-1) as collPos.+--+-- We can skip:+--  - the key equality check on the leaf, if we reach a leaf it must be the key+deleteKeyExists :: Int -> Hash -> k -> HashMap k v -> HashMap k v+deleteKeyExists !collPos0 !h0 !k0 !m0 = go collPos0 h0 k0 0 m0+  where+    go :: Int -> Hash -> k -> Int -> HashMap k v -> HashMap k v+    go !_collPos !_h !_k !_s (Leaf _ _) = Empty+    go collPos h k s (BitmapIndexed b ary) =+            let !st = A.index ary i+                !st' = go collPos h k (s+bitsPerSubkey) st+            in case st' of+                Empty | A.length ary == 1 -> Empty+                      | A.length ary == 2 ->+                          case (i, A.index ary 0, A.index ary 1) of+                          (0, _, l) | isLeafOrCollision l -> l+                          (1, l, _) | isLeafOrCollision l -> l+                          _                               -> bIndexed+                      | otherwise -> bIndexed+                    where+                      bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i)+                l | isLeafOrCollision l && A.length ary == 1 -> l+                _ -> BitmapIndexed b (A.update ary i st')+      where m = mask h s+            i = sparseIndex b m+    go collPos h k s (Full ary) =+        let !st   = A.index ary i+            !st' = go collPos h k (s+bitsPerSubkey) st+        in case st' of+            Empty ->+                let ary' = A.delete ary i+                    bm   = fullNodeMask .&. complement (1 `unsafeShiftL` i)+                in BitmapIndexed bm ary'+            _ -> Full (A.update ary i st')+      where i = index h s+    go collPos h _ _ (Collision _hy v)+      | A.length v == 2+      = if collPos == 0+        then Leaf h (A.index v 1)+        else Leaf h (A.index v 0)+      | otherwise = Collision h (A.delete v collPos)+    go !_ !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty"+{-# NOINLINE deleteKeyExists #-}++-- | /O(log n)/ Adjust the value tied to a given key in this map only+-- if it is present. Otherwise, leave the map alone.+adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v+-- This operation really likes to leak memory, so using this+-- indirect implementation shouldn't hurt much. Furthermore, it allows+-- GHC to avoid a leak when the function is lazy. In particular,+--+--     adjust (const x) k m+-- ==> adjust# (\v -> (# const x v #)) k m+-- ==> adjust# (\_ -> (# x #)) k m+adjust f k m = adjust# (\v -> (# f v #)) k m+{-# INLINE adjust #-}++-- | Much like 'adjust', but not inherently leaky.+adjust# :: (Eq k, Hashable k) => (v -> (# v #)) -> k -> HashMap k v -> HashMap k v+adjust# f k0 m0 = go h0 k0 0 m0+  where+    h0 = hash k0+    go !_ !_ !_ Empty = Empty+    go h k _ t@(Leaf hy (L ky y))+        | hy == h && ky == k = case f y of+            (# y' #) | ptrEq y y' -> t+                     | otherwise -> Leaf h (L k y')+        | otherwise          = t+    go h k s t@(BitmapIndexed b ary)+        | b .&. m == 0 = t+        | otherwise = let !st   = A.index ary i+                          !st'  = go h k (s+bitsPerSubkey) st+                          ary' = A.update ary i $! st'+                      in if ptrEq st st'+                         then t+                         else BitmapIndexed b ary'+      where m = mask h s+            i = sparseIndex b m+    go h k s t@(Full ary) =+        let i    = index h s+            !st   = A.index ary i+            !st'  = go h k (s+bitsPerSubkey) st+            ary' = update16 ary i $! st'+        in if ptrEq st st'+           then t+           else Full ary'+    go h k _ t@(Collision hy v)+        | h == hy   = let !v' = updateWith# f k v+                      in if A.unsafeSameArray v v'+                         then t+                         else Collision h v'+        | otherwise = t+{-# INLINABLE adjust# #-}++-- | /O(log n)/  The expression @('update' f k map)@ updates the value @x@ at @k@+-- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted.+-- If it is @('Just' y)@, the key @k@ is bound to the new value @y@.+update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a+update f = alter (>>= f)+{-# INLINABLE update #-}+++-- | /O(log n)/  The expression @('alter' f k map)@ alters the value @x@ at @k@, or+-- absence thereof.+--+-- 'alter' can be used to insert, delete, or update a value in a map. In short:+--+-- @+-- 'lookup' k ('alter' f k m) = f ('lookup' k m)+-- @+alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v+-- TODO(m-renaud): Consider using specialized insert and delete for alter.+alter f k m =+  case f (lookup k m) of+    Nothing -> delete k m+    Just v  -> insert k v m+{-# INLINABLE alter #-}++-- | /O(log n)/  The expression @('alterF' f k map)@ alters the value @x@ at+-- @k@, or absence thereof.+--+--  'alterF' can be used to insert, delete, or update a value in a map.+--+-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- <https://hackage.haskell.org/package/lens/docs/Control-Lens-At.html#v:at Control.Lens.At>.+--+-- @since 0.2.10+alterF :: (Functor f, Eq k, Hashable k)+       => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+-- We only calculate the hash once, but unless this is rewritten+-- by rules we may test for key equality multiple times.+-- We force the value of the map for consistency with the rewritten+-- version; otherwise someone could tell the difference using a lazy+-- @f@ and a functor that is similar to Const but not actually Const.+alterF f = \ !k !m ->+  let+    !h = hash k+    mv = lookup' h k m+  in (<$> f mv) $ \fres ->+    case fres of+      Nothing -> maybe m (const (delete' h k m)) mv+      Just v' -> insert' h k v' m++-- We unconditionally rewrite alterF in RULES, but we expose an+-- unfolding just in case it's used in some way that prevents the+-- rule from firing.+{-# INLINABLE [0] alterF #-}++#if MIN_VERSION_base(4,8,0)+-- This is just a bottom value. See the comment on the "alterFWeird"+-- rule.+test_bottom :: a+test_bottom = error "Data.Strict.HashMap.Autogen.alterF internal error: hit test_bottom"++-- We use this as an error result in RULES to ensure we don't get+-- any useless CallStack nonsense.+bogus# :: (# #) -> (# a #)+bogus# _ = error "Data.Strict.HashMap.Autogen.alterF internal error: hit bogus#"++{-# RULES+-- We probe the behavior of @f@ by applying it to Nothing and to+-- Just test_bottom. Based on the results, and how they relate to+-- each other, we choose the best implementation.++"alterFWeird" forall f. alterF f =+   alterFWeird (f Nothing) (f (Just test_bottom)) f++-- This rule covers situations where alterF is used to simply insert or+-- delete in Identity (most likely via Control.Lens.At). We recognize here+-- (through the repeated @x@ on the LHS) that+--+-- @f Nothing = f (Just bottom)@,+--+-- which guarantees that @f@ doesn't care what its argument is, so+-- we don't have to either.+--+-- Why only Identity? A variant of this rule is actually valid regardless of+-- the functor, but for some functors (e.g., []), it can lead to the+-- same keys being compared multiple times, which is bad if they're+-- ugly things like strings. This is unfortunate, since the rule is likely+-- a good idea for almost all realistic uses, but I don't like nasty+-- edge cases.+"alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x.+  alterFWeird x x f = \ !k !m ->+    Identity (case runIdentity x of {Nothing -> delete k m; Just a -> insert k a m})++-- This rule handles the case where 'alterF' is used to do 'insertWith'-like+-- things. Whenever possible, GHC will get rid of the Maybe nonsense for us.+-- We delay this rule to stage 1 so alterFconstant has a chance to fire.+"alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y.+  alterFWeird (coerce (Just x)) (coerce (Just y)) f =+    coerce (insertModifying x (\mold -> case runIdentity (f (Just mold)) of+                                            Nothing -> bogus# (# #)+                                            Just new -> (# new #)))++-- Handle the case where someone uses 'alterF' instead of 'adjust'. This+-- rule is kind of picky; it will only work if the function doesn't+-- do anything between case matching on the Maybe and producing a result.+"alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) _y.+  alterFWeird (coerce Nothing) (coerce (Just _y)) f =+    coerce (adjust# (\x -> case runIdentity (f (Just x)) of+                               Just x' -> (# x' #)+                               Nothing -> bogus# (# #)))++-- The simple specialization to Const; in this case we can look up+-- the key without caring what position it's in. This is only a tiny+-- optimization.+"alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)).+  alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (lookup k m)))+ #-}++-- This is a very unsafe version of alterF used for RULES. When calling+-- alterFWeird x y f, the following *must* hold:+--+-- x = f Nothing+-- y = f (Just _|_)+--+-- Failure to abide by these laws will make demons come out of your nose.+alterFWeird+       :: (Functor f, Eq k, Hashable k)+       => f (Maybe v)+       -> f (Maybe v)+       -> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFWeird _ _ f = alterFEager f+{-# INLINE [0] alterFWeird #-}++-- | This is the default version of alterF that we use in most non-trivial+-- cases. It's called "eager" because it looks up the given key in the map+-- eagerly, whether or not the given function requires that information.+alterFEager :: (Functor f, Eq k, Hashable k)+       => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFEager f !k m = (<$> f mv) $ \fres ->+  case fres of++    ------------------------------+    -- Delete the key from the map.+    Nothing -> case lookupRes of++      -- Key did not exist in the map to begin with, no-op+      Absent -> m++      -- Key did exist+      Present _ collPos -> deleteKeyExists collPos h k m++    ------------------------------+    -- Update value+    Just v' -> case lookupRes of++      -- Key did not exist before, insert v' under a new key+      Absent -> insertNewKey h k v' m++      -- Key existed before+      Present v collPos ->+        if v `ptrEq` v'+        -- If the value is identical, no-op+        then m+        -- If the value changed, update the value.+        else insertKeyExists collPos h k v' m++  where !h = hash k+        !lookupRes = lookupRecordCollision h k m+        !mv = case lookupRes of+           Absent -> Nothing+           Present v _ -> Just v+{-# INLINABLE alterFEager #-}+#endif++-- | /O(n*log m)/ Inclusion of maps. A map is included in another map if the keys+-- are subsets and the corresponding values are equal:+--+-- > isSubmapOf m1 m2 = keys m1 `isSubsetOf` keys m2 &&+-- >                    and [ v1 == v2 | (k1,v1) <- toList m1; let v2 = m2 ! k1 ]+--+-- ==== __Examples__+--+-- >>> fromList [(1,'a')] `isSubmapOf` fromList [(1,'a'),(2,'b')]+-- True+--+-- >>> fromList [(1,'a'),(2,'b')] `isSubmapOf` fromList [(1,'a')]+-- False+--+-- @since 0.2.12+isSubmapOf :: (Eq k, Hashable k, Eq v) => HashMap k v -> HashMap k v -> Bool+isSubmapOf = (inline isSubmapOfBy) (==)+{-# INLINABLE isSubmapOf #-}++-- | /O(n*log m)/ Inclusion of maps with value comparison. A map is included in+-- another map if the keys are subsets and if the comparison function is true+-- for the corresponding values:+--+-- > isSubmapOfBy cmpV m1 m2 = keys m1 `isSubsetOf` keys m2 &&+-- >                           and [ v1 `cmpV` v2 | (k1,v1) <- toList m1; let v2 = m2 ! k1 ]+--+-- ==== __Examples__+--+-- >>> isSubmapOfBy (<=) (fromList [(1,'a')]) (fromList [(1,'b'),(2,'c')])+-- True+--+-- >>> isSubmapOfBy (<=) (fromList [(1,'b')]) (fromList [(1,'a'),(2,'c')])+-- False+--+-- @since 0.2.12+isSubmapOfBy :: (Eq k, Hashable k) => (v1 -> v2 -> Bool) -> HashMap k v1 -> HashMap k v2 -> Bool+-- For maps without collisions the complexity is O(n*log m), where n is the size+-- of m1 and m the size of m2: the inclusion operation visits every leaf in m1 at least once.+-- For each leaf in m1, it looks up the key in m2.+--+-- The worst case complexity is O(n*m). The worst case is when both hashmaps m1+-- and m2 are collision nodes for the same hash. Since collision nodes are+-- unsorted arrays, it requires for every key in m1 a linear search to to find a+-- matching key in m2, hence O(n*m).+isSubmapOfBy comp !m1 !m2 = go 0 m1 m2+  where+    -- An empty map is always a submap of any other map.+    go _ Empty _ = True++    -- If the second map is empty and the first is not, it cannot be a submap.+    go _ _ Empty = False++    -- If the first map contains only one entry, lookup the key in the second map.+    go s (Leaf h1 (L k1 v1)) t2 = lookupCont (\_ -> False) (\v2 _ -> comp v1 v2) h1 k1 s t2++    -- In this case, we need to check that for each x in ls1, there is a y in+    -- ls2 such that x `comp` y. This is the worst case complexity-wise since it+    -- requires a O(m*n) check.+    go _ (Collision h1 ls1) (Collision h2 ls2) =+      h1 == h2 && subsetArray comp ls1 ls2++    -- In this case, we only need to check the entries in ls2 with the hash h1.+    go s t1@(Collision h1 _) (BitmapIndexed b ls2)+        | b .&. m == 0 = False+        | otherwise    =+            go (s+bitsPerSubkey) t1 (A.index ls2 (sparseIndex b m))+      where m = mask h1 s++    -- Similar to the previous case we need to traverse l2 at the index for the hash h1.+    go s t1@(Collision h1 _) (Full ls2) =+      go (s+bitsPerSubkey) t1 (A.index ls2 (index h1 s))++    -- In cases where the first and second map are BitmapIndexed or Full,+    -- traverse down the tree at the appropriate indices.+    go s (BitmapIndexed b1 ls1) (BitmapIndexed b2 ls2) =+      submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 b2 ls2+    go s (BitmapIndexed b1 ls1) (Full ls2) =+      submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 fullNodeMask ls2+    go s (Full ls1) (Full ls2) =+      submapBitmapIndexed (go (s+bitsPerSubkey)) fullNodeMask ls1 fullNodeMask ls2++    -- Collision and Full nodes always contain at least two entries. Hence it+    -- cannot be a map of a leaf.+    go _ (Collision {}) (Leaf {}) = False+    go _ (BitmapIndexed {}) (Leaf {}) = False+    go _ (Full {}) (Leaf {}) = False+    go _ (BitmapIndexed {}) (Collision {}) = False+    go _ (Full {}) (Collision {}) = False+    go _ (Full {}) (BitmapIndexed {}) = False+{-# INLINABLE isSubmapOfBy #-}++-- | /O(min n m))/ Checks if a bitmap indexed node is a submap of another.+submapBitmapIndexed :: (HashMap k v1 -> HashMap k v2 -> Bool) -> Bitmap -> A.Array (HashMap k v1) -> Bitmap -> A.Array (HashMap k v2) -> Bool+submapBitmapIndexed comp !b1 !ary1 !b2 !ary2 = subsetBitmaps && go 0 0 (b1Orb2 .&. negate b1Orb2)+  where+    go :: Int -> Int -> Bitmap -> Bool+    go !i !j !m+      | m > b1Orb2 = True++      -- In case a key is both in ary1 and ary2, check ary1[i] <= ary2[j] and+      -- increment the indices i and j.+      | b1Andb2 .&. m /= 0 = comp (A.index ary1 i) (A.index ary2 j) &&+                             go (i+1) (j+1) (m `unsafeShiftL` 1)++      -- In case a key occurs in ary1, but not ary2, only increment index j.+      | b2 .&. m /= 0 = go i (j+1) (m `unsafeShiftL` 1)++      -- In case a key neither occurs in ary1 nor ary2, continue.+      | otherwise = go i j (m `unsafeShiftL` 1)++    b1Andb2 = b1 .&. b2+    b1Orb2  = b1 .|. b2+    subsetBitmaps = b1Orb2 == b2+{-# INLINABLE submapBitmapIndexed #-}++------------------------------------------------------------------------+-- * Combine++-- | /O(n+m)/ The union of two maps. If a key occurs in both maps, the+-- mapping from the first will be the mapping in the result.+--+-- ==== __Examples__+--+-- >>> union (fromList [(1,'a'),(2,'b')]) (fromList [(2,'c'),(3,'d')])+-- fromList [(1,'a'),(2,'b'),(3,'d')]+union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v+union = unionWith const+{-# INLINABLE union #-}++-- | /O(n+m)/ The union of two maps.  If a key occurs in both maps,+-- the provided function (first argument) will be used to compute the+-- result.+unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v+          -> HashMap k v+unionWith f = unionWithKey (const f)+{-# INLINE unionWith #-}++-- | /O(n+m)/ The union of two maps.  If a key occurs in both maps,+-- the provided function (first argument) will be used to compute the+-- result.+unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v+          -> HashMap k v+unionWithKey f = go 0+  where+    -- empty vs. anything+    go !_ t1 Empty = t1+    go _ Empty t2 = t2+    -- leaf vs. leaf+    go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2))+        | h1 == h2  = if k1 == k2+                      then Leaf h1 (L k1 (f k1 v1 v2))+                      else collision h1 l1 l2+        | otherwise = goDifferentHash s h1 h2 t1 t2+    go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2)+        | h1 == h2  = Collision h1 (updateOrSnocWithKey (\k a b -> (# f k a b #)) k1 v1 ls2)+        | otherwise = goDifferentHash s h1 h2 t1 t2+    go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2))+        | h1 == h2  = Collision h1 (updateOrSnocWithKey (\k a b -> (# f k b a #)) k2 v2 ls1)+        | otherwise = goDifferentHash s h1 h2 t1 t2+    go s t1@(Collision h1 ls1) t2@(Collision h2 ls2)+        | h1 == h2  = Collision h1 (updateOrConcatWithKey f ls1 ls2)+        | otherwise = goDifferentHash s h1 h2 t1 t2+    -- branch vs. branch+    go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =+        let b'   = b1 .|. b2+            ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2+        in bitmapIndexedOrFull b' ary'+    go s (BitmapIndexed b1 ary1) (Full ary2) =+        let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2+        in Full ary'+    go s (Full ary1) (BitmapIndexed b2 ary2) =+        let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2+        in Full ary'+    go s (Full ary1) (Full ary2) =+        let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask+                   ary1 ary2+        in Full ary'+    -- leaf vs. branch+    go s (BitmapIndexed b1 ary1) t2+        | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2+                               b'   = b1 .|. m2+                           in bitmapIndexedOrFull b' ary'+        | otherwise      = let ary' = A.updateWith' ary1 i $ \st1 ->+                                   go (s+bitsPerSubkey) st1 t2+                           in BitmapIndexed b1 ary'+        where+          h2 = leafHashCode t2+          m2 = mask h2 s+          i = sparseIndex b1 m2+    go s t1 (BitmapIndexed b2 ary2)+        | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1+                               b'   = b2 .|. m1+                           in bitmapIndexedOrFull b' ary'+        | otherwise      = let ary' = A.updateWith' ary2 i $ \st2 ->+                                   go (s+bitsPerSubkey) t1 st2+                           in BitmapIndexed b2 ary'+      where+        h1 = leafHashCode t1+        m1 = mask h1 s+        i = sparseIndex b2 m1+    go s (Full ary1) t2 =+        let h2   = leafHashCode t2+            i    = index h2 s+            ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2+        in Full ary'+    go s t1 (Full ary2) =+        let h1   = leafHashCode t1+            i    = index h1 s+            ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2+        in Full ary'++    leafHashCode (Leaf h _) = h+    leafHashCode (Collision h _) = h+    leafHashCode _ = error "leafHashCode"++    goDifferentHash s h1 h2 t1 t2+        | m1 == m2  = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2)+        | m1 <  m2  = BitmapIndexed (m1 .|. m2) (A.pair t1 t2)+        | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1)+      where+        m1 = mask h1 s+        m2 = mask h2 s+{-# INLINE unionWithKey #-}++-- | Strict in the result of @f@.+unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a+             -> A.Array a+unionArrayBy f b1 b2 ary1 ary2 = A.run $ do+    let b' = b1 .|. b2+    mary <- A.new_ (popCount b')+    -- iterate over nonzero bits of b1 .|. b2+    -- it would be nice if we could shift m by more than 1 each time+    let ba = b1 .&. b2+        go !i !i1 !i2 !m+            | m > b'        = return ()+            | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1)+            | ba .&. m /= 0 = do+                x1 <- A.indexM ary1 i1+                x2 <- A.indexM ary2 i2+                A.write mary i $! f x1 x2+                go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1)+            | b1 .&. m /= 0 = do+                A.write mary i =<< A.indexM ary1 i1+                go (i+1) (i1+1) (i2  ) (m `unsafeShiftL` 1)+            | otherwise     = do+                A.write mary i =<< A.indexM ary2 i2+                go (i+1) (i1  ) (i2+1) (m `unsafeShiftL` 1)+    go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero+    return mary+    -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a+    -- subset of the other, we could use a slightly simpler algorithm,+    -- where we copy one array, and then update.+{-# INLINE unionArrayBy #-}++-- TODO: Figure out the time complexity of 'unions'.++-- | Construct a set containing all elements from a list of sets.+unions :: (Eq k, Hashable k) => [HashMap k v] -> HashMap k v+unions = L.foldl' union empty+{-# INLINE unions #-}+++------------------------------------------------------------------------+-- * Compose++-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O (n * \log(m)) \), where \(m\) is the size of the first argument+--+-- >>> compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')])+-- fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- @since UNRELEASED+compose :: (Eq b, Hashable b) => HashMap b c -> HashMap a b -> HashMap a c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++------------------------------------------------------------------------+-- * Transformations++-- | /O(n)/ Transform this map by applying a function to every value.+mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2+mapWithKey f = go+  where+    go Empty = Empty+    go (Leaf h (L k v)) = Leaf h $ L k (f k v)+    go (BitmapIndexed b ary) = BitmapIndexed b $ A.map go ary+    go (Full ary) = Full $ A.map go ary+    -- Why map strictly over collision arrays? Because there's no+    -- point suspending the O(1) work this does for each leaf.+    go (Collision h ary) = Collision h $+                           A.map' (\ (L k v) -> L k (f k v)) ary+{-# INLINE mapWithKey #-}++-- | /O(n)/ Transform this map by applying a function to every value.+map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = mapWithKey (const f)+{-# INLINE map #-}++-- TODO: We should be able to use mutation to create the new+-- 'HashMap'.++-- | /O(n)/ Perform an 'Applicative' action for each key-value pair+-- in a 'HashMap' and produce a 'HashMap' of all the results.+--+-- Note: the order in which the actions occur is unspecified. In particular,+-- when the map contains hash collisions, the order in which the actions+-- associated with the keys involved will depend in an unspecified way on+-- their insertion order.+traverseWithKey+  :: Applicative f+  => (k -> v1 -> f v2)+  -> HashMap k v1 -> f (HashMap k v2)+traverseWithKey f = go+  where+    go Empty                 = pure Empty+    go (Leaf h (L k v))      = Leaf h . L k <$> f k v+    go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse go ary+    go (Full ary)            = Full <$> A.traverse go ary+    go (Collision h ary)     =+        Collision h <$> A.traverse' (\ (L k v) -> L k <$> f k v) ary+{-# INLINE traverseWithKey #-}++------------------------------------------------------------------------+-- * Difference and intersection++-- | /O(n*log m)/ Difference of two maps. Return elements of the first map+-- not existing in the second.+difference :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v+difference a b = foldlWithKey' go empty a+  where+    go m k v = case lookup k b of+                 Nothing -> insert k v m+                 _       -> m+{-# INLINABLE difference #-}++-- | /O(n*log m)/ Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+differenceWith :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v+differenceWith f a b = foldlWithKey' go empty a+  where+    go m k v = case lookup k b of+                 Nothing -> insert k v m+                 Just w  -> maybe m (\y -> insert k y m) (f v w)+{-# INLINABLE differenceWith #-}++-- | /O(n*log m)/ Intersection of two maps. Return elements of the first+-- map for keys existing in the second.+intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v+intersection a b = foldlWithKey' go empty a+  where+    go m k v = case lookup k b of+                 Just _ -> insert k v m+                 _      -> m+{-# INLINABLE intersection #-}++-- | /O(n*log m)/ Intersection of two maps. If a key occurs in both maps+-- the provided function is used to combine the values from the two+-- maps.+intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1+                 -> HashMap k v2 -> HashMap k v3+intersectionWith f a b = foldlWithKey' go empty a+  where+    go m k v = case lookup k b of+                 Just w -> insert k (f v w) m+                 _      -> m+{-# INLINABLE intersectionWith #-}++-- | /O(n*log m)/ Intersection of two maps. If a key occurs in both maps+-- the provided function is used to combine the values from the two+-- maps.+intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3)+                    -> HashMap k v1 -> HashMap k v2 -> HashMap k v3+intersectionWithKey f a b = foldlWithKey' go empty a+  where+    go m k v = case lookup k b of+                 Just w -> insert k (f k v w) m+                 _      -> m+{-# INLINABLE intersectionWithKey #-}++------------------------------------------------------------------------+-- * Folds++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).  Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldl' :: (a -> v -> a) -> a -> HashMap k v -> a+foldl' f = foldlWithKey' (\ z _ v -> f z v)+{-# INLINE foldl' #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).  Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldr' :: (v -> a -> a) -> a -> HashMap k v -> a+foldr' f = foldrWithKey' (\ _ v z -> f v z)+{-# INLINE foldr' #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).  Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a+foldlWithKey' f = go+  where+    go !z Empty                = z+    go z (Leaf _ (L k v))      = f z k v+    go z (BitmapIndexed _ ary) = A.foldl' go z ary+    go z (Full ary)            = A.foldl' go z ary+    go z (Collision _ ary)     = A.foldl' (\ z' (L k v) -> f z' k v) z ary+{-# INLINE foldlWithKey' #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).  Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldrWithKey' :: (k -> v -> a -> a) -> a -> HashMap k v -> a+foldrWithKey' f = flip go+  where+    go Empty z                 = z+    go (Leaf _ (L k v)) !z     = f k v z+    go (BitmapIndexed _ ary) !z = A.foldr' go z ary+    go (Full ary) !z           = A.foldr' go z ary+    go (Collision _ ary) !z    = A.foldr' (\ (L k v) z' -> f k v z') z ary+{-# INLINE foldrWithKey' #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).+foldr :: (v -> a -> a) -> a -> HashMap k v -> a+foldr f = foldrWithKey (const f)+{-# INLINE foldr #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).+foldl :: (a -> v -> a) -> a -> HashMap k v -> a+foldl f = foldlWithKey (\a _k v -> f a v)+{-# INLINE foldl #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).+foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a+foldrWithKey f = flip go+  where+    go Empty z                 = z+    go (Leaf _ (L k v)) z      = f k v z+    go (BitmapIndexed _ ary) z = A.foldr go z ary+    go (Full ary) z            = A.foldr go z ary+    go (Collision _ ary) z     = A.foldr (\ (L k v) z' -> f k v z') z ary+{-# INLINE foldrWithKey #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).+foldlWithKey :: (a -> k -> v -> a) -> a -> HashMap k v -> a+foldlWithKey f = go+  where+    go z Empty                 = z+    go z (Leaf _ (L k v))      = f z k v+    go z (BitmapIndexed _ ary) = A.foldl go z ary+    go z (Full ary)            = A.foldl go z ary+    go z (Collision _ ary)     = A.foldl (\ z' (L k v) -> f z' k v) z ary+{-# INLINE foldlWithKey #-}++-- | /O(n)/ Reduce the map by applying a function to each element+-- and combining the results with a monoid operation.+foldMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m+foldMapWithKey f = go+  where+    go Empty = mempty+    go (Leaf _ (L k v)) = f k v+    go (BitmapIndexed _ ary) = A.foldMap go ary+    go (Full ary) = A.foldMap go ary+    go (Collision _ ary) = A.foldMap (\ (L k v) -> f k v) ary+{-# INLINE foldMapWithKey #-}++------------------------------------------------------------------------+-- * Filter++-- | /O(n)/ Transform this map by applying a function to every value+--   and retaining only some of them.+mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybeWithKey f = filterMapAux onLeaf onColl+  where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (Leaf h (L k v'))+        onLeaf _ = Nothing++        onColl (L k v) | Just v' <- f k v = Just (L k v')+                       | otherwise = Nothing+{-# INLINE mapMaybeWithKey #-}++-- | /O(n)/ Transform this map by applying a function to every value+--   and retaining only some of them.+mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybe f = mapMaybeWithKey (const f)+{-# INLINE mapMaybe #-}++-- | /O(n)/ Filter this map by retaining only elements satisfying a+-- predicate.+filterWithKey :: forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v+filterWithKey pred = filterMapAux onLeaf onColl+  where onLeaf t@(Leaf _ (L k v)) | pred k v = Just t+        onLeaf _ = Nothing++        onColl el@(L k v) | pred k v = Just el+        onColl _ = Nothing+{-# INLINE filterWithKey #-}+++-- | Common implementation for 'filterWithKey' and 'mapMaybeWithKey',+--   allowing the former to former to reuse terms.+filterMapAux :: forall k v1 v2+              . (HashMap k v1 -> Maybe (HashMap k v2))+             -> (Leaf k v1 -> Maybe (Leaf k v2))+             -> HashMap k v1+             -> HashMap k v2+filterMapAux onLeaf onColl = go+  where+    go Empty = Empty+    go t@Leaf{}+        | Just t' <- onLeaf t = t'+        | otherwise = Empty+    go (BitmapIndexed b ary) = filterA ary b+    go (Full ary) = filterA ary fullNodeMask+    go (Collision h ary) = filterC ary h++    filterA ary0 b0 =+        let !n = A.length ary0+        in runST $ do+            mary <- A.new_ n+            step ary0 mary b0 0 0 1 n+      where+        step :: A.Array (HashMap k v1) -> A.MArray s (HashMap k v2)+             -> Bitmap -> Int -> Int -> Bitmap -> Int+             -> ST s (HashMap k v2)+        step !ary !mary !b i !j !bi n+            | i >= n = case j of+                0 -> return Empty+                1 -> do+                    ch <- A.read mary 0+                    case ch of+                      t | isLeafOrCollision t -> return t+                      _                       -> BitmapIndexed b <$> A.trim mary 1+                _ -> do+                    ary2 <- A.trim mary j+                    return $! if j == maxChildren+                              then Full ary2+                              else BitmapIndexed b ary2+            | bi .&. b == 0 = step ary mary b i j (bi `unsafeShiftL` 1) n+            | otherwise = case go (A.index ary i) of+                Empty -> step ary mary (b .&. complement bi) (i+1) j+                         (bi `unsafeShiftL` 1) n+                t     -> do A.write mary j t+                            step ary mary b (i+1) (j+1) (bi `unsafeShiftL` 1) n++    filterC ary0 h =+        let !n = A.length ary0+        in runST $ do+            mary <- A.new_ n+            step ary0 mary 0 0 n+      where+        step :: A.Array (Leaf k v1) -> A.MArray s (Leaf k v2)+             -> Int -> Int -> Int+             -> ST s (HashMap k v2)+        step !ary !mary i !j n+            | i >= n    = case j of+                0 -> return Empty+                1 -> do l <- A.read mary 0+                        return $! Leaf h l+                _ | i == j -> do ary2 <- A.unsafeFreeze mary+                                 return $! Collision h ary2+                  | otherwise -> do ary2 <- A.trim mary j+                                    return $! Collision h ary2+            | Just el <- onColl $! A.index ary i+                = A.write mary j el >> step ary mary (i+1) (j+1) n+            | otherwise = step ary mary (i+1) j n+{-# INLINE filterMapAux #-}++-- | /O(n)/ Filter this map by retaining only elements which values+-- satisfy a predicate.+filter :: (v -> Bool) -> HashMap k v -> HashMap k v+filter p = filterWithKey (\_ v -> p v)+{-# INLINE filter #-}++------------------------------------------------------------------------+-- * Conversions++-- TODO: Improve fusion rules by modelled them after the Prelude ones+-- on lists.++-- | /O(n)/ Return a list of this map's keys.  The list is produced+-- lazily.+keys :: HashMap k v -> [k]+keys = L.map fst . toList+{-# INLINE keys #-}++-- | /O(n)/ Return a list of this map's values.  The list is produced+-- lazily.+elems :: HashMap k v -> [v]+elems = L.map snd . toList+{-# INLINE elems #-}++------------------------------------------------------------------------+-- ** Lists++-- | /O(n)/ Return a list of this map's elements.  The list is+-- produced lazily. The order of its elements is unspecified.+toList :: HashMap k v -> [(k, v)]+toList t = build (\ c z -> foldrWithKey (curry c) z t)+{-# INLINE toList #-}++-- | /O(n)/ Construct a map with the supplied mappings.  If the list+-- contains duplicate mappings, the later mappings take precedence.+fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v+fromList = L.foldl' (\ m (k, v) -> unsafeInsert k v m) empty+{-# INLINABLE fromList #-}++-- | /O(n*log n)/ Construct a map from a list of elements.  Uses+-- the provided function @f@ to merge duplicate entries with+-- @(f newVal oldVal)@.+--+-- === Examples+--+-- Given a list @xs@, create a map with the number of occurrences of each+-- element in @xs@:+--+-- > let xs = ['a', 'b', 'a']+-- > in fromListWith (+) [ (x, 1) | x <- xs ]+-- >+-- > = fromList [('a', 2), ('b', 1)]+--+-- Given a list of key-value pairs @xs :: [(k, v)]@, group all values by their+-- keys and return a @HashMap k [v]@.+--+-- > let xs = [('a', 1), ('b', 2), ('a', 3)]+-- > in fromListWith (++) [ (k, [v]) | (k, v) <- xs ]+-- >+-- > = fromList [('a', [3, 1]), ('b', [2])]+--+-- Note that the lists in the resulting map contain elements in reverse order+-- from their occurences in the original list.+--+-- More generally, duplicate entries are accumulated as follows;+-- this matters when @f@ is not commutative or not associative.+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f d (f c (f b a)))]+fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty+{-# INLINE fromListWith #-}++-- | /O(n*log n)/ Construct a map from a list of elements.  Uses+-- the provided function to merge duplicate entries.+--+-- === Examples+--+-- Given a list of key-value pairs where the keys are of different flavours, e.g:+--+-- > data Key = Div | Sub+--+-- and the values need to be combined differently when there are duplicates,+-- depending on the key:+--+-- > combine Div = div+-- > combine Sub = (-)+--+-- then @fromListWithKey@ can be used as follows:+--+-- > fromListWithKey combine [(Div, 2), (Div, 6), (Sub, 2), (Sub, 3)]+-- > = fromList [(Div, 3), (Sub, 1)]+--+-- More generally, duplicate entries are accumulated as follows;+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f k d (f k c (f k b a)))]+--+-- @since 0.2.11+fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty+{-# INLINE fromListWithKey #-}++------------------------------------------------------------------------+-- Array operations++-- | /O(n)/ Look up the value associated with the given key in an+-- array.+lookupInArrayCont ::+#if __GLASGOW_HASKELL__ >= 802+  forall rep (r :: TYPE rep) k v.+#else+  forall r k v.+#endif+  Eq k => ((# #) -> r) -> (v -> Int -> r) -> k -> A.Array (Leaf k v) -> r+lookupInArrayCont absent present k0 ary0 = go k0 ary0 0 (A.length ary0)+  where+    go :: Eq k => k -> A.Array (Leaf k v) -> Int -> Int -> r+    go !k !ary !i !n+        | i >= n    = absent (# #)+        | otherwise = case A.index ary i of+            (L kx v)+                | k == kx   -> present v i+                | otherwise -> go k ary (i+1) n+{-# INLINE lookupInArrayCont #-}++-- | /O(n)/ Lookup the value associated with the given key in this+-- array.  Returns 'Nothing' if the key wasn't found.+indexOf :: Eq k => k -> A.Array (Leaf k v) -> Maybe Int+indexOf k0 ary0 = go k0 ary0 0 (A.length ary0)+  where+    go !k !ary !i !n+        | i >= n    = Nothing+        | otherwise = case A.index ary i of+            (L kx _)+                | k == kx   -> Just i+                | otherwise -> go k ary (i+1) n+{-# INLINABLE indexOf #-}++updateWith# :: Eq k => (v -> (# v #)) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateWith# f k0 ary0 = go k0 ary0 0 (A.length ary0)+  where+    go !k !ary !i !n+        | i >= n    = ary+        | otherwise = case A.index ary i of+            (L kx y) | k == kx -> case f y of+                          (# y' #)+                             | ptrEq y y' -> ary+                             | otherwise -> A.update ary i (L k y')+                     | otherwise -> go k ary (i+1) n+{-# INLINABLE updateWith# #-}++updateOrSnocWith :: Eq k => (v -> v -> (# v #)) -> k -> v -> A.Array (Leaf k v)+                 -> A.Array (Leaf k v)+updateOrSnocWith f = updateOrSnocWithKey (const f)+{-# INLINABLE updateOrSnocWith #-}++updateOrSnocWithKey :: Eq k => (k -> v -> v -> (# v #)) -> k -> v -> A.Array (Leaf k v)+                 -> A.Array (Leaf k v)+updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0)+  where+    go !k v !ary !i !n+        | i >= n = A.run $ do+            -- Not found, append to the end.+            mary <- A.new_ (n + 1)+            A.copy ary 0 mary 0 n+            A.write mary n (L k v)+            return mary+        | L kx y <- A.index ary i+        , k == kx+        , (# v2 #) <- f k v y+            = A.update ary i (L k v2)+        | otherwise+            = go k v ary (i+1) n+{-# INLINABLE updateOrSnocWithKey #-}++updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateOrConcatWith f = updateOrConcatWithKey (const f)+{-# INLINABLE updateOrConcatWith #-}++updateOrConcatWithKey :: Eq k => (k -> v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateOrConcatWithKey f ary1 ary2 = A.run $ do+    -- TODO: instead of mapping and then folding, should we traverse?+    -- We'll have to be careful to avoid allocating pairs or similar.++    -- first: look up the position of each element of ary2 in ary1+    let indices = A.map' (\(L k _) -> indexOf k ary1) ary2+    -- that tells us how large the overlap is:+    -- count number of Nothing constructors+    let nOnly2 = A.foldl' (\n -> maybe (n+1) (const n)) 0 indices+    let n1 = A.length ary1+    let n2 = A.length ary2+    -- copy over all elements from ary1+    mary <- A.new_ (n1 + nOnly2)+    A.copy ary1 0 mary 0 n1+    -- append or update all elements from ary2+    let go !iEnd !i2+          | i2 >= n2 = return ()+          | otherwise = case A.index indices i2 of+               Just i1 -> do -- key occurs in both arrays, store combination in position i1+                             L k v1 <- A.indexM ary1 i1+                             L _ v2 <- A.indexM ary2 i2+                             A.write mary i1 (L k (f k v1 v2))+                             go iEnd (i2+1)+               Nothing -> do -- key is only in ary2, append to end+                             A.write mary iEnd =<< A.indexM ary2 i2+                             go (iEnd+1) (i2+1)+    go n1 0+    return mary+{-# INLINABLE updateOrConcatWithKey #-}++-- | /O(n*m)/ Check if the first array is a subset of the second array.+subsetArray :: Eq k => (v1 -> v2 -> Bool) -> A.Array (Leaf k v1) -> A.Array (Leaf k v2) -> Bool+subsetArray cmpV ary1 ary2 = A.length ary1 <= A.length ary2 && A.all inAry2 ary1+  where+    inAry2 (L k1 v1) = lookupInArrayCont (\_ -> False) (\v2 _ -> cmpV v1 v2) k1 ary2+    {-# INLINE inAry2 #-}++------------------------------------------------------------------------+-- Manually unrolled loops++-- | /O(n)/ Update the element at the given position in this array.+update16 :: A.Array e -> Int -> e -> A.Array e+update16 ary idx b = runST (update16M ary idx b)+{-# INLINE update16 #-}++-- | /O(n)/ Update the element at the given position in this array.+update16M :: A.Array e -> Int -> e -> ST s (A.Array e)+update16M ary idx b = do+    mary <- clone16 ary+    A.write mary idx b+    A.unsafeFreeze mary+{-# INLINE update16M #-}++-- | /O(n)/ Update the element at the given position in this array, by applying a function to it.+update16With' :: A.Array e -> Int -> (e -> e) -> A.Array e+update16With' ary idx f+  | (# x #) <- A.index# ary idx+  = update16 ary idx $! f x+{-# INLINE update16With' #-}++-- | Unsafely clone an array of 16 elements.  The length of the input+-- array is not checked.+clone16 :: A.Array e -> ST s (A.MArray s e)+clone16 ary =+    A.thaw ary 0 16++------------------------------------------------------------------------+-- Bit twiddling++bitsPerSubkey :: Int+bitsPerSubkey = 4++maxChildren :: Int+maxChildren = 1 `unsafeShiftL` bitsPerSubkey++subkeyMask :: Bitmap+subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1++sparseIndex :: Bitmap -> Bitmap -> Int+sparseIndex b m = popCount (b .&. (m - 1))++mask :: Word -> Shift -> Bitmap+mask w s = 1 `unsafeShiftL` index w s+{-# INLINE mask #-}++-- | Mask out the 'bitsPerSubkey' bits used for indexing at this level+-- of the tree.+index :: Hash -> Shift -> Int+index w s = fromIntegral $ (unsafeShiftR w s) .&. subkeyMask+{-# INLINE index #-}++-- | A bitmask with the 'bitsPerSubkey' least significant bits set.+fullNodeMask :: Bitmap+fullNodeMask = complement (complement 0 `unsafeShiftL` maxChildren)+{-# INLINE fullNodeMask #-}++-- | Check if two the two arguments are the same value.  N.B. This+-- function might give false negatives (due to GC moving objects.)+ptrEq :: a -> a -> Bool+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#)+{-# INLINE ptrEq #-}++------------------------------------------------------------------------+-- IsList instance+instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where+    type Item (HashMap k v) = (k, v)+    fromList = fromList+    toList   = toList
+ src/Data/Strict/HashMap/Autogen/Internal/Array.hs view
@@ -0,0 +1,627 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- Zero based arrays.+--+-- Note that no bounds checking are performed.+module Data.Strict.HashMap.Autogen.Internal.Array+    ( Array+    , MArray++      -- * Creation+    , new+    , new_+    , singleton+    , singletonM+    , pair++      -- * Basic interface+    , length+    , lengthM+    , read+    , write+    , index+    , indexM+    , index#+    , update+    , updateWith'+    , unsafeUpdateM+    , insert+    , insertM+    , delete+    , sameArray1+    , trim++    , unsafeFreeze+    , unsafeThaw+    , unsafeSameArray+    , run+    , copy+    , copyM++      -- * Folds+    , foldl+    , foldl'+    , foldr+    , foldr'+    , foldMap+    , all++    , thaw+    , map+    , map'+    , traverse+    , traverse'+    , toList+    , fromList+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import Control.Applicative (liftA2)+import Control.DeepSeq+import GHC.Exts(Int(..), Int#, reallyUnsafePtrEquality#, tagToEnum#, unsafeCoerce#, State#)+import GHC.ST (ST(..))+import Control.Monad.ST (stToIO)++#if __GLASGOW_HASKELL__ >= 709+import Prelude hiding (filter, foldMap, foldr, foldl, length, map, read, traverse, all)+#else+import Prelude hiding (filter, foldr, foldl, length, map, read, all)+#endif++#if __GLASGOW_HASKELL__ >= 710+import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#,+                 indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#,+                 SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#,+                 sizeofSmallMutableArray#, copySmallMutableArray#, cloneSmallMutableArray#)++#else+import GHC.Exts (Array#, newArray#, readArray#, writeArray#,+                 indexArray#, unsafeFreezeArray#, unsafeThawArray#,+                 MutableArray#, sizeofArray#, copyArray#, thawArray#,+                 sizeofMutableArray#, copyMutableArray#, cloneMutableArray#)+import Data.Monoid (Monoid (..))+#endif++#if defined(ASSERTS)+import qualified Prelude+#endif++import Data.Strict.HashMap.Autogen.Internal.Unsafe (runST)+import Control.Monad ((>=>))+++#if __GLASGOW_HASKELL__ >= 710+type Array# a = SmallArray# a+type MutableArray# a = SmallMutableArray# a++newArray# :: Int# -> a -> State# d -> (# State# d, SmallMutableArray# d a #)+newArray# = newSmallArray#++unsafeFreezeArray# :: SmallMutableArray# d a+                   -> State# d -> (# State# d, SmallArray# a #)+unsafeFreezeArray# = unsafeFreezeSmallArray#++readArray# :: SmallMutableArray# d a+           -> Int# -> State# d -> (# State# d, a #)+readArray# = readSmallArray#++writeArray# :: SmallMutableArray# d a+            -> Int# -> a -> State# d -> State# d+writeArray# = writeSmallArray#++indexArray# :: SmallArray# a -> Int# -> (# a #)+indexArray# = indexSmallArray#++unsafeThawArray# :: SmallArray# a+                 -> State# d -> (# State# d, SmallMutableArray# d a #)+unsafeThawArray# = unsafeThawSmallArray#++sizeofArray# :: SmallArray# a -> Int#+sizeofArray# = sizeofSmallArray#++copyArray# :: SmallArray# a+           -> Int#+           -> SmallMutableArray# d a+           -> Int#+           -> Int#+           -> State# d+           -> State# d+copyArray# = copySmallArray#++cloneMutableArray# :: SmallMutableArray# s a+                   -> Int#+                   -> Int#+                   -> State# s+                   -> (# State# s, SmallMutableArray# s a #)+cloneMutableArray# = cloneSmallMutableArray#++thawArray# :: SmallArray# a+           -> Int#+           -> Int#+           -> State# d+           -> (# State# d, SmallMutableArray# d a #)+thawArray# = thawSmallArray#++sizeofMutableArray# :: SmallMutableArray# s a -> Int#+sizeofMutableArray# = sizeofSmallMutableArray#++copyMutableArray# :: SmallMutableArray# d a+                  -> Int#+                  -> SmallMutableArray# d a+                  -> Int#+                  -> Int#+                  -> State# d+                  -> State# d+copyMutableArray# = copySmallMutableArray#+#endif++------------------------------------------------------------------------++#if defined(ASSERTS)+-- This fugly hack is brought by GHC's apparent reluctance to deal+-- with MagicHash and UnboxedTuples when inferring types. Eek!+# define CHECK_BOUNDS(_func_,_len_,_k_) \+if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.Strict.HashMap.Autogen.Internal.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else+# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \+if not ((_lhs_) _op_ (_rhs_)) then error ("Data.Strict.HashMap.Autogen.Internal.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else+# define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_)+# define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_)+# define CHECK_EQ(_func_,_lhs_,_rhs_) CHECK_OP(_func_,==,_lhs_,_rhs_)+#else+# define CHECK_BOUNDS(_func_,_len_,_k_)+# define CHECK_OP(_func_,_op_,_lhs_,_rhs_)+# define CHECK_GT(_func_,_lhs_,_rhs_)+# define CHECK_LE(_func_,_lhs_,_rhs_)+# define CHECK_EQ(_func_,_lhs_,_rhs_)+#endif++data Array a = Array {+      unArray :: !(Array# a)+    }++instance Show a => Show (Array a) where+    show = show . toList++-- Determines whether two arrays have the same memory address.+-- This is more reliable than testing pointer equality on the+-- Array wrappers, but it's still slightly bogus.+unsafeSameArray :: Array a -> Array b -> Bool+unsafeSameArray (Array xs) (Array ys) =+  tagToEnum# (unsafeCoerce# reallyUnsafePtrEquality# xs ys)++sameArray1 :: (a -> b -> Bool) -> Array a -> Array b -> Bool+sameArray1 eq !xs0 !ys0+  | lenxs /= lenys = False+  | otherwise = go 0 xs0 ys0+  where+    go !k !xs !ys+      | k == lenxs = True+      | (# x #) <- index# xs k+      , (# y #) <- index# ys k+      = eq x y && go (k + 1) xs ys++    !lenxs = length xs0+    !lenys = length ys0++length :: Array a -> Int+length ary = I# (sizeofArray# (unArray ary))+{-# INLINE length #-}++data MArray s a = MArray {+      unMArray :: !(MutableArray# s a)+    }++lengthM :: MArray s a -> Int+lengthM mary = I# (sizeofMutableArray# (unMArray mary))+{-# INLINE lengthM #-}++------------------------------------------------------------------------++instance NFData a => NFData (Array a) where+    rnf = rnfArray++rnfArray :: NFData a => Array a -> ()+rnfArray ary0 = go ary0 n0 0+  where+    n0 = length ary0+    go !ary !n !i+        | i >= n = ()+        | (# x #) <- index# ary i+        = rnf x `seq` go ary n (i+1)+-- We use index# just in case GHC can't see that the+-- relevant rnf is strict, or in case it actually isn't.+{-# INLINE rnfArray #-}++-- | Create a new mutable array of specified size, in the specified+-- state thread, with each element containing the specified initial+-- value.+new :: Int -> a -> ST s (MArray s a)+new i !b = new' i b+{-# INLINE new #-}++new' :: Int -> a -> ST s (MArray s a)+new' (I# n#) b =+    CHECK_GT("new",n,(0 :: Int))+    ST $ \s ->+        case newArray# n# b s of+            (# s', ary #) -> (# s', MArray ary #)+{-# INLINE new' #-}++new_ :: Int -> ST s (MArray s a)+new_ n = new' n undefinedElem++singleton :: a -> Array a+singleton !x = runST (singletonM x)+{-# INLINE singleton #-}++singletonM :: a -> ST s (Array a)+singletonM !x = new 1 x >>= unsafeFreeze+{-# INLINE singletonM #-}++pair :: a -> a -> Array a+pair !x !y = run $ do+    ary <- new 2 x+    write ary 1 y+    return ary+{-# INLINE pair #-}++read :: MArray s a -> Int -> ST s a+read ary _i@(I# i#) = ST $ \ s ->+    CHECK_BOUNDS("read", lengthM ary, _i)+        readArray# (unMArray ary) i# s+{-# INLINE read #-}++write :: MArray s a -> Int -> a -> ST s ()+write ary _i@(I# i#) !b = ST $ \ s ->+    CHECK_BOUNDS("write", lengthM ary, _i)+        case writeArray# (unMArray ary) i# b s of+            s' -> (# s' , () #)+{-# INLINE write #-}++index :: Array a -> Int -> a+index ary _i@(I# i#) =+    CHECK_BOUNDS("index", length ary, _i)+        case indexArray# (unArray ary) i# of (# b #) -> b+{-# INLINE index #-}++index# :: Array a -> Int -> (# a #)+index# ary _i@(I# i#) =+    CHECK_BOUNDS("index#", length ary, _i)+        indexArray# (unArray ary) i#+{-# INLINE index# #-}++indexM :: Array a -> Int -> ST s a+indexM ary _i@(I# i#) =+    CHECK_BOUNDS("indexM", length ary, _i)+        case indexArray# (unArray ary) i# of (# b #) -> return b+{-# INLINE indexM #-}++unsafeFreeze :: MArray s a -> ST s (Array a)+unsafeFreeze mary+    = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of+                   (# s', ary #) -> (# s', Array ary #)+{-# INLINE unsafeFreeze #-}++unsafeThaw :: Array a -> ST s (MArray s a)+unsafeThaw ary+    = ST $ \s -> case unsafeThawArray# (unArray ary) s of+                   (# s', mary #) -> (# s', MArray mary #)+{-# INLINE unsafeThaw #-}++run :: (forall s . ST s (MArray s e)) -> Array e+run act = runST $ act >>= unsafeFreeze+{-# INLINE run #-}++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s ()+copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+    CHECK_LE("copy", _sidx + _n, length src)+    CHECK_LE("copy", _didx + _n, lengthM dst)+        ST $ \ s# ->+        case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of+            s2 -> (# s2, () #)++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()+copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+    CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1)+    CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1)+    ST $ \ s# ->+    case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of+        s2 -> (# s2, () #)++cloneM :: MArray s a -> Int -> Int -> ST s (MArray s a)+cloneM _mary@(MArray mary#) _off@(I# off#) _len@(I# len#) =+    CHECK_BOUNDS("cloneM_off", lengthM _mary, _off - 1)+    CHECK_BOUNDS("cloneM_end", lengthM _mary, _off + _len - 1)+    ST $ \ s ->+    case cloneMutableArray# mary# off# len# s of+      (# s', mary'# #) -> (# s', MArray mary'# #)++-- | Create a new array of the @n@ first elements of @mary@.+trim :: MArray s a -> Int -> ST s (Array a)+trim mary n = cloneM mary 0 n >>= unsafeFreeze+{-# INLINE trim #-}++-- | /O(n)/ Insert an element at the given position in this array,+-- increasing its size by one.+insert :: Array e -> Int -> e -> Array e+insert ary idx b = runST (insertM ary idx b)+{-# INLINE insert #-}++-- | /O(n)/ Insert an element at the given position in this array,+-- increasing its size by one.+insertM :: Array e -> Int -> e -> ST s (Array e)+insertM ary idx b =+    CHECK_BOUNDS("insertM", count + 1, idx)+        do mary <- new_ (count+1)+           copy ary 0 mary 0 idx+           write mary idx b+           copy ary idx mary (idx+1) (count-idx)+           unsafeFreeze mary+  where !count = length ary+{-# INLINE insertM #-}++-- | /O(n)/ Update the element at the given position in this array.+update :: Array e -> Int -> e -> Array e+update ary idx b = runST (updateM ary idx b)+{-# INLINE update #-}++-- | /O(n)/ Update the element at the given position in this array.+updateM :: Array e -> Int -> e -> ST s (Array e)+updateM ary idx b =+    CHECK_BOUNDS("updateM", count, idx)+        do mary <- thaw ary 0 count+           write mary idx b+           unsafeFreeze mary+  where !count = length ary+{-# INLINE updateM #-}++-- | /O(n)/ Update the element at the given positio in this array, by+-- applying a function to it.  Evaluates the element to WHNF before+-- inserting it into the array.+updateWith' :: Array e -> Int -> (e -> e) -> Array e+updateWith' ary idx f+  | (# x #) <- index# ary idx+  = update ary idx $! f x+{-# INLINE updateWith' #-}++-- | /O(1)/ Update the element at the given position in this array,+-- without copying.+unsafeUpdateM :: Array e -> Int -> e -> ST s ()+unsafeUpdateM ary idx b =+    CHECK_BOUNDS("unsafeUpdateM", length ary, idx)+        do mary <- unsafeThaw ary+           write mary idx b+           _ <- unsafeFreeze mary+           return ()+{-# INLINE unsafeUpdateM #-}++foldl' :: (b -> a -> b) -> b -> Array a -> b+foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0+  where+    go ary n i !z+        | i >= n = z+        | otherwise+        = case index# ary i of+            (# x #) -> go ary n (i+1) (f z x)+{-# INLINE foldl' #-}++foldr' :: (a -> b -> b) -> b -> Array a -> b+foldr' f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0+  where+    go !_ary (-1) z = z+    go !ary i !z+      | (# x #) <- index# ary i+      = go ary (i - 1) (f x z)+{-# INLINE foldr' #-}++foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0+  where+    go ary n i z+        | i >= n = z+        | otherwise+        = case index# ary i of+            (# x #) -> f x (go ary n (i+1) z)+{-# INLINE foldr #-}++foldl :: (b -> a -> b) -> b -> Array a -> b+foldl f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0+  where+    go _ary (-1) z = z+    go ary i z+      | (# x #) <- index# ary i+      = f (go ary (i - 1) z) x+{-# INLINE foldl #-}++-- We go to a bit of trouble here to avoid appending an extra mempty.+-- The below implementation is by Mateusz Kowalczyk, who indicates that+-- benchmarks show it to be faster than one that avoids lifting out+-- lst.+foldMap :: Monoid m => (a -> m) -> Array a -> m+foldMap f = \ary0 -> case length ary0 of+  0 -> mempty+  len ->+    let !lst = len - 1+        go i | (# x #) <- index# ary0 i, let fx = f x =+          if i == lst then fx else fx `mappend` go (i + 1)+    in go 0+{-# INLINE foldMap #-}++-- | Verifies that a predicate holds for all elements of an array.+all :: (a -> Bool) -> Array a -> Bool+all p = foldr (\a acc -> p a && acc) True+{-# INLINE all #-}++undefinedElem :: a+undefinedElem = error "Data.Strict.HashMap.Autogen.Internal.Array: Undefined element"+{-# NOINLINE undefinedElem #-}++thaw :: Array e -> Int -> Int -> ST s (MArray s e)+thaw !ary !_o@(I# o#) (I# n#) =+    CHECK_LE("thaw", _o + n, length ary)+        ST $ \ s -> case thawArray# (unArray ary) o# n# s of+            (# s2, mary# #) -> (# s2, MArray mary# #)+{-# INLINE thaw #-}++-- | /O(n)/ Delete an element at the given position in this array,+-- decreasing its size by one.+delete :: Array e -> Int -> Array e+delete ary idx = runST (deleteM ary idx)+{-# INLINE delete #-}++-- | /O(n)/ Delete an element at the given position in this array,+-- decreasing its size by one.+deleteM :: Array e -> Int -> ST s (Array e)+deleteM ary idx = do+    CHECK_BOUNDS("deleteM", count, idx)+        do mary <- new_ (count-1)+           copy ary 0 mary 0 idx+           copy ary (idx+1) mary idx (count-(idx+1))+           unsafeFreeze mary+  where !count = length ary+{-# INLINE deleteM #-}++map :: (a -> b) -> Array a -> Array b+map f = \ ary ->+    let !n = length ary+    in run $ do+        mary <- new_ n+        go ary mary 0 n+  where+    go ary mary i n+        | i >= n    = return mary+        | otherwise = do+             x <- indexM ary i+             write mary i $ f x+             go ary mary (i+1) n+{-# INLINE map #-}++-- | Strict version of 'map'.+map' :: (a -> b) -> Array a -> Array b+map' f = \ ary ->+    let !n = length ary+    in run $ do+        mary <- new_ n+        go ary mary 0 n+  where+    go ary mary i n+        | i >= n    = return mary+        | otherwise = do+             x <- indexM ary i+             write mary i $! f x+             go ary mary (i+1) n+{-# INLINE map' #-}++fromList :: Int -> [a] -> Array a+fromList n xs0 =+    CHECK_EQ("fromList", n, Prelude.length xs0)+        run $ do+            mary <- new_ n+            go xs0 mary 0+  where+    go [] !mary !_   = return mary+    go (x:xs) mary i = do write mary i x+                          go xs mary (i+1)++toList :: Array a -> [a]+toList = foldr (:) []++newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)}++runSTA :: Int -> STA a -> Array a+runSTA !n (STA m) = runST $ new_ n >>= \ (MArray ar) -> m ar++traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse f = \ !ary ->+  let+    !len = length ary+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary)+      | (# x #) <- index# ary i+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  write (MArray mary) i b >> m mary)+               (f x) (go (i + 1))+  in runSTA len <$> go 0+{-# INLINE [1] traverse #-}++-- TODO: Would it be better to just use a lazy traversal+-- and then force the elements of the result? My guess is+-- yes.+traverse' :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse' f = \ !ary ->+  let+    !len = length ary+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary)+      | (# x #) <- index# ary i+      = liftA2 (\ !b (STA m) -> STA $ \mary ->+                    write (MArray mary) i b >> m mary)+               (f x) (go (i + 1))+  in runSTA len <$> go 0+{-# INLINE [1] traverse' #-}++-- Traversing in ST, we don't need to get fancy; we+-- can just do it directly.+traverseST :: (a -> ST s b) -> Array a -> ST s (Array b)+traverseST f = \ ary0 ->+  let+    !len = length ary0+    go k !mary+      | k == len = return mary+      | otherwise = do+          x <- indexM ary0 k+          y <- f x+          write mary k y+          go (k + 1) mary+  in new_ len >>= (go 0 >=> unsafeFreeze)+{-# INLINE traverseST #-}++traverseIO :: (a -> IO b) -> Array a -> IO (Array b)+traverseIO f = \ ary0 ->+  let+    !len = length ary0+    go k !mary+      | k == len = return mary+      | otherwise = do+          x <- stToIO $ indexM ary0 k+          y <- f x+          stToIO $ write mary k y+          go (k + 1) mary+  in stToIO (new_ len) >>= (go 0 >=> stToIO . unsafeFreeze)+{-# INLINE traverseIO #-}+++-- Why don't we have similar RULES for traverse'? The efficient+-- way to traverse strictly in IO or ST is to force results as+-- they come in, which leads to different semantics. In particular,+-- we need to ensure that+--+--  traverse' (\x -> print x *> pure undefined) xs+--+-- will actually print all the values and then return undefined.+-- We could add a strict mapMWithIndex, operating in an arbitrary+-- Monad, that supported such rules, but we don't have that right now.+{-# RULES+"traverse/ST" forall f. traverse f = traverseST f+"traverse/IO" forall f. traverse f = traverseIO f+ #-}
+ src/Data/Strict/HashMap/Autogen/Internal/List.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- Extra list functions+--+-- In separate module to aid testing.+module Data.Strict.HashMap.Autogen.Internal.List+    ( isPermutationBy+    , deleteBy+    , unorderedCompare+    ) where++import Data.Maybe (fromMaybe)+import Data.List (sortBy)+import Data.Monoid+import Prelude++-- Note: previous implemenation isPermutation = null (as // bs)+-- was O(n^2) too.+--+-- This assumes lists are of equal length+isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool+isPermutationBy f = go+  where+    f' = flip f++    go [] [] = True+    go (x : xs) (y : ys)+        | f x y         = go xs ys+        | otherwise     = fromMaybe False $ do+            xs' <- deleteBy f' y xs+            ys' <- deleteBy f x ys+            return (go xs' ys')+    go [] (_ : _) = False+    go (_ : _) [] = False++-- The idea:+--+-- Homogeonous version+--+-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering+-- uc c as bs = compare (sortBy c as) (sortBy c bs)+--+-- But as we have only (a -> b -> Ordering), we cannot directly compare+-- elements from the same list.+--+-- So when comparing elements from the list, we count how many elements are+-- "less and greater" in the other list, and use the count as a metric.+--+unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering+unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs)+  where+    go [] [] = EQ+    go [] (_ : _) = LT+    go (_ : _) [] = GT+    go (x : xs) (y : ys) = c x y `mappend` go xs ys++    cmpA a a' = compare (inB a) (inB a')+    cmpB b b' = compare (inA b) (inA b')++    inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs)+    inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as)++-- Returns Nothing is nothing deleted+deleteBy              :: (a -> b -> Bool) -> a -> [b] -> Maybe [b]+deleteBy _  _ []      = Nothing+deleteBy eq x (y:ys)  = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys)
+ src/Data/Strict/HashMap/Autogen/Internal/Strict.hs view
@@ -0,0 +1,757 @@+{-# LANGUAGE BangPatterns, CPP, PatternGuards, MagicHash, UnboxedTuples #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_HADDOCK not-home #-}++------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.HashMap.Autogen.Strict+-- Copyright   :  2010-2012 Johan Tibell+-- License     :  BSD-style+-- Maintainer  :  johan.tibell@gmail.com+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- A map from /hashable/ keys to values.  A map cannot contain+-- duplicate keys; each key can map to at most one value.  A 'HashMap'+-- makes no guarantees as to the order of its elements.+--+-- The implementation is based on /hash array mapped tries/.  A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings.+--+-- Many operations have a average-case complexity of /O(log n)/.  The+-- implementation uses a large base (i.e. 16) so in practice these+-- operations are constant time.+module Data.Strict.HashMap.Autogen.Internal.Strict+    (+      -- * Strictness properties+      -- $strictness++      HashMap++      -- * Construction+    , empty+    , singleton++      -- * Basic interface+    , HM.null+    , size+    , HM.member+    , HM.lookup+    , (HM.!?)+    , HM.findWithDefault+    , lookupDefault+    , (!)+    , insert+    , insertWith+    , delete+    , adjust+    , update+    , alter+    , alterF+    , isSubmapOf+    , isSubmapOfBy++      -- * Combine+      -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions++    -- ** Compose+    , compose++      -- * Transformations+    , map+    , mapWithKey+    , traverseWithKey++      -- * Difference and intersection+    , difference+    , differenceWith+    , intersection+    , intersectionWith+    , intersectionWithKey++      -- * Folds+    , foldMapWithKey+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'+    , HM.foldr+    , HM.foldl+    , foldrWithKey+    , foldlWithKey++      -- * Filter+    , HM.filter+    , filterWithKey+    , mapMaybe+    , mapMaybeWithKey++      -- * Conversions+    , keys+    , elems++      -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey+    ) where++import Data.Bits ((.&.), (.|.))++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import qualified Data.List as L+import Data.Hashable (Hashable)+import Prelude hiding (map, lookup)++import qualified Data.Strict.HashMap.Autogen.Internal.Array as A+import qualified Data.Strict.HashMap.Autogen.Internal as HM+import Data.Strict.HashMap.Autogen.Internal hiding (+    alter, alterF, adjust, fromList, fromListWith, fromListWithKey,+    insert, insertWith,+    differenceWith, intersectionWith, intersectionWithKey, map, mapWithKey,+    mapMaybe, mapMaybeWithKey, singleton, update, unionWith, unionWithKey,+    traverseWithKey)+import Data.Strict.HashMap.Autogen.Internal.Unsafe (runST)+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity+#endif+import Control.Applicative (Const (..))+import Data.Coerce++-- $strictness+--+-- This module satisfies the following strictness properties:+--+-- 1. Key arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+--    the map.++------------------------------------------------------------------------+-- * Construction++-- | /O(1)/ Construct a map with a single element.+singleton :: (Hashable k) => k -> v -> HashMap k v+singleton k !v = HM.singleton k v++------------------------------------------------------------------------+-- * Basic interface++-- | /O(log n)/ Associate the specified value with the specified+-- key in this map.  If this map previously contained a mapping for+-- the key, the old value is replaced.+insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v+insert k !v = HM.insert k v+{-# INLINABLE insert #-}++-- | /O(log n)/ Associate the value with the key in this map.  If+-- this map previously contained a mapping for the key, the old value+-- is replaced by the result of applying the given function to the new+-- and old value.  Example:+--+-- > insertWith f k v map+-- >   where f new old = new + old+insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v+           -> HashMap k v+insertWith f k0 v0 m0 = go h0 k0 v0 0 m0+  where+    h0 = hash k0+    go !h !k x !_ Empty = leaf h k x+    go h k x s t@(Leaf hy l@(L ky y))+        | hy == h = if ky == k+                    then leaf h k (f x y)+                    else x `seq` (collision h l (L k x))+        | otherwise = x `seq` runST (two s h k x hy t)+    go h k x s (BitmapIndexed b ary)+        | b .&. m == 0 =+            let ary' = A.insert ary i $! leaf h k x+            in bitmapIndexedOrFull (b .|. m) ary'+        | otherwise =+            let st   = A.index ary i+                st'  = go h k x (s+bitsPerSubkey) st+                ary' = A.update ary i $! st'+            in BitmapIndexed b ary'+      where m = mask h s+            i = sparseIndex b m+    go h k x s (Full ary) =+        let st   = A.index ary i+            st'  = go h k x (s+bitsPerSubkey) st+            ary' = update16 ary i $! st'+        in Full ary'+      where i = index h s+    go h k x s t@(Collision hy v)+        | h == hy   = Collision h (updateOrSnocWith f k x v)+        | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE insertWith #-}++-- | In-place update version of insertWith+unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v+                 -> HashMap k v+unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0+{-# INLINABLE unsafeInsertWith #-}++unsafeInsertWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> k -> v -> HashMap k v+                    -> HashMap k v+unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0)+  where+    h0 = hash k0+    go !h !k x !_ Empty = return $! leaf h k x+    go h k x s t@(Leaf hy l@(L ky y))+        | hy == h = if ky == k+                    then return $! leaf h k (f k x y)+                    else do+                        let l' = x `seq` (L k x)+                        return $! collision h l l'+        | otherwise = x `seq` two s h k x hy t+    go h k x s t@(BitmapIndexed b ary)+        | b .&. m == 0 = do+            ary' <- A.insertM ary i $! leaf h k x+            return $! bitmapIndexedOrFull (b .|. m) ary'+        | otherwise = do+            st <- A.indexM ary i+            st' <- go h k x (s+bitsPerSubkey) st+            A.unsafeUpdateM ary i st'+            return t+      where m = mask h s+            i = sparseIndex b m+    go h k x s t@(Full ary) = do+        st <- A.indexM ary i+        st' <- go h k x (s+bitsPerSubkey) st+        A.unsafeUpdateM ary i st'+        return t+      where i = index h s+    go h k x s t@(Collision hy v)+        | h == hy   = return $! Collision h (updateOrSnocWithKey f k x v)+        | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE unsafeInsertWithKey #-}++-- | /O(log n)/ Adjust the value tied to a given key in this map only+-- if it is present. Otherwise, leave the map alone.+adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v+adjust f k0 m0 = go h0 k0 0 m0+  where+    h0 = hash k0+    go !_ !_ !_ Empty = Empty+    go h k _ t@(Leaf hy (L ky y))+        | hy == h && ky == k = leaf h k (f y)+        | otherwise          = t+    go h k s t@(BitmapIndexed b ary)+        | b .&. m == 0 = t+        | otherwise = let st   = A.index ary i+                          st'  = go h k (s+bitsPerSubkey) st+                          ary' = A.update ary i $! st'+                      in BitmapIndexed b ary'+      where m = mask h s+            i = sparseIndex b m+    go h k s (Full ary) =+        let i    = index h s+            st   = A.index ary i+            st'  = go h k (s+bitsPerSubkey) st+            ary' = update16 ary i $! st'+        in Full ary'+    go h k _ t@(Collision hy v)+        | h == hy   = Collision h (updateWith f k v)+        | otherwise = t+{-# INLINABLE adjust #-}++-- | /O(log n)/  The expression @('update' f k map)@ updates the value @x@ at @k@+-- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted.+-- If it is @('Just' y)@, the key @k@ is bound to the new value @y@.+update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a+update f = alter (>>= f)+{-# INLINABLE update #-}++-- | /O(log n)/  The expression @('alter' f k map)@ alters the value @x@ at @k@, or+-- absence thereof.+--+-- 'alter' can be used to insert, delete, or update a value in a map. In short:+--+-- @+-- 'lookup' k ('alter' f k m) = f ('lookup' k m)+-- @+alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v+alter f k m =+  case f (HM.lookup k m) of+    Nothing -> delete k m+    Just v  -> insert k v m+{-# INLINABLE alter #-}++-- | /O(log n)/  The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.+--+-- 'alterF' can be used to insert, delete, or update a value in a map.+--+-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- <https://hackage.haskell.org/package/lens/docs/Control-Lens-At.html#v:at Control.Lens.At>.+--+-- @since 0.2.10+alterF :: (Functor f, Eq k, Hashable k)+       => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+-- Special care is taken to only calculate the hash once. When we rewrite+-- with RULES, we also ensure that we only compare the key for equality+-- once. We force the value of the map for consistency with the rewritten+-- version; otherwise someone could tell the difference using a lazy+-- @f@ and a functor that is similar to Const but not actually Const.+alterF f = \ !k !m ->+  let !h = hash k+      mv = lookup' h k m+  in (<$> f mv) $ \fres ->+    case fres of+      Nothing -> maybe m (const (delete' h k m)) mv+      Just !v' -> insert' h k v' m++-- We rewrite this function unconditionally in RULES, but we expose+-- an unfolding just in case it's used in a context where the rules+-- don't fire.+{-# INLINABLE [0] alterF #-}++#if MIN_VERSION_base(4,8,0)+-- See notes in Data.Strict.HashMap.Autogen.Internal+test_bottom :: a+test_bottom = error "Data.Strict.HashMap.Autogen.alterF internal error: hit test_bottom"++bogus# :: (# #) -> (# a #)+bogus# _ = error "Data.Strict.HashMap.Autogen.alterF internal error: hit bogus#"++impossibleAdjust :: a+impossibleAdjust = error "Data.Strict.HashMap.Autogen.alterF internal error: impossible adjust"++{-# RULES++-- See detailed notes on alterF rules in Data.Strict.HashMap.Autogen.Internal.++"alterFWeird" forall f. alterF f =+    alterFWeird (f Nothing) (f (Just test_bottom)) f++"alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x.+  alterFWeird x x f = \ !k !m ->+    Identity (case runIdentity x of {Nothing -> delete k m; Just a -> insert k a m})++"alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y.+  alterFWeird (coerce (Just x)) (coerce (Just y)) f =+    coerce (insertModifying x (\mold -> case runIdentity (f (Just mold)) of+                                            Nothing -> bogus# (# #)+                                            Just !new -> (# new #)))++-- This rule is written a bit differently than the one for lazy+-- maps because the adjust here is strict. We could write it the+-- same general way anyway, but this seems simpler.+"alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) x.+  alterFWeird (coerce Nothing) (coerce (Just x)) f =+    coerce (adjust (\a -> case runIdentity (f (Just a)) of+                               Just a' -> a'+                               Nothing -> impossibleAdjust))++"alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) .+  alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (lookup k m)))+ #-}++-- This is a very unsafe version of alterF used for RULES. When calling+-- alterFWeird x y f, the following *must* hold:+--+-- x = f Nothing+-- y = f (Just _|_)+--+-- Failure to abide by these laws will make demons come out of your nose.+alterFWeird+       :: (Functor f, Eq k, Hashable k)+       => f (Maybe v)+       -> f (Maybe v)+       -> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFWeird _ _ f = alterFEager f+{-# INLINE [0] alterFWeird #-}++-- | This is the default version of alterF that we use in most non-trivial+-- cases. It's called "eager" because it looks up the given key in the map+-- eagerly, whether or not the given function requires that information.+alterFEager :: (Functor f, Eq k, Hashable k)+       => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFEager f !k !m = (<$> f mv) $ \fres ->+  case fres of++    ------------------------------+    -- Delete the key from the map.+    Nothing -> case lookupRes of++      -- Key did not exist in the map to begin with, no-op+      Absent -> m++      -- Key did exist, no collision+      Present _ collPos -> deleteKeyExists collPos h k m++    ------------------------------+    -- Update value+    Just v' -> case lookupRes of++      -- Key did not exist before, insert v' under a new key+      Absent -> insertNewKey h k v' m++      -- Key existed before, no hash collision+      Present v collPos -> v' `seq`+        if v `ptrEq` v'+        -- If the value is identical, no-op+        then m+        -- If the value changed, update the value.+        else insertKeyExists collPos h k v' m++  where !h = hash k+        !lookupRes = lookupRecordCollision h k m+        !mv = case lookupRes of+          Absent -> Nothing+          Present v _ -> Just v+{-# INLINABLE alterFEager #-}+#endif++------------------------------------------------------------------------+-- * Combine++-- | /O(n+m)/ The union of two maps.  If a key occurs in both maps,+-- the provided function (first argument) will be used to compute the result.+unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v+          -> HashMap k v+unionWith f = unionWithKey (const f)+{-# INLINE unionWith #-}++-- | /O(n+m)/ The union of two maps.  If a key occurs in both maps,+-- the provided function (first argument) will be used to compute the result.+unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v+          -> HashMap k v+unionWithKey f = go 0+  where+    -- empty vs. anything+    go !_ t1 Empty = t1+    go _ Empty t2 = t2+    -- leaf vs. leaf+    go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2))+        | h1 == h2  = if k1 == k2+                      then leaf h1 k1 (f k1 v1 v2)+                      else collision h1 l1 l2+        | otherwise = goDifferentHash s h1 h2 t1 t2+    go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2)+        | h1 == h2  = Collision h1 (updateOrSnocWithKey f k1 v1 ls2)+        | otherwise = goDifferentHash s h1 h2 t1 t2+    go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2))+        | h1 == h2  = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1)+        | otherwise = goDifferentHash s h1 h2 t1 t2+    go s t1@(Collision h1 ls1) t2@(Collision h2 ls2)+        | h1 == h2  = Collision h1 (updateOrConcatWithKey f ls1 ls2)+        | otherwise = goDifferentHash s h1 h2 t1 t2+    -- branch vs. branch+    go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =+        let b'   = b1 .|. b2+            ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2+        in bitmapIndexedOrFull b' ary'+    go s (BitmapIndexed b1 ary1) (Full ary2) =+        let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2+        in Full ary'+    go s (Full ary1) (BitmapIndexed b2 ary2) =+        let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2+        in Full ary'+    go s (Full ary1) (Full ary2) =+        let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask+                   ary1 ary2+        in Full ary'+    -- leaf vs. branch+    go s (BitmapIndexed b1 ary1) t2+        | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2+                               b'   = b1 .|. m2+                           in bitmapIndexedOrFull b' ary'+        | otherwise      = let ary' = A.updateWith' ary1 i $ \st1 ->+                                   go (s+bitsPerSubkey) st1 t2+                           in BitmapIndexed b1 ary'+        where+          h2 = leafHashCode t2+          m2 = mask h2 s+          i = sparseIndex b1 m2+    go s t1 (BitmapIndexed b2 ary2)+        | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1+                               b'   = b2 .|. m1+                           in bitmapIndexedOrFull b' ary'+        | otherwise      = let ary' = A.updateWith' ary2 i $ \st2 ->+                                   go (s+bitsPerSubkey) t1 st2+                           in BitmapIndexed b2 ary'+      where+        h1 = leafHashCode t1+        m1 = mask h1 s+        i = sparseIndex b2 m1+    go s (Full ary1) t2 =+        let h2   = leafHashCode t2+            i    = index h2 s+            ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2+        in Full ary'+    go s t1 (Full ary2) =+        let h1   = leafHashCode t1+            i    = index h1 s+            ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2+        in Full ary'++    leafHashCode (Leaf h _) = h+    leafHashCode (Collision h _) = h+    leafHashCode _ = error "leafHashCode"++    goDifferentHash s h1 h2 t1 t2+        | m1 == m2  = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2)+        | m1 <  m2  = BitmapIndexed (m1 .|. m2) (A.pair t1 t2)+        | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1)+      where+        m1 = mask h1 s+        m2 = mask h2 s+{-# INLINE unionWithKey #-}++------------------------------------------------------------------------+-- * Transformations++-- | /O(n)/ Transform this map by applying a function to every value.+mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2+mapWithKey f = go+  where+    go Empty                 = Empty+    go (Leaf h (L k v))      = leaf h k (f k v)+    go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary+    go (Full ary)            = Full $ A.map' go ary+    go (Collision h ary)     =+        Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary+{-# INLINE mapWithKey #-}++-- | /O(n)/ Transform this map by applying a function to every value.+map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = mapWithKey (const f)+{-# INLINE map #-}+++------------------------------------------------------------------------+-- * Filter++-- | /O(n)/ Transform this map by applying a function to every value+--   and retaining only some of them.+mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybeWithKey f = filterMapAux onLeaf onColl+  where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v')+        onLeaf _ = Nothing++        onColl (L k v) | Just v' <- f k v = Just (L k v')+                       | otherwise = Nothing+{-# INLINE mapMaybeWithKey #-}++-- | /O(n)/ Transform this map by applying a function to every value+--   and retaining only some of them.+mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybe f = mapMaybeWithKey (const f)+{-# INLINE mapMaybe #-}++-- | /O(n)/ Perform an 'Applicative' action for each key-value pair+-- in a 'HashMap' and produce a 'HashMap' of all the results. Each 'HashMap'+-- will be strict in all its values.+--+-- @+-- traverseWithKey f = fmap ('map' id) . "Data.Strict.HashMap.Autogen.Lazy".'Data.Strict.HashMap.Autogen.Lazy.traverseWithKey' f+-- @+--+-- Note: the order in which the actions occur is unspecified. In particular,+-- when the map contains hash collisions, the order in which the actions+-- associated with the keys involved will depend in an unspecified way on+-- their insertion order.+traverseWithKey+  :: Applicative f+  => (k -> v1 -> f v2)+  -> HashMap k v1 -> f (HashMap k v2)+traverseWithKey f = go+  where+    go Empty                 = pure Empty+    go (Leaf h (L k v))      = leaf h k <$> f k v+    go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse' go ary+    go (Full ary)            = Full <$> A.traverse' go ary+    go (Collision h ary)     =+        Collision h <$> A.traverse' (\ (L k v) -> (L k $!) <$> f k v) ary+{-# INLINE traverseWithKey #-}++------------------------------------------------------------------------+-- * Difference and intersection++-- | /O(n*log m)/ Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+differenceWith :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v+differenceWith f a b = foldlWithKey' go empty a+  where+    go m k v = case HM.lookup k b of+                 Nothing -> insert k v m+                 Just w  -> maybe m (\y -> insert k y m) (f v w)+{-# INLINABLE differenceWith #-}++-- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps+-- the provided function is used to combine the values from the two+-- maps.+intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1+                 -> HashMap k v2 -> HashMap k v3+intersectionWith f a b = foldlWithKey' go empty a+  where+    go m k v = case HM.lookup k b of+                 Just w -> insert k (f v w) m+                 _      -> m+{-# INLINABLE intersectionWith #-}++-- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps+-- the provided function is used to combine the values from the two+-- maps.+intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3)+                    -> HashMap k v1 -> HashMap k v2 -> HashMap k v3+intersectionWithKey f a b = foldlWithKey' go empty a+  where+    go m k v = case HM.lookup k b of+                 Just w -> insert k (f k v w) m+                 _      -> m+{-# INLINABLE intersectionWithKey #-}++------------------------------------------------------------------------+-- ** Lists++-- | /O(n*log n)/ Construct a map with the supplied mappings.  If the+-- list contains duplicate mappings, the later mappings take+-- precedence.+fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v+fromList = L.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) empty+{-# INLINABLE fromList #-}++-- | /O(n*log n)/ Construct a map from a list of elements.  Uses+-- the provided function @f@ to merge duplicate entries with+-- @(f newVal oldVal)@.+--+-- === Examples+--+-- Given a list @xs@, create a map with the number of occurrences of each+-- element in @xs@:+--+-- > let xs = ['a', 'b', 'a']+-- > in fromListWith (+) [ (x, 1) | x <- xs ]+-- >+-- > = fromList [('a', 2), ('b', 1)]+--+-- Given a list of key-value pairs @xs :: [(k, v)]@, group all values by their+-- keys and return a @HashMap k [v]@.+--+-- > let xs = ('a', 1), ('b', 2), ('a', 3)]+-- > in fromListWith (++) [ (k, [v]) | (k, v) <- xs ]+-- >+-- > = fromList [('a', [3, 1]), ('b', [2])]+--+-- Note that the lists in the resulting map contain elements in reverse order+-- from their occurences in the original list.+--+-- More generally, duplicate entries are accumulated as follows;+-- this matters when @f@ is not commutative or not associative.+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f d (f c (f b a)))]+fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty+{-# INLINE fromListWith #-}++-- | /O(n*log n)/ Construct a map from a list of elements.  Uses+-- the provided function to merge duplicate entries.+--+-- === Examples+--+-- Given a list of key-value pairs where the keys are of different flavours, e.g:+--+-- > data Key = Div | Sub+--+-- and the values need to be combined differently when there are duplicates,+-- depending on the key:+--+-- > combine Div = div+-- > combine Sub = (-)+--+-- then @fromListWithKey@ can be used as follows:+--+-- > fromListWithKey combine [(Div, 2), (Div, 6), (Sub, 2), (Sub, 3)]+-- > = fromList [(Div, 3), (Sub, 1)]+--+-- More generally, duplicate entries are accumulated as follows;+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f k d (f k c (f k b a)))]+--+-- @since 0.2.11+fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty+{-# INLINE fromListWithKey #-}++------------------------------------------------------------------------+-- Array operations++updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0)+  where+    go !k !ary !i !n+        | i >= n    = ary+        | otherwise = case A.index ary i of+            (L kx y) | k == kx   -> let !v' = f y in A.update ary i (L k v')+                     | otherwise -> go k ary (i+1) n+{-# INLINABLE updateWith #-}++-- | Append the given key and value to the array. If the key is+-- already present, instead update the value of the key by applying+-- the given function to the new and old value (in that order). The+-- value is always evaluated to WHNF before being inserted into the+-- array.+updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v)+                 -> A.Array (Leaf k v)+updateOrSnocWith f = updateOrSnocWithKey (const f)+{-# INLINABLE updateOrSnocWith #-}++-- | Append the given key and value to the array. If the key is+-- already present, instead update the value of the key by applying+-- the given function to the new and old value (in that order). The+-- value is always evaluated to WHNF before being inserted into the+-- array.+updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v)+                 -> A.Array (Leaf k v)+updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0)+  where+    go !k v !ary !i !n+        | i >= n = A.run $ do+            -- Not found, append to the end.+            mary <- A.new_ (n + 1)+            A.copy ary 0 mary 0 n+            let !l = v `seq` (L k v)+            A.write mary n l+            return mary+        | otherwise = case A.index ary i of+            (L kx y) | k == kx   -> let !v' = f k v y in A.update ary i (L k v')+                     | otherwise -> go k v ary (i+1) n+{-# INLINABLE updateOrSnocWithKey #-}++------------------------------------------------------------------------+-- Smart constructors+--+-- These constructors make sure the value is in WHNF before it's+-- inserted into the constructor.++leaf :: Hash -> k -> v -> HashMap k v+leaf h k = \ !v -> Leaf h (L k v)+{-# INLINE leaf #-}
+ src/Data/Strict/HashMap/Autogen/Internal/Unsafe.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}++#if !MIN_VERSION_base(4,9,0)+{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++-- | = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- This module exports a workaround for this bug:+--+--    http://hackage.haskell.org/trac/ghc/ticket/5916+--+-- Please read the comments in ghc/libraries/base/GHC/ST.lhs to+-- understand what's going on here.+--+-- Code that uses this module should be compiled with -fno-full-laziness+module Data.Strict.HashMap.Autogen.Internal.Unsafe+    ( runST+    ) where++#if MIN_VERSION_base(4,9,0)+-- The GHC issue was fixed in GHC 8.0/base 4.9+import Control.Monad.ST++#else++import GHC.Base (realWorld#)+import qualified GHC.ST as ST++-- | Return the value computed by a state transformer computation.+-- The @forall@ ensures that the internal state used by the 'ST'+-- computation is inaccessible to the rest of the program.+runST :: (forall s. ST.ST s a) -> a+runST st = runSTRep (case st of { ST.ST st_rep -> st_rep })+{-# INLINE runST #-}++runSTRep :: (forall s. ST.STRep s a) -> a+runSTRep st_rep = case st_rep realWorld# of+                        (# _, r #) -> r+{-# INLINE [0] runSTRep #-}+#endif
+ src/Data/Strict/HashMap/Autogen/Strict.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE Safe #-}++------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.HashMap.Autogen.Strict+-- Copyright   :  2010-2012 Johan Tibell+-- License     :  BSD-style+-- Maintainer  :  johan.tibell@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- A map from /hashable/ keys to values.  A map cannot contain+-- duplicate keys; each key can map to at most one value.  A 'HashMap'+-- makes no guarantees as to the order of its elements.+--+-- The implementation is based on /hash array mapped tries/.  A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings.+--+-- Many operations have a average-case complexity of /O(log n)/.  The+-- implementation uses a large base (i.e. 16) so in practice these+-- operations are constant time.+module Data.Strict.HashMap.Autogen.Strict+    (+      -- * Strictness properties+      -- $strictness++      HashMap++      -- * Construction+    , empty+    , singleton++      -- * Basic interface+    , null+    , size+    , member+    , lookup+    , (!?)+    , findWithDefault+    , lookupDefault+    , (!)+    , insert+    , insertWith+    , delete+    , adjust+    , update+    , alter+    , alterF+    , isSubmapOf+    , isSubmapOfBy++      -- * Combine+      -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions++    -- ** Compose+    , compose++      -- * Transformations+    , map+    , mapWithKey+    , traverseWithKey++      -- * Difference and intersection+    , difference+    , differenceWith+    , intersection+    , intersectionWith+    , intersectionWithKey++      -- * Folds+    , foldMapWithKey+    , foldr+    , foldl+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'+    , foldrWithKey+    , foldlWithKey++      -- * Filter+    , filter+    , filterWithKey+    , mapMaybe+    , mapMaybeWithKey++      -- * Conversions+    , keys+    , elems++      -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey+    ) where++import Data.Strict.HashMap.Autogen.Internal.Strict as HM+import Prelude ()++-- $strictness+--+-- This module satisfies the following strictness properties:+--+-- 1. Key arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+--    the map.
+ src/Data/Strict/HashMap/Internal.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Strict.HashMap.Internal where++import Data.HashMap.Lazy                  as L+import Data.Strict.HashMap.Autogen.Strict as S++import Data.Binary+import Data.Hashable+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex+import Data.Strict.Classes++instance (Eq k, Hashable k) => Strict (L.HashMap k v) (S.HashMap k v) where+  toStrict = S.fromList . L.toList+  toLazy = L.fromList . S.toList+  {-# INLINE toStrict #-}+  {-# INLINE toLazy #-}++-- code copied from indexed-traversable-instances++instance FunctorWithIndex k (S.HashMap k) where+  imap = S.mapWithKey+  {-# INLINE imap #-}++instance FoldableWithIndex k (S.HashMap k) where+  ifoldr  = S.foldrWithKey+  {-# INLINE ifoldr #-}+  ifoldl' = S.foldlWithKey' . flip+  {-# INLINE ifoldl' #-}++instance TraversableWithIndex k (S.HashMap k) where+  itraverse = S.traverseWithKey+  {-# INLINE itraverse #-}++-- code copied from binary-instances++instance (Hashable k, Eq k, Binary k, Binary v) => Binary (S.HashMap k v) where+    get = fmap S.fromList get+    put = put . S.toList
+ src/Data/Strict/HashSet.hs view
@@ -0,0 +1,10 @@+{- | Module alias of "Data.HashSet"++This module re-exports "Data.HashSet" for convenience, so that you can avoid an+additional direct dependency on @containers@ if you want to.+-}+module Data.Strict.HashSet+  ( module Data.HashSet+  ) where++import Data.HashSet
+ src/Data/Strict/IntMap.hs view
@@ -0,0 +1,20 @@+{- | Fully-strict version of "Data.IntMap.Strict"++Unlike @Data.IntMap.Strict@ t'Data.IntMap.Strict.IntMap' which is an alias to+@Data.IntMap.Lazy@ t'Data.IntMap.Lazy.IntMap', the instances of our {- haddock+ #1251 -} t'Data.Strict.IntMap.IntMap' are all strict as well.++You should be able to switch from the former simply by changing your module+imports, and your package dependency from @containers@ to @strict-containers@.+If this doesn't work, please file a bug.++The documentation in the auto-generated modules have not been updated in a+particularly sophisticated way, so may sound weird or contradictory. In those+cases, please re-interpret such weird wording in the context of the above.+-}+module Data.Strict.IntMap+  ( module Data.Strict.IntMap.Autogen.Strict+  ) where++import Data.Strict.IntMap.Internal+import Data.Strict.IntMap.Autogen.Strict
+ src/Data/Strict/IntMap/Autogen/Internal.hs view
@@ -0,0 +1,3579 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+#endif+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE TypeFamilies #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.IntMap.Autogen.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+--                (c) wren romano 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- This defines the data structures and core (hidden) manipulations+-- on representations.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntMap matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.++module Data.Strict.IntMap.Autogen.Internal (+    -- * Map type+      IntMap(..), Key          -- instance Eq,Show++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , disjoint++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , 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++    -- ** Deprecated general combining function+    , mergeWithKey+    , mergeWithKey'++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * 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++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internal types+    , Mask, Prefix, Nat++    -- * Utility+    , natFromInt+    , intFromNat+    , link+    , linkWithMask+    , bin+    , binCheckLeft+    , binCheckRight+    , zero+    , nomatch+    , match+    , mask+    , maskW+    , shorter+    , branchMask+    , highestBitMask++    -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict"+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity (..))+import Control.Applicative (liftA2)+#else+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2)+import Data.Monoid (Monoid(..))+import Data.Traversable (Traversable(traverse))+import Data.Word (Word)+#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+#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)++import Data.IntSet.Internal (Key)+import qualified Data.IntSet.Internal as IntSet+import Data.Strict.ContainersUtils.Autogen.BitUtil+import Data.Strict.ContainersUtils.Autogen.StrictPair++#if __GLASGOW_HASKELL__+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),+                  DataType, mkDataType)+import GHC.Exts (build)+#if !MIN_VERSION_base(4,8,0)+import Data.Functor ((<$))+#endif+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif+import Text.Read+#endif+import qualified Control.Category as Category+#if __GLASGOW_HASKELL__ >= 709+import Data.Coerce+#endif+++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++natFromInt :: Key -> Nat+natFromInt = fromIntegral+{-# INLINE natFromInt #-}++intFromNat :: Nat -> Key+intFromNat = fromIntegral+{-# INLINE intFromNat #-}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+++-- | A map of integers to values @a@.++-- See Note: Order of constructors+data IntMap a = Bin {-# UNPACK #-} !Prefix+                    {-# UNPACK #-} !Mask+                    !(IntMap a)+                    !(IntMap a)+-- Fields:+--   prefix: The most significant bits shared by all keys in this Bin.+--   mask: The switching bit to determine if a key should follow the left+--         or right subtree of a 'Bin'.+-- Invariant: Nil is never found as a child of Bin.+-- Invariant: The Mask is a power of 2. It is the largest bit position at which+--            two keys of the map differ.+-- Invariant: Prefix is the common high-order bits that all elements share to+--            the left of the Mask bit.+-- 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.+              | Tip {-# UNPACK #-} !Key !a+              | Nil++type Prefix = Int+type Mask   = Int+++-- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type IntSetPrefix = Int+type IntSetBitMap = Word++bitmapOf :: Int -> IntSetBitMap+bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)+{-# INLINE bitmapOf #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | /O(min(n,W))/. Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: IntMap a -> Key -> a+(!) m k = find k m++-- | /O(min(n,W))/. Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'+--+-- @since 0.5.11++(!?) :: IntMap a -> Key -> Maybe a+(!?) m k = lookup k m++-- | Same as 'difference'.+(\\) :: IntMap a -> IntMap b -> IntMap a+m1 \\ m2 = difference m1 m2++infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++instance Monoid (IntMap a) where+    mempty  = empty+    mconcat = unions+#if !(MIN_VERSION_base(4,9,0))+    mappend = union+#else+    mappend = (<>)++-- | @since 0.5.7+instance Semigroup (IntMap a) where+    (<>)    = union+    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 _ m l r)+            | m < 0     = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Nil = mempty+          go (Tip _ v) = f v+          go (Bin _ m l r)+            | m < 0     = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+#if MIN_VERSION_base(4,8,0)+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= IntMap.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Nil = False+          go x (Tip _ y) = x == y+          go x (Bin _ _ l r) = go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Nil = error "Data.Foldable.maximum (for Data.Strict.IntMap.Autogen): empty map"+          start (Tip _ y) = y+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = max m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Nil = error "Data.Foldable.minimum (for Data.Strict.IntMap.Autogen): empty map"+          start (Tip _ y) = y+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = min m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}+#endif++-- | Traverses in order of increasing key.+instance Traversable IntMap where+    traverse f = traverseWithKey (\_ -> f)+    {-# INLINE traverse #-}++instance NFData a => NFData (IntMap a) where+    rnf Nil = ()+    rnf (Tip _ v) = rnf v+    rnf (Bin _ _ l r) = rnf l `seq` rnf r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data a => Data (IntMap a) where+  gfoldl f z im = z fromList `f` (toList im)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intMapDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix++intMapDataType :: DataType+intMapDataType = mkDataType "Data.Strict.IntMap.Autogen.Internal.IntMap" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+--+-- > Data.Strict.IntMap.Autogen.null (empty)           == True+-- > Data.Strict.IntMap.Autogen.null (singleton 1 'a') == False++null :: IntMap a -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | /O(n)/. Number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: IntMap a -> Int+size = go 0+  where+    go !acc (Bin _ _ l r) = go (go acc l) r+    go acc (Tip _ _) = 1 + acc+    go acc Nil = acc++-- | /O(min(n,W))/. Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++-- See Note: Local 'go' functions and capturing]+member :: Key -> IntMap a -> Bool+member !k = go+  where+    go (Bin p m l r) | nomatch k p m = False+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx _) = k == kx+    go Nil = False++-- | /O(min(n,W))/. Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> IntMap a -> Bool+notMember k m = not $ member k m++-- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.++-- See Note: Local 'go' functions and capturing]+lookup :: Key -> IntMap a -> Maybe a+lookup !k = go+  where+    go (Bin p m l r) | nomatch k p m = Nothing+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = Just x+                  | otherwise = Nothing+    go Nil = Nothing+++-- See Note: Local 'go' functions and capturing]+find :: Key -> IntMap a -> a+find !k = go+  where+    go (Bin p m l r) | nomatch k p m = not_found+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = not_found+    go Nil = not_found++    not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")++-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def !k = go+  where+    go (Bin p m l r) | nomatch k p m = def+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++-- | /O(log n)/. Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntMap a -> Maybe (Key, a)+lookupLT !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r+      | zero k m  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k <= ky   = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | /O(log n)/. Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntMap a -> Maybe (Key, a)+lookupGT !k t = 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 unsafeFindMin l else unsafeFindMin def+      | zero k m  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k >= ky   = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def++-- | /O(log n)/. Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > 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')++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntMap a -> Maybe (Key, a)+lookupLE !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r+      | zero k m  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k < ky    = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | /O(log n)/. Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > 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++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntMap a -> Maybe (Key, a)+lookupGE !k t = 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 unsafeFindMin l else unsafeFindMin def+      | zero k m  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k > ky    = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def+++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntMap a -> Maybe (Key, a)+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip ky y) = Just (ky, y)+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntMap a -> Maybe (Key, a)+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip ky y) = Just (ky, y)+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | /O(n+m)/. Check whether the key sets of two maps are disjoint+-- (i.e. their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- > disjoint a b == null (intersection a b)+--+-- @since 0.6.2.1+disjoint :: IntMap a -> IntMap b -> Bool+disjoint Nil _ = True+disjoint _ Nil = True+disjoint (Tip kx _) ys = notMember kx ys+disjoint xs (Tip ky _) = notMember ky xs+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2 = disjoint1+  | shorter m2 m1 = disjoint2+  | p1 == p2      = disjoint l1 l2 && disjoint r1 r2+  | otherwise     = True+  where+    disjoint1 | nomatch p2 p1 m1 = True+              | zero p2 m1       = disjoint l1 t2+              | otherwise        = disjoint r1 t2+    disjoint2 | nomatch p1 p2 m2 = True+              | zero p1 m2       = disjoint t1 l2+              | otherwise        = disjoint t1 r2++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.Strict.IntMap.Autogen.Strict" exposed a version of+-- 'compose' that forced the values of the output 'IntMap'. This version does+-- not force these values.+--+-- @since 0.6.3.1+compose :: IntMap c -> IntMap Int -> IntMap c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: IntMap a+empty+  = Nil+{-# INLINE empty #-}++-- | /O(1)/. A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> IntMap a+singleton k x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > 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'++insert :: Key -> a -> IntMap a -> IntMap a+insert !k x t@(Bin p m l r)+  | nomatch k p m = link k (Tip k x) p t+  | zero k m      = Bin p m (insert k x l) r+  | otherwise     = Bin p m l (insert k x r)+insert k x t@(Tip ky _)+  | k==ky         = Tip k x+  | otherwise     = link k (Tip k x) ky t+insert k x Nil = Tip k x++-- right-biased insertion, used by 'union'+-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > 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"++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > 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"++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f !k x t@(Bin p m l r)+  | nomatch k p m = link k (Tip k x) p t+  | zero k m      = Bin p m (insertWithKey f k x l) r+  | otherwise     = Bin p m l (insertWithKey f k x r)+insertWithKey f k x t@(Tip ky y)+  | k == ky       = Tip k (f k x y)+  | otherwise     = link k (Tip k x) ky t+insertWithKey _ k x Nil = Tip k x++-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|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")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f !k x t@(Bin p m l r)+  | nomatch k p m = (Nothing,link k (Tip k x) p t)+  | zero k m      = let (found,l') = insertLookupWithKey f k x l+                    in (found,Bin p m l' r)+  | otherwise     = let (found,r') = insertLookupWithKey f k x r+                    in (found,Bin p m l r')+insertLookupWithKey f k x t@(Tip ky y)+  | k == ky       = (Just y,Tip k (f k x y))+  | otherwise     = (Nothing,link k (Tip k x) ky t)+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > 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++delete :: Key -> IntMap a -> IntMap a+delete !k t@(Bin p m l r)+  | nomatch k p m = t+  | zero k m      = binCheckLeft p m (delete k l) r+  | otherwise     = binCheckRight p m l (delete k r)+delete k t@(Tip ky _)+  | k == ky       = Nil+  | otherwise     = t+delete _k Nil = Nil++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > 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++adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > 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++adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f !k t@(Bin p m l r)+  | nomatch k p m = t+  | zero k m      = Bin p m (adjustWithKey f k l) r+  | otherwise     = Bin p m l (adjustWithKey f k r)+adjustWithKey f k t@(Tip ky y)+  | k == ky       = Tip ky (f k y)+  | otherwise     = t+adjustWithKey _ _ Nil = Nil+++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > 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"++update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f+  = updateWithKey (\_ x -> f x)++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f !k t@(Bin p m l r)+  | nomatch k p m = t+  | zero k m      = binCheckLeft p m (updateWithKey f k l) r+  | otherwise     = binCheckRight p m l (updateWithKey f k r)+updateWithKey f k t@(Tip ky y)+  | k == ky       = case (f k y) of+                      Just y' -> Tip ky y'+                      Nothing -> Nil+  | otherwise     = t+updateWithKey _ _ Nil = Nil++-- | /O(min(n,W))/. Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f !k t@(Bin p m l r)+  | nomatch k p m = (Nothing,t)+  | zero k m      = let !(found,l') = updateLookupWithKey f k l+                    in (found,binCheckLeft p m l' r)+  | otherwise     = let !(found,r') = updateLookupWithKey f k r+                    in (found,binCheckRight p m l r')+updateLookupWithKey f k t@(Tip ky y)+  | k==ky         = case (f k y) of+                      Just y' -> (Just y,Tip ky y')+                      Nothing -> (Just y,Nil)+  | otherwise     = (Nothing,t)+updateLookupWithKey _ _ Nil = (Nothing,Nil)++++-- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f !k t@(Bin p m l r)+  | nomatch k p m = case f Nothing of+                      Nothing -> t+                      Just x -> link k (Tip k x) p t+  | zero k m      = binCheckLeft p m (alter f k l) r+  | otherwise     = binCheckRight p m l (alter f k r)+alter f k t@(Tip ky y)+  | k==ky         = case f (Just y) of+                      Just x -> Tip ky x+                      Nothing -> Nil+  | otherwise     = case f Nothing of+                      Just x -> link k (Tip k x) ky t+                      Nothing -> Tip ky y+alter f k Nil     = case f Nothing of+                      Just x -> Tip k x+                      Nothing -> Nil++-- | /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 an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap 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.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)+-- This implementation was stolen from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just v' -> insert k v' m+  where mv = lookup k m++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > 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")]++unions :: Foldable f => f (IntMap a) -> IntMap a+unions xs+  = Foldable.foldl' union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | /O(n+m)/. The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: IntMap a -> IntMap a -> IntMap a+union m1 m2+  = mergeWithKey' Bin const id id m1 m2++-- | /O(n+m)/. The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: IntMap a -> IntMap b -> IntMap a+difference m1 m2+  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2++-- | /O(n+m)/. Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2+++-- TODO(wrengr): re-verify that asymptotic bound+-- | /O(n+m)/. Remove all the keys in a given set from a map.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m+-- @+--+-- @since 0.5.8+withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a+withoutKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)+    | shorter m1 m2  = difference1+    | shorter m2 m1  = difference2+    | p1 == p2       = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)+    | otherwise      = t1+    where+    difference1+        | nomatch p2 p1 m1  = t1+        | zero p2 m1        = binCheckLeft p1 m1 (withoutKeys l1 t2) r1+        | otherwise         = binCheckRight p1 m1 l1 (withoutKeys r1 t2)+    difference2+        | nomatch p1 p2 m2  = t1+        | zero p1 m2        = withoutKeys t1 l2+        | otherwise         = withoutKeys t1 r2+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` 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)+withoutKeys t1@(Bin _ _ _ _) IntSet.Nil = t1+withoutKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = Nil+    | otherwise = t1+withoutKeys Nil _ = Nil+++updatePrefix+    :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a+updatePrefix !kp t@(Bin p m l r) f+    | m .&. IntSet.suffixBitMask /= 0 =+        if p .&. IntSet.prefixBitMask == kp then f t else t+    | nomatch kp p m = t+    | zero kp m      = binCheckLeft p m (updatePrefix kp l f) r+    | otherwise      = binCheckRight p m l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+    | kx .&. IntSet.prefixBitMask == kp = f t+    | otherwise = t+updatePrefix _ Nil _ = Nil+++withoutBM :: IntSetBitMap -> IntMap a -> IntMap a+withoutBM 0 t = t+withoutBM bm (Bin p m l r) =+    let leftBits = bitmapOf (p .|. m) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p m (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil+    | otherwise = t+withoutBM _ Nil = Nil+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: IntMap a -> IntMap b -> IntMap a+intersection m1 m2+  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2+++-- TODO(wrengr): re-verify that asymptotic bound+-- | /O(n+m)/. The restriction of a map to the keys in a set.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m+-- @+--+-- @since 0.5.8+restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a+restrictKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)+    | shorter m1 m2  = intersection1+    | shorter m2 m1  = intersection2+    | p1 == p2       = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)+    | otherwise      = Nil+    where+    intersection1+        | nomatch p2 p1 m1  = Nil+        | zero p2 m1        = restrictKeys l1 t2+        | otherwise         = restrictKeys r1 t2+    intersection2+        | nomatch p1 p2 m2  = Nil+        | zero p1 m2        = restrictKeys t1 l2+        | otherwise         = restrictKeys t1 r2+restrictKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =+    let minbit = bitmapOf p1+        ge_minbit = complement (minbit - 1)+        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+        le_maxbit = maxbit .|. (maxbit - 1)+    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+    -- and 'restrictBM' here, in order to avoid redundant case analyses?+    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _ _) IntSet.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = t1+    | otherwise = Nil+restrictKeys Nil _ = Nil+++-- | /O(min(n,W))/. Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a+lookupPrefix !kp t@(Bin p m l r)+    | m .&. IntSet.suffixBitMask /= 0 =+        if p .&. IntSet.prefixBitMask == kp then t else Nil+    | nomatch kp p m = Nil+    | zero kp m      = lookupPrefix kp l+    | otherwise      = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+    | (kx .&. IntSet.prefixBitMask) == kp = t+    | otherwise = Nil+lookupPrefix _ Nil = Nil+++restrictBM :: IntSetBitMap -> IntMap a -> IntMap a+restrictBM 0 _ = Nil+restrictBM bm (Bin p m l r) =+    let leftBits = bitmapOf (p .|. m) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p m (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t+    | otherwise = Nil+restrictBM _ Nil = Nil+++-- | /O(n+m)/. The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | /O(n+m)/. A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+             -> IntMap a -> IntMap b -> IntMap c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) ->+          case f k1 x1 x2 of+            Nothing -> Nil+            Just x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++-- Slightly more general version of mergeWithKey. It differs in the following:+--+-- * the combining function operates on maps instead of keys and values. The+--   reason is to enable sharing in union, difference and intersection.+--+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,+--   Bin constructor can be used, because we know both subtrees are nonempty.++mergeWithKey' :: (Prefix -> Mask -> IntMap c -> IntMap c -> IntMap c)+              -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+              -> IntMap a -> IntMap b -> IntMap c+mergeWithKey' bin' f g1 g2 = go+  where+    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+      | shorter m1 m2  = merge1+      | shorter m2 m1  = merge2+      | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)+      where+        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)+               | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)+               | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)+        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)+               | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)+               | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)++    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'+      where+        merge0 t2 k2 t1@(Bin p1 m1 l1 r1)+          | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)+          | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)+          | otherwise  = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)+        merge0 t2 k2 t1@(Tip k1 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t2 _  Nil = g2 t2++    go t1@(Bin _ _ _ _) Nil = g1 t1++    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'+      where+        merge0 t1 k1 t2@(Bin p2 m2 l2 r2)+          | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)+          | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)+          | otherwise  = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)+        merge0 t1 k1 t2@(Tip k2 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t1 _  Nil = g1 t1++    go Nil t2 = g2 t2++    maybe_link _ Nil _ t2 = t2+    maybe_link _ t1 _ Nil = t1+    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2+    {-# INLINE maybe_link #-}+{-# INLINE mergeWithKey' #-}+++{--------------------------------------------------------------------+  mergeA+--------------------------------------------------------------------}++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f k x z@ is an abstract representation+-- of a function of type @Key -> x -> f (Maybe z)@.+--+-- @since 0.5.9++data WhenMissing f x y = WhenMissing+  { missingSubtree :: IntMap x -> f (IntMap y)+  , missingKey :: Key -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)+  where+    id = preserveMissing+    f . g =+      traverseMaybeMissing $ \ k x -> do+        y <- missingKey g k x+        case y of+          Nothing -> pure Nothing+          Just q  -> missingKey f k q+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey f k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where+#if !MIN_VERSION_base(4,8,0)+  return = pure+#endif+  m >>= f =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey m k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> missingKey (f r) k x+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+  :: (Applicative f, Monad f)+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}+++-- | Map covariantly over a @'WhenMissing' f x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMissing+  :: Functor f+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapGentlyWhenMissing f t = WhenMissing+  { missingSubtree = \m -> fmap f <$> missingSubtree t m+  , missingKey     = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}+++-- | Map covariantly over a @'WhenMatched' f k x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapGentlyWhenMatched f t =+  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}+++-- | Map contravariantly over a @'WhenMissing' f _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey     = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}+++-- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched+  :: (b -> a)+  -> WhenMatched f a y z+  -> WhenMatched f b y z+contramapFirstWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}+++-- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched+  :: (b -> a)+  -> WhenMatched f x a z+  -> WhenMatched f x b z+contramapSecondWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}+++#if !MIN_VERSION_base(4,8,0)+newtype Identity a = Identity {runIdentity :: a}++instance Functor Identity where+    fmap f (Identity x) = Identity (f x)++instance Applicative Identity where+    pure = Identity+    Identity f <*> Identity x = Identity (f x)+#endif++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge'.+--+-- A tactic of type @SimpleWhenMissing x z@ is an abstract+-- representation of a function of type @Key -> x -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity+++-- | A tactic for dealing with keys present in both maps in 'merge'+-- or 'mergeA'.+--+-- A tactic of type @WhenMatched f x y z@ is an abstract representation+-- of a function of type @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+newtype WhenMatched f x y z = WhenMatched+  { matchedKey :: Key -> x -> y -> f (Maybe z) }+++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}+++-- | Along with traverseMaybeMissing, witnesses the isomorphism+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}+++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)+  where+    id = zipWithMatched (\_ _ y -> y)+    f . g =+      zipWithMaybeAMatched $ \k x y -> do+        res <- runWhenMatched g k x y+        case res of+          Nothing -> pure Nothing+          Just r  -> runWhenMatched f k x r+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched fs k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where+#if !MIN_VERSION_base(4,8,0)+  return = pure+#endif+  m >>= f =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched m k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9+mapWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapWhenMatched f (WhenMatched g) =+  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}+++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract+-- representation of a function of type @Key -> x -> y -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity+++-- | 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+-- >   :: (Key -> x -> y -> z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+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 #-}+++-- | 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.+--+-- @since 0.5.9+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 maybe use the result in the merged map.+--+-- > zipWithMaybeMatched+-- >   :: (Key -> x -> y -> Maybe z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMaybeMatched+  :: Applicative f+  => (Key -> x -> y -> Maybe z)+  -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ 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.+--+-- @since 0.5.9+zipWithMaybeAMatched+  :: (Key -> x -> y -> f (Maybe z))+  -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}+++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- > dropMissing :: SimpleWhenMissing x y+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Nil)+  , missingKey     = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}+++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- > preserveMissing :: SimpleWhenMissing x x+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingKey     = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}+++-- | Map over the entries whose keys are missing from the other map.+--+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+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 #-}+++-- | 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 :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'+-- operations.+--+-- @since 0.5.9+mapMaybeMissing+  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey     = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}+++-- | Filter the entries whose keys are missing from the other map.+--+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing+  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}+++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- >   \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing+  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}+++-- | /O(n)/. Filter keys and values using an 'Applicative' predicate.+filterWithKeyA+  :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)+filterWithKeyA _ Nil           = pure Nil+filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x+filterWithKeyA f (Bin p m l r)+  | m < 0     = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)+  | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t+++-- | Traverse over the entries whose keys are missing from the other+-- map.+--+-- @since 0.5.9+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 #-}+++-- | 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.+--+-- @since 0.5.9+traverseMaybeMissing+  :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}+++-- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+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)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)+++-- | Merge two maps.+--+-- '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'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- 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"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use+-- 'merge' to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge diffPreserve diffDrop f+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)+--+-- @since 0.5.9+merge+  :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@+  -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@+  -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> IntMap a -- ^ Map @m1@+  -> IntMap b -- ^ Map @m2@+  -> IntMap c+merge g1 g2 f m1 m2 =+  runIdentity $ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}+++-- | An applicative version of 'merge'.+--+-- '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'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'mergeA' will first \"align\" these maps by key:+--+-- @+-- 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"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f)+  => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> IntMap a -- ^ Map @m1@+  -> IntMap b -- ^ Map @m2@+  -> f (IntMap c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t, missingKey = g2k}+    WhenMatched{matchedKey = f}+    = go+  where+    go t1  Nil = g1t t1+    go Nil t2  = g2t t2++    -- This case is already covered below.+    -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2++    go (Tip k1 x1) t2' = merge2 t2'+      where+        merge2 t2@(Bin p2 m2 l2 r2)+          | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)+          | zero k1 m2       = binA p2 m2 (merge2 l2) (g2t r2)+          | otherwise        = binA p2 m2 (g2t l2) (merge2 r2)+        merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2+        merge2 Nil           = subsingletonBy g1k k1 x1++    go t1' (Tip k2 x2) = merge1 t1'+      where+        merge1 t1@(Bin p1 m1 l1 r1)+          | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)+          | zero k2 m1       = binA p1 m1 (merge1 l1) (g1t r1)+          | otherwise        = binA p1 m1 (g1t l1) (merge1 r1)+        merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2+        merge1 Nil           = subsingletonBy g2k k2 x2++    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+      | shorter m1 m2  = merge1+      | shorter m2 m1  = merge2+      | p1 == p2       = binA p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = linkA p1 (g1t t1) p2 (g2t t2)+      where+        merge1 | nomatch p2 p1 m1  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p2 m1        = binA p1 m1 (go  l1 t2) (g1t r1)+               | otherwise         = binA p1 m1 (g1t l1)    (go  r1 t2)+        merge2 | nomatch p1 p2 m2  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p1 m2        = binA p2 m2 (go  t1 l2) (g2t    r2)+               | otherwise         = binA p2 m2 (g2t    l2) (go  t1 r2)++    subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x+    {-# INLINE subsingletonBy #-}++    mergeTips k1 x1 k2 x2+      | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2+      | k1 <  k2  = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)+        {-+        = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2+        -}+      | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)+    {-# INLINE mergeTips #-}++    subdoubleton _ _   Nothing Nothing     = Nil+    subdoubleton _ k2  Nothing (Just y2)   = Tip k2 y2+    subdoubleton k1 _  (Just y1) Nothing   = Tip k1 y1+    subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)+    {-# INLINE subdoubleton #-}++    -- | A variant of 'link_' which makes sure to execute side-effects+    -- in the right order.+    linkA+        :: Applicative f+        => Prefix -> f (IntMap a)+        -> Prefix -> f (IntMap a)+        -> f (IntMap a)+    linkA p1 t1 p2 t2+      | zero p1 m = binA p m t1 t2+      | otherwise = binA p m t2 t1+      where+        m = branchMask p1 p2+        p = mask p1 m+    {-# INLINE linkA #-}++    -- A variant of 'bin' that ensures that effects for negative keys are executed+    -- first.+    binA+        :: Applicative f+        => Prefix+        -> Mask+        -> f (IntMap a)+        -> f (IntMap a)+        -> f (IntMap a)+    binA p m a b+      | m < 0     = liftA2 (flip (bin p m)) b a+      | otherwise = liftA2       (bin p m)  a b+    {-# INLINE binA #-}+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | /O(min(n,W))/. Update the value at the minimal key.+--+-- > 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"++updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMinWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMinWithKey Nil"++-- | /O(min(n,W))/. Update the value at the maximal key.+--+-- > 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"++updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMaxWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMaxWithKey Nil"+++data View a = View {-# UNPACK #-} !Key a !(IntMap a)++-- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+maxViewWithKey t = case t of+  Nil -> Nothing+  _ -> Just $ case maxViewWithKeySure t of+                View k v t' -> ((k, v), t')+{-# INLINE maxViewWithKey #-}++maxViewWithKeySure :: IntMap a -> View a+maxViewWithKeySure t =+  case t of+    Nil -> error "maxViewWithKeySure Nil"+    Bin p m l r | m < 0 ->+      case go l of View k a l' -> View k a (binCheckLeft p m l' r)+    _ -> go t+  where+    go (Bin p m l r) =+        case go r of View k a r' -> View k a (binCheckRight p m l r')+    go (Tip k y) = View k y Nil+    go Nil = error "maxViewWithKey_go Nil"+-- See note on NOINLINE at minViewWithKeySure+{-# NOINLINE maxViewWithKeySure #-}++-- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+minViewWithKey t =+  case t of+    Nil -> Nothing+    _ -> Just $ case minViewWithKeySure t of+                  View k v t' -> ((k, v), t')+-- We inline this to give GHC the best possible chance of+-- getting rid of the Maybe, pair, and Int constructors, as+-- well as a thunk under the Just. That is, we really want to+-- be certain this inlines!+{-# INLINE minViewWithKey #-}++minViewWithKeySure :: IntMap a -> View a+minViewWithKeySure t =+  case t of+    Nil -> error "minViewWithKeySure Nil"+    Bin p m l r | m < 0 ->+      case go r of+        View k a r' -> View k a (binCheckRight p m l r')+    _ -> go t+  where+    go (Bin p m l r) =+        case go l of View k a l' -> View k a (binCheckLeft p m l' r)+    go (Tip k y) = View k y Nil+    go Nil = error "minViewWithKey_go Nil"+-- There's never anything significant to be gained by inlining+-- this. Sufficiently recent GHC versions will inline the wrapper+-- anyway, which should be good enough.+{-# NOINLINE minViewWithKeySure #-}++-- | /O(min(n,W))/. Update the value at the maximal key.+--+-- > 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"++updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | /O(min(n,W))/. Update the value at the minimal key.+--+-- > 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"++updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)++-- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: IntMap a -> Maybe (a, IntMap a)+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)++-- | /O(min(n,W))/. Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: IntMap a -> Maybe (a, IntMap a)+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)++-- | /O(min(n,W))/. Delete and find the maximal element.+-- This function throws an error if the map is empty. Use 'maxViewWithKey'+-- if the map may be empty.+deleteFindMax :: IntMap a -> ((Key, a), IntMap a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey++-- | /O(min(n,W))/. Delete and find the minimal element.+-- This function throws an error if the map is empty. Use 'minViewWithKey'+-- if the map may be empty.+deleteFindMin :: IntMap a -> ((Key, a), IntMap a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey++-- | /O(min(n,W))/. The minimal key of the map. Returns 'Nothing' if the map is empty.+lookupMin :: IntMap a -> Maybe (Key, a)+lookupMin Nil = Nothing+lookupMin (Tip k v) = Just (k,v)+lookupMin (Bin _ m l r)+  | m < 0     = go r+  | otherwise = go l+    where go (Tip k v)      = Just (k,v)+          go (Bin _ _ l' _) = go l'+          go Nil            = Nothing++-- | /O(min(n,W))/. The minimal key of the map. Calls 'error' if the map is empty.+-- Use 'minViewWithKey' if the map may be empty.+findMin :: IntMap a -> (Key, a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty map has no minimal element"++-- | /O(min(n,W))/. The maximal key of the map. Returns 'Nothing' if the map is empty.+lookupMax :: IntMap a -> Maybe (Key, a)+lookupMax Nil = Nothing+lookupMax (Tip k v) = Just (k,v)+lookupMax (Bin _ m l r)+  | m < 0     = go l+  | otherwise = go r+    where go (Tip k v)      = Just (k,v)+          go (Bin _ _ _ r') = go r'+          go Nil            = Nothing++-- | /O(min(n,W))/. The maximal key of the map. Calls 'error' if the map is empty.+-- Use 'maxViewWithKey' if the map may be empty.+findMax :: IntMap a -> (Key, a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty map has no maximal element"++-- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.+deleteMin :: IntMap a -> IntMap a+deleteMin = maybe Nil snd . minView++-- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.+deleteMax :: IntMap a -> IntMap a+deleteMax = maybe Nil snd . maxView+++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isProperSubmapOf m1 m2+  = isProperSubmapOfBy (==) m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isProperSubmapOfBy predicate t1 t2+  = case submapCmp predicate t1 t2 of+      LT -> True+      _  -> False++submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering+submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = submapCmpLt+  | p1 == p2       = submapCmpEq+  | otherwise      = GT  -- disjoint+  where+    submapCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = submapCmp predicate t1 l2+                | otherwise         = submapCmp predicate t1 r2+    submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++submapCmp _         (Bin _ _ _ _) _  = GT+submapCmp predicate (Tip kx x) (Tip ky y)+  | (kx == ky) && predicate x y = EQ+  | otherwise                   = GT  -- disjoint+submapCmp predicate (Tip k x) t+  = case lookup k t of+     Just y | predicate x y -> LT+     _                      -> GT -- disjoint+submapCmp _    Nil Nil = EQ+submapCmp _    Nil _   = LT++-- | /O(n+m)/. Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isSubmapOf m1 m2+  = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 &&+                       if zero p1 m2+                       then isSubmapOfBy predicate t1 l2+                       else isSubmapOfBy predicate t1 r2+  | otherwise      = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2+isSubmapOfBy _         (Bin _ _ _ _) _ = False+isSubmapOfBy predicate (Tip k x) t     = case lookup k t of+                                         Just y  -> predicate x y+                                         Nothing -> False+isSubmapOfBy _         Nil _           = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> IntMap a -> IntMap b+map f = go+  where+    go (Bin p m l r) = Bin p m (go l) (go r)+    go (Tip k x)     = Tip k (f x)+    go Nil           = Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not play well with RULES yet.+{-# RULES+"map/coerce" map coerce = coerce+ #-}+#endif++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k (f k x)+      Nil         -> Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | /O(n)/.+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = Tip k <$> f k v+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (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+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+  = case t of+      Bin p m l r+        | m < 0 ->+            let (a1,r') = mapAccumL f a r+                (a2,l') = mapAccumL f a1 l+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,l') = mapAccumL f a l+                (a2,r') = mapAccumL f a1 r+            in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumRWithKey f a t+  = case t of+      Bin p m l r+        | m < 0 ->+            let (a1,l') = mapAccumRWithKey f a l+                (a2,r') = mapAccumRWithKey f a1 r+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,r') = mapAccumRWithKey f a r+                (a2,l') = mapAccumRWithKey f a1 l+            in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | /O(n*min(n,W))/.+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > 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"++mapKeys :: (Key->Key) -> IntMap a -> IntMap a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | /O(n*min(n,W))/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > 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"++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a+mapKeysWith c f+  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | /O(n*min(n,W))/.+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has slightly better performance than 'mapKeys'.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]++mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a+mapKeysMonotonic f+  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy some predicate.+--+-- > 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++filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey predicate = go+    where+    go Nil           = Nil+    go t@(Tip k x)   = if predicate k x then t else Nil+    go (Bin p m l r) = bin p m (go l) (go r)++-- | /O(n)/. Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > 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")])++partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | /O(n)/. Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > 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")])++partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t =+      case t of+        Bin p m l r ->+          let (l1 :*: l2) = go predicate l+              (r1 :*: r2) = go predicate r+          in bin p m l1 r1 :*: bin p m l2 r2+        Tip k x+          | predicate k x -> (t :*: Nil)+          | otherwise     -> (Nil :*: t)+        Nil -> (Nil :*: Nil)++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > 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, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > 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, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p m l r) =+      bin p m l1 r1 :*: bin p m l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left y  -> (Tip k y :*: Nil)+      Right z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++-- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > 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)++split :: Key -> IntMap a -> (IntMap a, IntMap a)+split k t =+  case t of+    Bin _ m l r+      | m < 0 ->+        if k >= 0 -- handle negative numbers.+        then+          case go k l of+            (lt :*: gt) ->+              let !lt' = union r lt+              in (lt', gt)+        else+          case go k r of+            (lt :*: gt) ->+              let !gt' = union gt l+              in (lt, gt')+    _ -> case go k t of+          (lt :*: gt) -> (lt, gt)+  where+    go k' t'@(Bin p m l r)+      | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'+      | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r+      | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt+    go k' t'@(Tip ky _)+      | k' > ky   = (t' :*: Nil)+      | k' < ky   = (Nil :*: t')+      | otherwise = (Nil :*: Nil)+    go _ Nil = (Nil :*: Nil)+++data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a)++mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)+{-# INLINE mapGT #-}++-- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > 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)++splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)+splitLookup k t =+  case+    case t of+      Bin _ m l r+        | m < 0 ->+          if k >= 0 -- handle negative numbers.+          then mapLT (union r) (go k l)+          else mapGT (`union` l) (go k r)+      _ -> go k t+  of SplitLookup lt fnd gt -> (lt, fnd, gt)+  where+    go k' t'@(Bin p m l r)+      | nomatch k' p m =+          if k' > p+          then SplitLookup t' Nothing Nil+          else SplitLookup Nil Nothing t'+      | zero k' m = mapGT (`union` r) (go k' l)+      | otherwise = mapLT (union l) (go k' r)+    go k' t'@(Tip ky y)+      | k' > ky   = SplitLookup t'  Nothing  Nil+      | k' < ky   = SplitLookup Nil Nothing  t'+      | otherwise = SplitLookup Nil (Just y) Nil+    go _ Nil      = SplitLookup Nil Nothing  Nil++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> IntMap a -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip _ x)     = f x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> IntMap a -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip _ x)     = f x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | /O(n)/. Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> IntMap b -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip _ x)     = f z' x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> IntMap b -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip _ x)     = f z' x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | /O(n)/. Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx x)    = f kx x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey #-}++-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip kx x)    = f kx x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey' #-}++-- | /O(n)/. Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx x)    = f z' kx x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldlWithKey #-}++-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip kx x)    = f z' kx x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldlWithKey' #-}++-- | /O(n)/. Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m+foldMapWithKey f = go+  where+    go Nil           = mempty+    go (Tip kx x)    = f kx x+    go (Bin _ m l r)+      | m < 0     = go r `mappend` go l+      | otherwise = go l `mappend` go r+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: IntMap a -> [a]+elems = foldr (:) []++-- | /O(n)/. Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: IntMap a -> [Key]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the+-- map in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: IntMap a -> [(Key,a)]+assocs = toAscList++-- | /O(n*min(n,W))/. The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]+-- > keysSet empty == Data.IntSet.empty++keysSet :: IntMap a -> IntSet.IntSet+keysSet Nil = IntSet.Nil+keysSet (Tip kx _) = IntSet.singleton kx+keysSet (Bin p m l r)+  | m .&. IntSet.suffixBitMask == 0 = IntSet.Bin p m (keysSet l) (keysSet r)+  | otherwise = IntSet.Tip (p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)+  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'+        computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx+        computeBm _   Nil = error "Data.IntSet.keysSet: Nil"++-- | /O(n)/. Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.IntSet.empty == empty++fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a+fromSet _ IntSet.Nil = Nil+fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)+  where+    -- This is slightly complicated, as we to convert the dense+    -- representation of IntSet into tree representation of IntMap.+    --+    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with+    -- prefix 'prefix'. We split bmask into halves corresponding+    -- to left and right subtree. If they are both nonempty, we+    -- create a Bin node, otherwise exactly one of them is nonempty+    -- and we construct the IntMap from that half.+    buildTree g !prefix !bmask bits = case bits of+      0 -> Tip prefix (g prefix)+      _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+        bits2+          | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2+          | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree g prefix bmask bits2+          | otherwise ->+              Bin prefix bits2+                (buildTree g prefix bmask bits2)+                (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 708+-- | @since 0.5.6.2+instance GHCExts.IsList (IntMap a) where+  type Item (IntMap a) = (Key,a)+  fromList = fromList+  toList   = toList+#endif++-- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list+-- fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: IntMap a -> [(Key,a)]+toList = toAscList++-- | /O(n)/. Convert the map to a list of key\/value pairs where the+-- keys are in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: IntMap a -> [(Key,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: IntMap a -> [(Key,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif+++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(IntMap a) ![(Key,a)]++data Distinct = Distinct | Nondistinct++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal _   _   = False++nequal :: Eq a => IntMap a -> IntMap a -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx x) (Tip ky y)+  = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal _   _   = True++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.9+instance Eq1 IntMap where+  liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+    = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)+  liftEq eq (Tip kx x) (Tip ky y)+    = (kx == ky) && (eq x y)+  liftEq _eq Nil Nil = True+  liftEq _eq _   _   = False+#endif++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord a => Ord (IntMap a) where+    compare m1 m2 = compare (toList m1) (toList m2)++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.9+instance Ord1 IntMap where+  liftCompare cmp m n =+    liftCompare (liftCompare cmp) (toList m) (toList n)+#endif++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}++instance Functor IntMap where+    fmap = map++#ifdef __GLASGOW_HASKELL__+    a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)+    a <$ Tip k _     = Tip k a+    _ <$ Nil         = Nil+#endif++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show a => Show (IntMap a) where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.9+instance Show1 IntMap where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl+#endif++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read e) => Read (IntMap e) where+#ifdef __GLASGOW_HASKELL__+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.9+instance Read1 IntMap where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl+#endif++{--------------------------------------------------------------------+  Typeable+--------------------------------------------------------------------}++INSTANCE_TYPEABLE1(IntMap)++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> IntMap a -> IntMap a -> IntMap a+linkWithMask m p1 t1 {-p2-} t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    p = mask p1 m+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin p m l r+{-# INLINE bin #-}++-- binCheckLeft only checks that the left subtree is non-empty+binCheckLeft :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a+binCheckLeft _ _ Nil r = r+binCheckLeft p m l r   = Bin p m l r+{-# INLINE binCheckLeft #-}++-- binCheckRight only checks that the right subtree is non-empty+binCheckRight :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a+binCheckRight _ _ l Nil = l+binCheckRight p m l r   = Bin p m l r+{-# INLINE binCheckRight #-}++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}++-- | Should this key follow the left subtree of a 'Bin' with switching+-- bit @m@? N.B., the answer is only valid when @match i p m@ is true.+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-}++nomatch,match :: Key -> Prefix -> Mask -> Bool++-- | Does the key @i@ differ from the prefix @p@ before getting to+-- the switching bit @m@?+nomatch i p m+  = (mask i m) /= p+{-# INLINE nomatch #-}++-- | Does the key @i@ match the prefix @p@ (up to but not including+-- bit @m@)?+match i p m+  = (mask i m) == p+{-# INLINE match #-}+++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-}+++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. ((-m) `xor` m))+{-# INLINE maskW #-}++-- | Does the left switching bit specify a shorter prefix?+shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-}++-- | The first switching bit where the two prefixes disagree.+branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+{-# INLINE branchMask #-}++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | /O(1)/.  Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+splitRoot :: IntMap a -> [IntMap a]+splitRoot orig =+  case orig of+    Nil -> []+    x@(Tip _ _) -> [x]+    Bin _ m l r | m < 0 -> [r, l]+                | otherwise -> [l, r]+{-# INLINE splitRoot #-}+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}++-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+  = showTreeWith True False s+++{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t = case t of+  Bin p m l r ->+    showsTree wide (withBar rbars) (withEmpty rbars) r .+    showWide wide rbars .+    showsBars lbars . showString (showBin p m) . showString "\n" .+    showWide wide lbars .+    showsTree wide (withEmpty lbars) (withBar lbars) l+  Tip k x ->+    showsBars lbars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t = case t of+  Bin p m l r ->+    showsBars bars . showString (showBin p m) . showString "\n" .+    showWide wide bars .+    showsTreeHang wide (withBar bars) l .+    showWide wide bars .+    showsTreeHang wide (withEmpty bars) r+  Tip k x ->+    showsBars bars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars
+ src/Data/Strict/IntMap/Autogen/Internal/Debug.hs view
@@ -0,0 +1,6 @@+module Data.Strict.IntMap.Autogen.Internal.Debug+  ( showTree+  , showTreeWith+  ) where++import Data.Strict.IntMap.Autogen.Internal
+ src/Data/Strict/IntMap/Autogen/Internal/DeprecatedDebug.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-}++module Data.Strict.IntMap.Autogen.Internal.DeprecatedDebug where+import Data.Strict.IntMap.Autogen.Internal (IntMap)++import Data.Strict.ContainersUtils.Autogen.TypeError+++-- | 'showTree' has moved to 'Data.Strict.IntMap.Autogen.Internal.Debug.showTree'+showTree :: Whoops "Data.Strict.IntMap.Autogen.showTree has moved to Data.Strict.IntMap.Autogen.Internal.Debug.showTree"+         => IntMap a -> String+showTree _ = undefined++-- | 'showTreeWith' has moved to 'Data.Strict.IntMap.Autogen.Internal.Debug.showTreeWith'+showTreeWith :: Whoops "Data.Strict.IntMap.Autogen.showTreeWith has moved to Data.Strict.IntMap.Autogen.Internal.Debug.showTreeWith"+             => Bool -> Bool -> IntMap a -> String+showTreeWith _ _ _ = undefined
+ src/Data/Strict/IntMap/Autogen/Merge/Strict.hs view
@@ -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.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.Internal+  ( SimpleWhenMissing+  , SimpleWhenMatched+  , merge+  , dropMissing+  , preserveMissing+  , filterMissing+  , WhenMissing (..)+  , WhenMatched (..)+  , mergeA+  , filterAMissing+  , runWhenMatched+  , runWhenMissing+  )+import Data.Strict.IntMap.Autogen.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 #-}
+ src/Data/Strict/IntMap/Autogen/Strict.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Trustworthy #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.Strict (IntMap)+-- > import qualified Data.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.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://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * 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.Strict.IntMap.Autogen.Internal.++module Data.Strict.IntMap.Autogen.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++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , 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.Strict.IntMap.Autogen.Strict.Internal+import Prelude ()
+ src/Data/Strict/IntMap/Autogen/Strict/Internal.hs view
@@ -0,0 +1,1215 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.IntMap.Autogen.Strict.Internal+-- 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.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.Strict (IntMap)+-- > import qualified Data.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.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.Strict.IntMap.Autogen.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://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * 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.Strict.IntMap.Autogen.Internal.++module Data.Strict.IntMap.Autogen.Strict.Internal (+    -- * 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++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , 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 Prelude hiding (lookup,map,filter,foldr,foldl,null)++import Data.Bits+import qualified Data.Strict.IntMap.Autogen.Internal as L+import Data.Strict.IntMap.Autogen.Internal+  ( IntMap (..)+  , Key+  , mask+  , branchMask+  , nomatch+  , zero+  , natFromInt+  , intFromNat+  , bin+  , binCheckLeft+  , binCheckRight+  , link+  , linkWithMask++  , (\\)+  , (!)+  , (!?)+  , empty+  , assocs+  , filter+  , filterWithKey+  , findMin+  , findMax+  , foldMapWithKey+  , foldr+  , foldl+  , foldr'+  , foldl'+  , foldlWithKey+  , foldrWithKey+  , foldlWithKey'+  , foldrWithKey'+  , keysSet+  , mergeWithKey'+  , compose+  , delete+  , deleteMin+  , deleteMax+  , deleteFindMax+  , deleteFindMin+  , difference+  , elems+  , intersection+  , disjoint+  , isProperSubmapOf+  , isProperSubmapOfBy+  , isSubmapOf+  , isSubmapOfBy+  , lookup+  , lookupLE+  , lookupGE+  , lookupLT+  , lookupGT+  , lookupMin+  , lookupMax+  , minView+  , maxView+  , minViewWithKey+  , maxViewWithKey+  , keys+  , mapKeys+  , mapKeysMonotonic+  , member+  , notMember+  , null+  , partition+  , partitionWithKey+  , restrictKeys+  , size+  , split+  , splitLookup+  , splitRoot+  , toAscList+  , toDescList+  , toList+  , union+  , unions+  , withoutKeys+  )+#ifdef __GLASGOW_HASKELL__+import Data.Strict.IntMap.Autogen.Internal.DeprecatedDebug (showTree, showTreeWith)+#endif+import qualified Data.IntSet.Internal as IntSet+import Data.Strict.ContainersUtils.Autogen.BitUtil+import Data.Strict.ContainersUtils.Autogen.StrictPair+#if !MIN_VERSION_base(4,8,0)+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+--------------------------------------------------------------------}++-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See IntMap.Internal.Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def !k = go+  where+    go (Bin p m l r) | nomatch k p m = def+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> IntMap a+singleton k !x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > 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'++insert :: Key -> a -> IntMap a -> IntMap a+insert !k !x t =+  case t of+    Bin p m l r+      | nomatch k p m -> link k (Tip k x) p t+      | zero k m      -> Bin p m (insert k x l) r+      | otherwise     -> Bin p m l (insert k x r)+    Tip ky _+      | k==ky         -> Tip k x+      | otherwise     -> link k (Tip k x) ky t+    Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > 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"++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > 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"+--+-- If the key exists in the map, this function is lazy in @value@ but strict+-- in the result of @f@.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f !k x t =+  case t of+    Bin p m l r+      | nomatch k p m -> link k (singleton k x) p t+      | zero k m      -> Bin p m (insertWithKey f k x l) r+      | otherwise     -> Bin p m l (insertWithKey f k x r)+    Tip ky y+      | k==ky         -> Tip k $! f k x y+      | otherwise     -> link k (singleton k x) ky t+    Nil -> singleton k x++-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|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")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0+  where+    go f k x t =+      case t of+        Bin p m l r+          | nomatch k p m -> Nothing :*: link k (singleton k x) p t+          | zero k m      -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)+          | otherwise     -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')+        Tip ky y+          | k==ky         -> (Just y :*: (Tip k $! f k x y))+          | otherwise     -> (Nothing :*: link k (singleton k x) ky t)+        Nil -> Nothing :*: (singleton k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > 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++adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > 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++adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> t+      | zero k m      -> Bin p m (adjustWithKey f k l) r+      | otherwise     -> Bin p m l (adjustWithKey f k r)+    Tip ky y+      | k==ky         -> Tip ky $! f k y+      | otherwise     -> t+    Nil -> Nil++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > 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"++update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f+  = updateWithKey (\_ x -> f x)++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> t+      | zero k m      -> binCheckLeft p m (updateWithKey f k l) r+      | otherwise     -> binCheckRight p m l (updateWithKey f k r)+    Tip ky y+      | k==ky         -> case f k y of+                           Just !y' -> Tip ky y'+                           Nothing -> Nil+      | otherwise     -> t+    Nil -> Nil++-- | /O(min(n,W))/. Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0+  where+    go f k t =+      case t of+        Bin p m l r+          | nomatch k p m -> (Nothing :*: t)+          | zero k m      -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)+          | otherwise     -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')+        Tip ky y+          | k==ky         -> case f k y of+                               Just !y' -> (Just y :*: Tip ky y')+                               Nothing  -> (Just y :*: Nil)+          | otherwise     -> (Nothing :*: t)+        Nil -> (Nothing :*: Nil)++++-- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> case f Nothing of+                           Nothing -> t+                           Just !x  -> link k (Tip k x) p t+      | zero k m      -> binCheckLeft p m (alter f k l) r+      | otherwise     -> binCheckRight p m l (alter f k r)+    Tip ky y+      | k==ky         -> case f (Just y) of+                           Just !x -> Tip ky x+                           Nothing -> Nil+      | otherwise     -> case f Nothing of+                           Just !x -> link k (Tip k x) ky t+                           Nothing -> t+    Nil               -> case f Nothing of+                           Just !x -> Tip k x+                           Nothing -> Nil++-- | /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 an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap 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.++-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- 'Control.Lens.At'.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)+-- This implementation was modified from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just !v' -> insert k v' m+  where mv = lookup k m+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | /O(n+m)/. The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- | /O(n+m)/. Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++-- | /O(n+m)/. The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | /O(n+m)/. A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily.  Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+             -> IntMap a -> IntMap b -> IntMap c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil+                                                                  Just !x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | /O(log n)/. Update the value at the minimal key.+--+-- > 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"++updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMinWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMinWithKey Nil"++-- | /O(log n)/. Update the value at the maximal key.+--+-- > 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"++updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMaxWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMaxWithKey Nil"++-- | /O(log n)/. Update the value at the maximal key.+--+-- > 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"++updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | /O(log n)/. Update the value at the minimal key.+--+-- > 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"++updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)+++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> IntMap a -> IntMap b+map f = go+  where+    go (Bin p m l r) = Bin p m (go l) (go r)+    go (Tip k x)     = Tip k $! f x+    go Nil           = Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs+ #-}+#endif++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k $! f k x+      Nil         -> Nil++#ifdef __GLASGOW_HASKELL__+-- Pay close attention to strictness here. We need to force the+-- intermediate result for map f . map g, and we need to refrain+-- from forcing it for map f . L.map g, etc.+--+-- TODO Consider moving map and mapWithKey to IntMap.Internal so we can write+-- non-orphan RULES for things like L.map f (map g xs). We'd need a new function+-- for this, and we'd have to pay attention to simplifier phases. Something like+--+-- lsmap :: (b -> c) -> (a -> b) -> IntMap a -> IntMap c+-- lsmap _ _ Nil = Nil+-- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)+-- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k $! g a) xs+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f $! g k a) xs+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | /O(n)/.+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = (\ !v' -> Tip k v') <$> f k v+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)+      | otherwise = liftA2 (Bin p m) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+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)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = 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.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.  Strict in+-- the accumulating argument and the both elements of the+-- result of the function.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r+            | m < 0 ->+                let (a1 :*: r') = go f a r+                    (a2 :*: l') = go f a1 l+                in (a2 :*: Bin p m l' r')+            | otherwise ->+                let (a1 :*: l') = go f a l+                    (a2 :*: r') = go f a1 r+                in (a2 :*: Bin p m l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r+            | m < 0 ->+              let (a1 :*: l') = go f a l+                  (a2 :*: r') = go f a1 r+              in (a2 :*: Bin p m l' r')+            | otherwise ->+              let (a1 :*: r') = go f a r+                  (a2 :*: l') = go f a1 l+              in (a2 :*: Bin p m l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > 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"++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just !y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > 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, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > 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, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p m l r)+      = bin p m l1 r1 :*: bin p m l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left !y  -> (Tip k y :*: Nil)+      Right !z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++{--------------------------------------------------------------------+  Conversions+--------------------------------------------------------------------}++-- | /O(n)/. Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.IntSet.empty == empty++fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a+fromSet _ IntSet.Nil = Nil+fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)+  where -- This is slightly complicated, as we to convert the dense+        -- representation of IntSet into tree representation of IntMap.+        --+        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.+        -- We split bmask into halves corresponding to left and right subtree.+        -- If they are both nonempty, we create a Bin node, otherwise exactly+        -- one of them is nonempty and we construct the IntMap from that half.+        buildTree g !prefix !bmask bits = case bits of+          0 -> Tip prefix $! g prefix+          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+                 bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+                           buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2+                       | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+                           buildTree g prefix bmask bits2+                       | otherwise ->+                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx $! vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let !v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx $! vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let !v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx $! vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(IntMap a) ![(Key,a)]++data Distinct = Distinct | Nondistinct
+ src/Data/Strict/IntMap/Internal.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Strict.IntMap.Internal where++import Data.IntMap.Lazy                  as L+import Data.Strict.IntMap.Autogen.Strict as S++import Control.Monad+import Data.Binary+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex+import Data.Semigroup (Semigroup (..)) -- helps with compatibility+import Data.Strict.Classes++instance Strict (L.IntMap e) (S.IntMap e) where+  toStrict = S.fromList . L.toList+  toLazy = L.fromList . S.toList+  {-# INLINE toStrict #-}+  {-# INLINE toLazy #-}++-- code copied from indexed-traversable++instance FunctorWithIndex Int S.IntMap where+  imap = S.mapWithKey+  {-# INLINE imap #-}++instance FoldableWithIndex Int S.IntMap where+  ifoldMap = S.foldMapWithKey+  {-# INLINE ifoldMap #-}+  ifoldr   = S.foldrWithKey+  {-# INLINE ifoldr #-}+  ifoldl'  = S.foldlWithKey' . flip+  {-# INLINE ifoldl' #-}++instance TraversableWithIndex Int S.IntMap where+  itraverse = S.traverseWithKey+  {-# INLINE itraverse #-}++-- code copied from binary++instance (Binary e) => Binary (S.IntMap e) where+    put m = put (S.size m) <> mapM_ put (S.toAscList m)+    get   = liftM S.fromDistinctAscList get
+ src/Data/Strict/IntSet.hs view
@@ -0,0 +1,10 @@+{- | Module alias of "Data.IntSet"++This module re-exports "Data.IntSet" for convenience, so that you can avoid an+additional direct dependency on @containers@ if you want to.+-}+module Data.Strict.IntSet+  ( module Data.IntSet+  ) where++import Data.IntSet
+ src/Data/Strict/Map.hs view
@@ -0,0 +1,20 @@+{- | Fully-strict version of "Data.Map.Strict"++Unlike @Data.Map.Strict@ t'Data.Map.Strict.Map' which is an alias to+@Data.Map.Lazy@ t'Data.Map.Lazy.Map', the instances of our {- haddock #1251 {-+-} -} t'Data.Strict.Map.Map' are all strict as well.++You should be able to switch from the former simply by changing your module+imports, and your package dependency from @containers@ to @strict-containers@.+If this doesn't work, please file a bug.++The documentation in the auto-generated modules have not been updated in a+particularly sophisticated way, so may sound weird or contradictory. In those+cases, please re-interpret such weird wording in the context of the above.+-}+module Data.Strict.Map+  ( module Data.Strict.Map.Autogen.Strict+  ) where++import Data.Strict.Map.Internal+import Data.Strict.Map.Autogen.Strict
+ src/Data/Strict/Map/Autogen/Internal.hs view
@@ -0,0 +1,4377 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+#endif+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+#define USE_MAGIC_PROXY 1+#endif++#ifdef USE_MAGIC_PROXY+{-# LANGUAGE MagicHash #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++#if !(WORD_SIZE_IN_BITS >= 61)+#define DEFINE_ALTERF_FALLBACK 1+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.Map.Autogen.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- An efficient implementation of maps from keys to values (dictionaries).+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- >  import Data.Strict.Map.Autogen (Map)+-- >  import qualified Data.Strict.Map.Autogen as Map+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets: a balancing act/\",+--     Journal of Functional Programming 3(4):553-562, October 1993,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Using INLINABLE]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+++-- [Note: Using INLINE]+-- ~~~~~~~~~~~~~~~~~~~~+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods marked INLINE have to be nonrecursive -- a 'go' function doing+-- the real work is provided.+++-- [Note: Type of local 'go' function]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If the local 'go' function uses an Ord class, it sometimes heap-allocates+-- the Ord dictionary when the 'go' function does not have explicit type.+-- In that case we give 'go' explicit type. But this slightly decrease+-- performance, as the resulting 'go' function can float out to top level.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- As opposed to Map, when 'go' function captures an argument, increased+-- heap-allocation can occur: sometimes in a polymorphic function, the 'go'+-- floats out of its enclosing function and then it heap-allocates the+-- dictionary and the argument. Maybe it floats out too late and strictness+-- analyzer cannot see that these could be passed on stack.+--++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Map matters when considering performance.+-- Currently in GHC 7.0, when type has 2 constructors, a forward conditional+-- jump is made when successfully matching second constructor. Successful match+-- of first constructor results in the forward jump not taken.+-- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip+-- improves the benchmark by up to 10% on x86.++module Data.Strict.Map.Autogen.Internal (+    -- * Map type+      Map(..)          -- instance Eq,Show,Read+    , Size++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , preserveMissing'+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , 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++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * Filter+    , filter+    , filterWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- Used by the strict version+    , AreWeStrict (..)+    , atKeyImpl+#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)+    , atKeyPlain+#endif+    , bin+    , balance+    , balanceL+    , balanceR+    , delta+    , insertMax+    , link+    , link2+    , glue+    , MaybeS(..)+    , Identity(..)++    -- Used by Map.Merge.Lazy+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity (..))+import Control.Applicative (liftA3)+#else+import Control.Applicative (Applicative(..), (<$>), liftA3)+import Data.Monoid (Monoid(..))+import Data.Traversable (Traversable(traverse))+#endif+#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes+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+#if MIN_VERSION_base(4,10,0)+import Data.Bifoldable+#endif+import Data.Typeable+import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop)++import qualified Data.Set.Internal as Set+import Data.Set.Internal (Set)+import Data.Strict.ContainersUtils.Autogen.PtrEquality (ptrEq)+import Data.Strict.ContainersUtils.Autogen.StrictPair+import Data.Strict.ContainersUtils.Autogen.StrictMaybe+import Data.Strict.ContainersUtils.Autogen.BitQueue+#ifdef DEFINE_ALTERF_FALLBACK+import Data.Strict.ContainersUtils.Autogen.BitUtil (wordSize)+#endif++#if __GLASGOW_HASKELL__+import GHC.Exts (build, lazy)+#if !MIN_VERSION_base(4,8,0)+import Data.Functor ((<$))+#endif+#ifdef USE_MAGIC_PROXY+import GHC.Exts (Proxy#, proxy# )+#endif+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif+import Text.Read hiding (lift)+import Data.Data+import qualified Control.Category as Category+#endif+#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#endif+++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 !,!?,\\ --++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Ord k => Map k a -> k -> a+(!) m k = find k m+#if __GLASGOW_HASKELL__+{-# INLINE (!) #-}+#endif++-- | /O(log n)/. Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing+-- prop> fromList [(5, 'a'), (3, 'b')] !? 5 == Just 'a'+--+-- @since 0.5.9++(!?) :: Ord k => Map k a -> k -> Maybe a+(!?) m k = lookup k m+#if __GLASGOW_HASKELL__+{-# INLINE (!?) #-}+#endif++-- | Same as 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__+{-# INLINE (\\) #-}+#endif++{--------------------------------------------------------------------+  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)+              | Tip++type Size     = Int++#if __GLASGOW_HASKELL__ >= 708+type role Map nominal representational+#endif++instance (Ord k) => Monoid (Map k v) where+    mempty  = empty+    mconcat = unions+#if !(MIN_VERSION_base(4,9,0))+    mappend = union+#else+    mappend = (<>)++instance (Ord k) => Semigroup (Map k v) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid+#endif++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (Map k a) where+  gfoldl f z m   = z fromList `f` toList m+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = mapDataType+  dataCast2 f    = gcast2 f++fromListConstr :: Constr+fromListConstr = mkConstr mapDataType "fromList" [] Prefix++mapDataType :: DataType+mapDataType = mkDataType "Data.Strict.Map.Autogen.Internal.Map" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+--+-- > Data.Strict.Map.Autogen.null (empty)           == True+-- > Data.Strict.Map.Autogen.null (singleton 1 'a') == False++null :: Map k a -> Bool+null Tip      = True+null (Bin {}) = False+{-# INLINE null #-}++-- | /O(1)/. The number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3++size :: Map k a -> Int+size Tip              = 0+size (Bin sz _ _ _ _) = sz+{-# INLINE size #-}+++-- | /O(log n)/. Lookup the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+--+-- An example of using @lookup@:+--+-- > import Prelude hiding (lookup)+-- > import Data.Strict.Map.Autogen+-- >+-- > 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+-- >+-- > main = do+-- >     putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))+-- >     putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))+--+-- The output of this program:+--+-- >   John's currency: Just "Euro"+-- >   Pete's currency: Nothing+lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+  where+    go !_ Tip = Nothing+    go k (Bin _ kx x l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> Just x+#if __GLASGOW_HASKELL__+{-# INLINABLE lookup #-}+#else+{-# INLINE lookup #-}+#endif++-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False+member :: Ord k => k -> Map k a -> Bool+member = go+  where+    go !_ Tip = False+    go k (Bin _ kx _ l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> True+#if __GLASGOW_HASKELL__+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | /O(log n)/. Is the key not a member of the map? See also 'member'.+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Ord k => k -> Map k a -> Bool+notMember k m = not $ member k m+#if __GLASGOW_HASKELL__+{-# INLINABLE notMember #-}+#else+{-# INLINE notMember #-}+#endif++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+find :: Ord k => k -> Map k a -> a+find = go+  where+    go !_ Tip = error "Map.!: given key is not an element in the map"+    go k (Bin _ kx x l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE find #-}+#else+{-# INLINE find #-}+#endif++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault = go+  where+    go def !_ Tip = def+    go def k (Bin _ kx x l r) = case compare k kx of+      LT -> go def k l+      GT -> go def k r+      EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++-- | /O(log n)/. Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l+                                 | otherwise = goJust k kx x r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l+                                     | otherwise = goJust k kx x r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLT #-}+#else+{-# INLINE lookupLT #-}+#endif++-- | /O(log n)/. Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l+                                 | otherwise = goNothing k r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l+                                     | otherwise = goJust k kx' x' r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGT #-}+#else+{-# INLINE lookupGT #-}+#endif++-- | /O(log n)/. Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > 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')+lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l+                                                        EQ -> Just (kx, x)+                                                        GT -> goJust k kx x r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l+                                                            EQ -> Just (kx, x)+                                                            GT -> goJust k kx x r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLE #-}+#else+{-# INLINE lookupLE #-}+#endif++-- | /O(log n)/. Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > 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+lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+                                                        EQ -> Just (kx, x)+                                                        GT -> goNothing k r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+                                                            EQ -> Just (kx, x)+                                                            GT -> goJust k kx' x' r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGE #-}+#else+{-# INLINE lookupGE #-}+#endif++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: Map k a+empty = Tip+{-# INLINE empty #-}++-- | /O(1)/. A map with a single element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insertion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > 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'++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx0 = go kx0 kx0+  where+    -- Unlike insertR, we only get sharing here+    -- when the inserted value is at the same address+    -- as the present value. We try anyway; this condition+    -- seems particularly likely to occur in 'union'.+    go :: Ord k => k -> k -> a -> Map k a -> Map k a+    go orig !_  x Tip = singleton (lazy orig) x+    go orig !kx x t@(Bin sz ky y l r) =+        case compare kx ky of+            LT | l' `ptrEq` l -> t+               | otherwise -> balanceL ky y l' r+               where !l' = go orig kx x l+            GT | r' `ptrEq` r -> t+               | otherwise -> balanceR ky y l r'+               where !r' = go orig kx x r+            EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t+               | otherwise -> Bin sz (lazy orig) x l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif++-- [Note: Avoiding worker/wrapper]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 'insert' has to go to great lengths to get pointer equality right and+-- to prevent unnecessary allocation. The trouble is that GHC *really* wants+-- to unbox the key and throw away the boxed one. This is bad for us, because+-- we want to compare the pointer of the box we are given to the one already+-- present if they compare EQ. It's also bad for us because it leads to the+-- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the+-- 'go' function *two copies* of the key we're given. One of them we use for+-- comparisons; the other we keep in our pocket. To prevent worker/wrapper from+-- messing with the copy in our pocket, we sprinkle about calls to the magical+-- function 'lazy'. This is all horrible, but it seems to work okay.+++-- Insert a new key and value in the map if it is not already present.+-- Used by `union`.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper+insertR :: Ord k => k -> a -> Map k a -> Map k a+insertR kx0 = go kx0 kx0+  where+    go :: Ord k => k -> k -> a -> Map k a -> Map k a+    go orig !_  x Tip = singleton (lazy orig) x+    go orig !kx x t@(Bin _ ky y l r) =+        case compare kx ky of+            LT | l' `ptrEq` l -> t+               | otherwise -> balanceL ky y l' r+               where !l' = go orig kx x l+            GT | r' `ptrEq` r -> t+               | otherwise -> balanceR ky y l r'+               where !r' = go orig kx x r+            EQ -> t+#if __GLASGOW_HASKELL__+{-# INLINABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > 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"++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith = go+  where+    -- We have no hope of making pointer equality tricks work+    -- here, because lazy insertWith *always* changes the tree,+    -- either adding a new entry or replacing an element with a+    -- thunk.+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy kx (f x y) l r++#if __GLASGOW_HASKELL__+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++-- | A helper function for 'unionWith'. When the key is already in+-- the map, the key is left alone, not replaced. The combining+-- function is flipped--it is applied to the old value and then the+-- new value.++insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithR = go+  where+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy ky (f y x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithR #-}+#else+{-# INLINE insertWithR #-}+#endif++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > 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"++-- See Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy kx (f kx x y) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++-- | A helper function for 'unionWithKey'. When the key is already in+-- the map, the key is left alone, not replaced. The combining+-- function is flipped--it is applied to the old value and then the+-- new value.+insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKeyR = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy ky (f ky y x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKeyR #-}+#else+{-# INLINE insertWithKeyR #-}+#endif++-- | /O(log n)/. Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|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")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++-- See Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+                    -> (Maybe a, Map k a)+insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)+    go _ !kx x Tip = (Nothing :*: singleton kx x)+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> let !(found :*: l') = go f kx x l+                      !t' = balanceL ky y l' r+                  in (found :*: t')+            GT -> let !(found :*: r') = go f kx x r+                      !t' = balanceR ky y l r'+                  in (found :*: t')+            EQ -> (Just y :*: Bin sy kx (f kx x y) l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | /O(log n)/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > 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++-- See Note: Type of local 'go' function+delete :: Ord k => k -> Map k a -> Map k a+delete = go+  where+    go :: Ord k => k -> Map k a -> Map k a+    go !_ Tip = Tip+    go k t@(Bin _ kx x l r) =+        case compare k kx of+            LT | l' `ptrEq` l -> t+               | otherwise -> balanceR kx x l' r+               where !l' = go k l+            GT | r' `ptrEq` r -> t+               | otherwise -> balanceL kx x l r'+               where !r' = go k r+            EQ -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE delete #-}+#else+{-# INLINE delete #-}+#endif++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > 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++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > 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++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey = go+  where+    go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k (Bin sx kx x l r) =+        case compare k kx of+           LT -> Bin sx kx x (go f k l) r+           GT -> Bin sx kx x l (go f k r)+           EQ -> Bin sx kx (f kx x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > 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"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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"++-- See Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+  where+    go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k(Bin sx kx x l r) =+        case compare k kx of+           LT -> balanceR kx x (go f k l) r+           GT -> balanceL kx x l (go f k r)+           EQ -> case f kx x of+                   Just x' -> Bin sx kx x' l r+                   Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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")++-- See Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f0 k0 = toPair . go f0 k0+ where+   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+   go _ !_ Tip = (Nothing :*: Tip)+   go f k (Bin sx kx x l r) =+          case compare k kx of+               LT -> let !(found :*: l') = go f k l+                         !t' = balanceR kx x l' r+                     in (found :*: t')+               GT -> let !(found :*: r') = go f k r+                         !t' = balanceL kx x l r'+                     in (found :*: t')+               EQ -> case f kx x of+                       Just x' -> (Just x' :*: Bin sx kx x' l r)+                       Nothing -> let !glued = glue l r+                                  in (Just x :*: glued)+#if __GLASGOW_HASKELL__+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]++-- See Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+  where+    go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+    go f !k Tip = case f Nothing of+               Nothing -> Tip+               Just x  -> singleton k x++    go f k (Bin sx kx x l r) = case compare k kx of+               LT -> balance kx x (go f k l) r+               GT -> balance kx x l (go f k r)+               EQ -> case f (Just x) of+                       Just x' -> Bin sx kx x' l r+                       Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE alter #-}+#else+{-# INLINE alter #-}+#endif++-- 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)+#ifdef 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 #-}++#ifdef 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+    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+#ifdef 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++#ifdef 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 -> 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++#ifdef 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++{--------------------------------------------------------------------+  Indexing+--------------------------------------------------------------------}+-- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map. Calls 'error' when the key is not+-- a 'member' of the map.+--+-- > findIndex 2 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map+-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0+-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1+-- > findIndex 6 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map++-- See Note: Type of local 'go' function+findIndex :: Ord k => k -> Map k a -> Int+findIndex = go 0+  where+    go :: Ord k => Int -> k -> Map k a -> Int+    go !_   !_ Tip  = error "Map.findIndex: element is not in the map"+    go idx k (Bin _ kx _ l r) = case compare k kx of+      LT -> go idx k l+      GT -> go (idx + size l + 1) k r+      EQ -> idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE findIndex #-}+#endif++-- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map.+--+-- > 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++-- See Note: Type of local 'go' function+lookupIndex :: Ord k => k -> Map k a -> Maybe Int+lookupIndex = go 0+  where+    go :: Ord k => Int -> k -> Map k a -> Maybe Int+    go !_  !_ Tip  = Nothing+    go idx k (Bin _ kx _ l r) = case compare k kx of+      LT -> go idx k l+      GT -> go (idx + size l + 1) k r+      EQ -> Just $! idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupIndex #-}+#endif++-- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based+-- index in the sequence sorted by keys. If the /index/ is out of range (less+-- than zero, greater or equal to 'size' of the map), 'error' is called.+--+-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")+-- > elemAt 2 (fromList [(5,"a"), (3,"b")])    Error: index out of range++elemAt :: Int -> Map k a -> (k,a)+elemAt !_ Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+  = case compare i sizeL of+      LT -> elemAt i l+      GT -> elemAt (i-sizeL-1) r+      EQ -> (kx,x)+  where+    sizeL = size l++-- | Take a given number of entries in key order, beginning+-- with the smallest keys.+--+-- @+-- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'+-- @+--+-- @since 0.5.8++take :: Int -> Map k a -> Map k a+take i m | i >= size m = m+take i0 m0 = go i0 m0+  where+    go i !_ | i <= 0 = Tip+    go !_ Tip = Tip+    go i (Bin _ kx x l r) =+      case compare i sizeL of+        LT -> go i l+        GT -> link kx x l (go (i - sizeL - 1) r)+        EQ -> l+      where sizeL = size l++-- | Drop a given number of entries in key order, beginning+-- with the smallest keys.+--+-- @+-- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'+-- @+--+-- @since 0.5.8+drop :: Int -> Map k a -> Map k a+drop i m | i >= size m = Tip+drop i0 m0 = go i0 m0+  where+    go i m | i <= 0 = m+    go !_ Tip = Tip+    go i (Bin _ kx x l r) =+      case compare i sizeL of+        LT -> link kx x (go i l) r+        GT -> go (i - sizeL - 1) r+        EQ -> insertMin kx x r+      where sizeL = size l++-- | /O(log n)/. Split a map at a particular index.+--+-- @+-- splitAt !n !xs = ('take' n xs, 'drop' n xs)+-- @+--+-- @since 0.5.8+splitAt :: Int -> Map k a -> (Map k a, Map k a)+splitAt i0 m0+  | i0 >= size m0 = (m0, Tip)+  | otherwise = toPair $ go i0 m0+  where+    go i m | i <= 0 = Tip :*: m+    go !_ Tip = Tip :*: Tip+    go i (Bin _ kx x l r)+      = case compare i sizeL of+          LT -> case go i l of+                  ll :*: lr -> ll :*: link kx x lr r+          GT -> case go (i - sizeL - 1) r of+                  rl :*: rr -> link kx x l rl :*: rr+          EQ -> l :*: insertMin kx x r+      where sizeL = size l++-- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > 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 (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f !i t =+  case t of+    Tip -> error "Map.updateAt: index out of range"+    Bin sx kx x l r -> case compare i sizeL of+      LT -> balanceR kx x (updateAt f i l) r+      GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+      EQ -> case f kx x of+              Just x' -> Bin sx kx x' l r+              Nothing -> glue l r+      where+        sizeL = size l++-- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > deleteAt 0  (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > deleteAt 1  (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > deleteAt 2 (fromList [(5,"a"), (3,"b")])     Error: index out of range+-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")])  Error: index out of range++deleteAt :: Int -> Map k a -> Map k a+deleteAt !i t =+  case t of+    Tip -> error "Map.deleteAt: index out of range"+    Bin _ kx x l r -> case compare i sizeL of+      LT -> balanceR kx x (deleteAt i l) r+      GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)+      EQ -> glue l r+      where+        sizeL = size l+++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++lookupMinSure :: k -> a -> Map k a -> (k, a)+lookupMinSure k a Tip = (k, a)+lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l++-- | /O(log n)/. The minimal key of the map. Returns 'Nothing' if the map is empty.+--+-- > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")+-- > lookupMin empty = Nothing+--+-- @since 0.5.9++lookupMin :: Map k a -> Maybe (k,a)+lookupMin Tip = Nothing+lookupMin (Bin _ k x l _) = Just $! lookupMinSure k x l++-- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.+--+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > findMin empty                            Error: empty map has no minimal element++findMin :: Map k a -> (k,a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "Map.findMin: empty map has no minimal element"++-- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.+--+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")+-- > findMax empty                            Error: empty map has no maximal element++lookupMaxSure :: k -> a -> Map k a -> (k, a)+lookupMaxSure k a Tip = (k, a)+lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r++-- | /O(log n)/. The maximal key of the map. Returns 'Nothing' if the map is empty.+--+-- > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")+-- > lookupMax empty = Nothing+--+-- @since 0.5.9++lookupMax :: Map k a -> Maybe (k, a)+lookupMax Tip = Nothing+lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r++findMax :: Map k a -> (k,a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "Map.findMax: empty map has no maximal element"++-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.+--+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]+-- > deleteMin empty == empty++deleteMin :: Map k a -> Map k a+deleteMin (Bin _ _  _ Tip r)  = r+deleteMin (Bin _ kx x l r)    = balanceR kx x (deleteMin l) r+deleteMin Tip                 = Tip++-- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.+--+-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]+-- > deleteMax empty == empty++deleteMax :: Map k a -> Map k a+deleteMax (Bin _ _  _ l Tip)  = l+deleteMax (Bin _ kx x l r)    = balanceL kx x l (deleteMax r)+deleteMax Tip                 = Tip++-- | /O(log n)/. Update the value at the minimal key.+--+-- > 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"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+  = updateMinWithKey (\_ x -> f x) m++-- | /O(log n)/. Update the value at the maximal key.+--+-- > 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"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+  = updateMaxWithKey (\_ x -> f x) m+++-- | /O(log n)/. Update the value at the minimal key.+--+-- > 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"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip                 = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+                                           Nothing -> r+                                           Just x' -> Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r)    = balanceR kx x (updateMinWithKey f l) r++-- | /O(log n)/. Update the value at the maximal key.+--+-- > 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"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip                 = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+                                           Nothing -> l+                                           Just x' -> Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r)    = balanceL kx x l (updateMaxWithKey f r)++-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+minViewWithKey Tip = Nothing+minViewWithKey (Bin _ k x l r) = Just $+  case minViewSure k x l r of+    MinView km xm t -> ((km, xm), t)+-- We inline this to give GHC the best possible chance of getting+-- rid of the Maybe and pair constructors, as well as the thunk under+-- the Just.+{-# INLINE minViewWithKey #-}++-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+maxViewWithKey Tip = Nothing+maxViewWithKey (Bin _ k x l r) = Just $+  case maxViewSure k x l r of+    MaxView km xm t -> ((km, xm), t)+-- See note on inlining at minViewWithKey+{-# INLINE maxViewWithKey #-}++-- | /O(log n)/. Retrieves the value associated with minimal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")+-- > minView empty == Nothing++minView :: Map k a -> Maybe (a, Map k a)+minView t = case minViewWithKey t of+              Nothing -> Nothing+              Just ~((_, x), t') -> Just (x, t')++-- | /O(log n)/. Retrieves the value associated with maximal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")+-- > maxView empty == Nothing++maxView :: Map k a -> Maybe (a, Map k a)+maxView t = case maxViewWithKey t of+              Nothing -> Nothing+              Just ~((_, x), t') -> Just (x, t')++{--------------------------------------------------------------------+  Union.+--------------------------------------------------------------------}+-- | The union of a list of maps:+--   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+--+-- > 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")]++unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a+unions ts+  = Foldable.foldl' union empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unions #-}+#endif++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unionsWith #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/.+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.+-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Ord k => Map k a -> Map k a -> Map k a+union t1 Tip  = t1+union t1 (Bin _ k x Tip Tip) = insertR k x t1+union (Bin _ k x Tip Tip) t2 = insert k x t2+union Tip t2 = t2+union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of+  (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+           | otherwise -> link k1 x1 l1l2 r1r2+           where !l1l2 = union l1 l2+                 !r1r2 = union r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE union #-}+#endif++{--------------------------------------------------------------------+  Union with a combining function+--------------------------------------------------------------------}+-- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+-- QuickCheck says pointer equality never happens here.+unionWith _f t1 Tip = t1+unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1+unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2+unionWith _f Tip t2 = t2+unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> case mb of+      Nothing -> link k1 x1 l1l2 r1r2+      Just x2 -> link k1 (f x1 x2) l1l2 r1r2+    where !l1l2 = unionWith f l1 l2+          !r1r2 = unionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWith #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/.+-- Union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey _f t1 Tip = t1+unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1+unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2+unionWithKey _f Tip t2 = t2+unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> case mb of+      Nothing -> link k1 x1 l1l2 r1r2+      Just x2 -> link k1 (f k1 x1 x2) l1l2 r1r2+    where !l1l2 = unionWithKey f l1 l2+          !r1r2 = unionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- We don't currently attempt to use any pointer equality tricks for+-- 'difference'. To do so, we'd have to match on the first argument+-- and split the second. Unfortunately, the proof of the time bound+-- relies on doing it the way we do, and it's not clear whether that+-- bound holds the other way.++-- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps.+-- Return elements of the first map not existing in the second map.+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Ord k => Map k a -> Map k b -> Map k a+difference Tip _   = Tip+difference t1 Tip  = t1+difference t1 (Bin _ k _ l2 r2) = case split k t1 of+  (l1, r1)+    | size l1l2 + size r1r2 == size t1 -> t1+    | otherwise -> link2 l1l2 r1r2+    where+      !l1l2 = difference l1 l2+      !r1r2 = difference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE difference #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m+-- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s+-- @+--+-- @since 0.5.8++withoutKeys :: Ord k => Map k a -> Set k -> Map k a+withoutKeys Tip _ = Tip+withoutKeys m Set.Tip = m+withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of+  (lm, b, rm)+     | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m+     | otherwise -> link2 lm' rm'+     where+       !lm' = withoutKeys lm ls+       !rm' = withoutKeys rm rs+#if __GLASGOW_HASKELL__+{-# INLINABLE withoutKeys #-}+#endif++-- | /O(n+m)/. Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"+differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f = merge preserveMissing dropMissing $+       zipWithMaybeMatched (\_ x y -> f x y)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWith #-}+#endif++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f =+  merge preserveMissing dropMissing (zipWithMaybeMatched f)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Ord k => Map k a -> Map k b -> Map k a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin _ k x l1 r1) t2+  | mb = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+         then t1+         else link k x l1l2 r1r2+  | otherwise = link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitMember k t2+    !l1l2 = intersection l1 l2+    !r1r2 = intersection r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersection #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/. Restrict a 'Map' to only those keys+-- found in a 'Set'.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m+-- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s+-- @+--+-- @since 0.5.8+restrictKeys :: Ord k => Map k a -> Set k -> Map k a+restrictKeys Tip _ = Tip+restrictKeys _ Set.Tip = Tip+restrictKeys m@(Bin _ k x l1 r1) s+  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+        then m+        else link k x l1l2 r1r2+  | otherwise = link2 l1l2 r1r2+  where+    !(l2, b, r2) = Set.splitMember k s+    !l1l2 = restrictKeys l1 l2+    !r1r2 = restrictKeys r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE restrictKeys #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+-- We have no hope of pointer equality tricks here because every single+-- element in the result will be a thunk.+intersectionWith _f Tip _ = Tip+intersectionWith _f _ Tip = Tip+intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> link k (f x1 x2) l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWith f l1 l2+    !r1r2 = intersectionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWith #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey _f Tip _ = Tip+intersectionWithKey _f _ Tip = Tip+intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> link k (f k x1 x2) l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWithKey f l1 l2+    !r1r2 = intersectionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWithKey #-}+#endif++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | /O(m*log(n\/m + 1)), m <= n/. Check whether the key sets of two+-- maps are disjoint (i.e., their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.6.2.1++-- See 'Data.Set.Internal.isSubsetOfX' for some background+-- on the implementation design.+disjoint :: Ord k => Map k a -> Map k b -> Bool+disjoint Tip _ = True+disjoint _ Tip = True+disjoint (Bin 1 k _ _ _) t = k `notMember` t+disjoint (Bin _ k _ l r) t+  = not found && disjoint l lt && disjoint r gt+  where+    (lt,found,gt) = splitMember k t++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O (n * \log(m)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.Strict.Map.Autogen.Strict" exposed a version of+-- 'compose' that forced the values of the output 'Map'. This version does not+-- force these values.+--+-- @since 0.6.3.1+compose :: Ord b => Map b c -> Map a b -> Map a c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++#if !MIN_VERSION_base (4,8,0)+-- | The identity type.+newtype Identity a = Identity { runIdentity :: a }+#if __GLASGOW_HASKELL__ == 708+instance Functor Identity where+  fmap = coerce+instance Applicative Identity where+  (<*>) = coerce+  pure = Identity+#else+instance Functor Identity where+  fmap f (Identity a) = Identity (f a)+instance Applicative Identity where+  Identity f <*> Identity x = Identity (f x)+  pure = Identity+#endif+#endif++-- | A tactic for dealing with keys present in one map but not the other in+-- 'merge' or 'mergeA'.+--+-- A tactic of type @ WhenMissing f k x z @ is an abstract representation+-- of a function of type @ k -> x -> f (Maybe z) @.+--+-- @since 0.5.9++data WhenMissing f k x y = WhenMissing+  { missingSubtree :: Map k x -> f (Map k y)+  , missingKey :: k -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f k x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}++-- | @since 0.5.9+instance (Applicative f, Monad f)+         => Category.Category (WhenMissing f k) where+  id = preserveMissing+  f . g = traverseMaybeMissing $+    \ k x -> missingKey g k x >>= \y ->+         case y of+           Nothing -> pure Nothing+           Just q -> missingKey f k q+  {-# INLINE id #-}+  {-# INLINE (.) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f k x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g = traverseMaybeMissing $ \k x -> do+         res1 <- missingKey f k x+         case res1 of+           Nothing -> pure Nothing+           Just r -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where+#if !MIN_VERSION_base(4,8,0)+  return = pure+#endif+  m >>= f = traverseMaybeMissing $ \k x -> do+         res1 <- missingKey m k x+         case res1 of+           Nothing -> pure Nothing+           Just r -> missingKey (f r) k x+  {-# INLINE (>>=) #-}++-- | Map covariantly over a @'WhenMissing' f k x@.+--+-- @since 0.5.9+mapWhenMissing :: (Applicative f, Monad f)+               => (a -> b)+               -> WhenMissing f k x a -> WhenMissing f k x b+mapWhenMissing f t = WhenMissing+    { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+    , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}++-- | Map covariantly over a @'WhenMissing' f k x@, using only a 'Functor f'+-- constraint.+mapGentlyWhenMissing :: Functor f+               => (a -> b)+               -> WhenMissing f k x a -> WhenMissing f k x b+mapGentlyWhenMissing f t = WhenMissing+    { missingSubtree = \m -> fmap f <$> missingSubtree t m+    , missingKey = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}++-- | Map covariantly over a @'WhenMatched' f k x@, using only a 'Functor f'+-- constraint.+mapGentlyWhenMatched :: Functor f+               => (a -> b)+               -> WhenMatched f k x y a -> WhenMatched f k x y b+mapGentlyWhenMatched f t = zipWithMaybeAMatched $+  \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}++-- | Map contravariantly over a @'WhenMissing' f k _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f k a x -> WhenMissing f k b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}++-- | Map contravariantly over a @'WhenMatched' f k _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched :: (b -> a)+                          -> WhenMatched f k a y z+                          -> WhenMatched f k b y z+contramapFirstWhenMatched f t = WhenMatched $+  \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}++-- | Map contravariantly over a @'WhenMatched' f k x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched :: (b -> a)+                           -> WhenMatched f k x a z+                           -> WhenMatched f k x b z+contramapSecondWhenMatched f t = WhenMatched $+  \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}++-- | A tactic for dealing with keys present in one map but not the other in+-- 'merge'.+--+-- A tactic of type @ SimpleWhenMissing k x z @ is an abstract representation+-- of a function of type @ k -> x -> Maybe z @.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity++-- | A tactic for dealing with keys present in both+-- maps in 'merge' or 'mergeA'.+--+-- A tactic of type @ WhenMatched f k x y z @ is an abstract representation+-- of a function of type @ k -> x -> y -> f (Maybe z) @.+--+-- @since 0.5.9+newtype WhenMatched f k x y z = WhenMatched+  { matchedKey :: k -> x -> y -> f (Maybe z) }++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism between+-- @WhenMatched f k x y z@ and @k -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f k x y z -> k -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}++-- | Along with traverseMaybeMissing, witnesses the isomorphism between+-- @WhenMissing f k x y@ and @k -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f k x y -> k -> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f k x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where+  id = zipWithMatched (\_ _ y -> y)+  f . g = zipWithMaybeAMatched $+            \k x y -> do+              res <- runWhenMatched g k x y+              case res of+                Nothing -> pure Nothing+                Just r -> runWhenMatched f k x r+  {-# INLINE id #-}+  {-# INLINE (.) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f k x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs = zipWithMaybeAMatched $ \k x y -> do+    res <- runWhenMatched fs k x y+    case res of+      Nothing -> pure Nothing+      Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where+#if !MIN_VERSION_base(4,8,0)+  return = pure+#endif+  m >>= f = zipWithMaybeAMatched $ \k x y -> do+    res <- runWhenMatched m k x y+    case res of+      Nothing -> pure Nothing+      Just r -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}++-- | Map covariantly over a @'WhenMatched' f k x y@.+--+-- @since 0.5.9+mapWhenMatched :: Functor f+               => (a -> b)+               -> WhenMatched f k x y a+               -> WhenMatched f k x y b+mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @ SimpleWhenMatched k x y z @ is an abstract representation+-- of a function of type @ k -> x -> y -> Maybe z @.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity++-- | 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+-- @+--+-- @since 0.5.9+zipWithMatched :: Applicative f+               => (k -> x -> y -> z)+               -> WhenMatched f k x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}++-- | 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.+--+-- @since 0.5.9+zipWithAMatched :: Applicative f+                => (k -> x -> y -> f z)+                -> WhenMatched f k 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 maybe use the result in the merged map.+--+-- @+-- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)+--                     -> SimpleWhenMatched k x y z+-- @+--+-- @since 0.5.9+zipWithMaybeMatched :: Applicative f+                    => (k -> x -> y -> Maybe z)+                    -> WhenMatched f k x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ 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.+--+-- @since 0.5.9+zipWithMaybeAMatched :: (k -> x -> y -> f (Maybe z))+                     -> WhenMatched f k x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- @+-- dropMissing :: SimpleWhenMissing k x y+-- @+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f k x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Tip)+  , missingKey = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- @+-- preserveMissing :: SimpleWhenMissing k x x+-- @+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f k x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , 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.+--+-- @+-- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey = \ k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}++-- | 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.+--+-- @since 0.5.9+mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}++-- | Filter the entries whose keys are missing from the other map.+--+-- @+-- filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing k x x+-- @+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing :: Applicative f+              => (k -> x -> Bool) -> WhenMissing f k x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- @+-- filterAMissing f = Merge.Lazy.traverseMaybeMissing $+--   \k x -> (\b -> guard b *> Just x) <$> f k x+-- @+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing :: Applicative f+              => (k -> x -> f Bool) -> WhenMissing f k x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t++-- | Traverse over the entries whose keys are missing from the other map.+--+-- @since 0.5.9+traverseMissing :: Applicative f+                    => (k -> x -> f y) -> WhenMissing f k x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}++-- | 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.+--+-- @since 0.5.9+traverseMaybeMissing :: Applicative f+                      => (k -> x -> f (Maybe y)) -> WhenMissing f k x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}++-- | Merge two maps.+--+-- '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'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- 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"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use 'merge'+-- to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge preserveMissing dropMissing (zipWithMatched f)+-- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched $ \ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h)+--+-- @since 0.5.9+merge :: Ord k+             => SimpleWhenMissing k a c -- ^ What to do with keys in @m1@ but not @m2@+             -> SimpleWhenMissing k b c -- ^ What to do with keys in @m2@ but not @m1@+             -> SimpleWhenMatched k a b c -- ^ What to do with keys in both @m1@ and @m2@+             -> Map k a -- ^ Map @m1@+             -> Map k b -- ^ Map @m2@+             -> Map k c+merge g1 g2 f m1 m2 = runIdentity $+  mergeA g1 g2 f m1 m2+{-# INLINE merge #-}++-- | An applicative version of 'merge'.+--+-- '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'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- @mergeA@ will first \"align\" these maps by key:+--+-- @+-- 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"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f, Ord k)+  => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f k b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f k a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> Map k a -- ^ Map @m1@+  -> Map k b -- ^ Map @m2@+  -> f (Map k c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t}+    (WhenMatched f) = go+  where+    go t1 Tip = g1t t1+    go Tip t2 = g2t t2+    go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of+      (l2, mx2, r2) -> case mx2 of+          Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+                        l1l2 (g1k kx x1) r1r2+          Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+                        l1l2 (f kx x1 x2) r1r2+        where+          !l1l2 = go l1 l2+          !r1r2 = go r1 r2+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | /O(n+m)/. An unsafe general combining function.+--+-- WARNING: This function can produce corrupt maps and its results+-- may depend on the internal structures of its inputs. Users should+-- prefer 'merge' or 'mergeA'.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@,+-- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k+             => (k -> a -> b -> Maybe c)+             -> (Map k a -> Map k c)+             -> (Map k b -> Map k c)+             -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+  where+    go Tip t2 = g2 t2+    go t1 Tip = g1 t1+    go (Bin _ kx x l1 r1) t2 =+      case found of+        Nothing -> case g1 (singleton kx x) of+                     Tip -> link2 l' r'+                     (Bin _ _ x' Tip Tip) -> link kx x' l' r'+                     _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"+        Just x2 -> case f kx x x2 of+                     Nothing -> link2 l' r'+                     Just x' -> link kx x' l' r'+      where+        (l2, found, r2) = splitLookup kx t2+        l' = go l1 l2+        r' = go r1 r2+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | /O(m*log(n\/m + 1)), m <= n/.+-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+--+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubmapOf #-}+#endif++{- | /O(m*log(n\/m + 1)), m <= n/.+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all 'False':++ > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > 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+#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+                 && 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__+{-# INLINABLE submap' #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isProperSubmapOf m1 m2+  = isProperSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubmapOf #-}+#endif++{- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+++-}+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+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubmapOfBy #-}+#endif++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy the predicate.+--+-- > 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++filter :: (a -> Bool) -> Map k a -> Map k a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy the predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a+filterWithKey _ Tip = Tip+filterWithKey p t@(Bin _ kx x l r)+  | p kx x    = if pl `ptrEq` l && pr `ptrEq` r+                then t+                else link kx x pl pr+  | otherwise = link2 pl pr+  where !pl = filterWithKey p l+        !pr = filterWithKey p r++-- | /O(n)/. Filter keys and values using an 'Applicative'+-- predicate.+filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a)+filterWithKeyA _ Tip = pure Tip+filterWithKeyA p t@(Bin _ kx x l r) =+  liftA3 combine (p kx x) (filterWithKeyA p l) (filterWithKeyA p r)+  where+    combine True pl pr+      | pl `ptrEq` l && pr `ptrEq` r = t+      | otherwise = link kx x pl pr+    combine False pl pr = link2 pl pr++-- | /O(log n)/. Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)+-- @+--+-- @since 0.5.8++takeWhileAntitone :: (k -> Bool) -> Map k a -> Map k a+takeWhileAntitone _ Tip = Tip+takeWhileAntitone p (Bin _ kx x l r)+  | p kx = link kx x l (takeWhileAntitone p r)+  | otherwise = takeWhileAntitone p l++-- | /O(log n)/. Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k))+-- @+--+-- @since 0.5.8++dropWhileAntitone :: (k -> Bool) -> Map k a -> Map k a+dropWhileAntitone _ Tip = Tip+dropWhileAntitone p (Bin _ kx x l r)+  | p kx = dropWhileAntitone p r+  | otherwise = link kx x (dropWhileAntitone p l) r++-- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = partitionWithKey (\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point where the predicate switches from holding to not+-- holding (where the predicate is seen to hold before the first key and to fail+-- after the last key).+--+-- @since 0.5.8++spanAntitone :: (k -> Bool) -> Map k a -> (Map k a, Map k a)+spanAntitone p0 m = toPair (go p0 m)+  where+    go _ Tip = Tip :*: Tip+    go p (Bin _ kx x l r)+      | p kx = let u :*: v = go p r in link kx x l u :*: v+      | otherwise = let u :*: v = go p l in u :*: link kx x v r++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > 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")])++partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > 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")])++partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)+partitionWithKey p0 t0 = toPair $ go p0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go p t@(Bin _ kx x l r)+      | p kx x    = (if l1 `ptrEq` l && r1 `ptrEq` r+                     then t+                     else link kx x l1 r1) :*: link2 l2 r2+      | otherwise = link2 l1 r1 :*:+                    (if l2 `ptrEq` l && r2 `ptrEq` r+                     then t+                     else link kx x l2 r2)+      where+        (l1 :*: l2) = go p l+        (r1 :*: r2) = go p r++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+  Just y  -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+  Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.5.8+traverseMaybeWithKey :: Applicative f+                     => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)+traverseMaybeWithKey = go+  where+    go _ Tip = pure Tip+    go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x+    go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)+      where+        combine !l' mx !r' = case mx of+          Nothing -> link2 l' r'+          Just x' -> link kx x' l' r'++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > 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, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > 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, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go f (Bin _ kx x l r) = case f kx x of+      Left y  -> link kx y l1 r1 :*: link2 l2 r2+      Right z -> link2 l1 r1 :*: link kx z l2 r2+     where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map f = go where+  go Tip = Tip+  go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r)+-- We use a `go` function to allow `map` to inline. This makes+-- a big difference if someone uses `map (const x) m` instead+-- of `x <$ m`; it doesn't seem to do any harm.++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.+{-# RULES+"map/coerce" map coerce = coerce+ #-}+#endif++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | /O(n)/.+-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)+traverseWithKey f = go+  where+    go Tip = pure Tip+    go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v+    go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r)+{-# INLINE traverseWithKey #-}++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+  = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip               = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+  let (a1,l') = mapAccumL f a l+      (a2,x') = f a1 kx x+      (a3,r') = mapAccumL f a2 r+  in (a3,Bin sx kx x' l' r')++-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+  let (a1,r') = mapAccumRWithKey f a r+      (a2,x') = f a1 kx x+      (a3,l') = mapAccumRWithKey f a2 l+  in (a3,Bin sx kx x' l' r')++-- | /O(n*log n)/.+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > 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"++mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeys #-}+#endif++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@. The value at the greater of the two original keys+-- is used as the first argument to @c@.+--+-- > 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"++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeysWith #-}+#endif+++-- | /O(n)/.+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has better performance than 'mapKeys'.+--+-- > 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++mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a+mapKeysMonotonic _ Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+    Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++{--------------------------------------------------------------------+  Folds+--------------------------------------------------------------------}++-- | /O(n)/. Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> Map k a -> b+foldr f z = go z+  where+    go z' Tip             = z'+    go z' (Bin _ _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr #-}++-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Map k a -> b+foldr' f z = go z+  where+    go !z' Tip             = z'+    go z' (Bin _ _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr' #-}++-- | /O(n)/. Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> Map k b -> a+foldl f z = go z+  where+    go z' Tip             = z'+    go z' (Bin _ _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl #-}++-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Map k b -> a+foldl' f z = go z+  where+    go !z' Tip             = z'+    go z' (Bin _ _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl' #-}++-- | /O(n)/. Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey f z = go z+  where+    go z' Tip             = z'+    go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l+{-# INLINE foldrWithKey #-}++-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey' f z = go z+  where+    go !z' Tip              = z'+    go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l+{-# INLINE foldrWithKey' #-}++-- | /O(n)/. Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey f z = go z+  where+    go z' Tip              = z'+    go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r+{-# INLINE foldlWithKey #-}++-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey' f z = go z+  where+    go !z' Tip              = z'+    go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r+{-# INLINE foldlWithKey' #-}++-- | /O(n)/. Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m+foldMapWithKey f = go+  where+    go Tip             = mempty+    go (Bin 1 k v _ _) = f k v+    go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Map k a -> [a]+elems = foldr (:) []++-- | /O(n)/. Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: Map k a -> [k]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map+-- in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Map k a -> [(k,a)]+assocs m+  = toAscList m++-- | /O(n)/. The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]+-- > keysSet empty == Data.Set.empty++keysSet :: Map k a -> Set.Set k+keysSet Tip = Set.Tip+keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)++-- | /O(n)/. Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 708+-- | @since 0.5.6.2+instance (Ord k) => GHCExts.IsList (Map k v) where+  type Item (Map k v) = (k,v)+  fromList = fromList+  toList   = toList+#endif++-- | /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+-- for the key is retained.+--+-- If the keys of the list are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually.+fromList :: Ord k => [(k,a)] -> Map k a+fromList [] = Tip+fromList [(kx, x)] = Bin 1 kx x Tip Tip+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0+                           | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+  where+    not_ordered _ [] = False+    not_ordered kx ((ky,_) : _) = kx >= ky+    {-# INLINE not_ordered #-}++    fromList' t0 xs = Foldable.foldl' ins t0 xs+      where ins t (k,x) = insert k x t++    go !_ t [] = t+    go _ t [(kx, x)] = insertMax kx x t+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs+                              | otherwise = case create s xss of+                                  (r, ys, []) -> go (s `shiftL` 1) (link kx x l r) ys+                                  (r, _,  ys) -> fromList' (link kx x l r) ys++    -- The create is returning a triple (tree, xs, ys). Both xs and ys+    -- represent not yet processed elements and only one of them can be nonempty.+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree+    -- and must be inserted using fromList'. Otherwise the keys have been+    -- ordered so far.+    create !_ [] = (Tip, [], [])+    create s xs@(xp : xss)+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)+                                    | otherwise -> (Bin 1 kx x Tip Tip, xss, [])+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, [], _) -> res+                      (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)+                                               | otherwise -> case create (s `shiftR` 1) yss of+                                                   (r, zs, ws) -> (link ky y l r, zs, ws)+#if __GLASGOW_HASKELL__+{-# INLINABLE fromList #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromListWith #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- > let f k a1 a2 = (show k) ++ a1 ++ a2+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]+-- > fromListWithKey f [] == empty++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t+#if __GLASGOW_HASKELL__+{-# INLINABLE fromListWithKey #-}+#endif++-- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Map k a -> [(k,a)]+toList = toAscList++-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are+-- in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Map k a -> [(k,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: Map k a -> [(k,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.++  Note that if [xs] is ascending that:+    fromAscList xs       == fromList xs+    fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+--+-- > 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++fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs+  = fromDistinctAscList (combineEq xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,_) (x@(kx,xx):xs')+    | kx==kz    = combineEq' (kx,xx) xs'+    | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__+{-# INLINABLE fromAscList #-}+#endif++-- | /O(n)/. Build a map from a descending list in linear time.+-- /The precondition (input list is descending) is not checked./+--+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]+-- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- @since 0.5.8++fromDescList :: Eq k => [(k,a)] -> Map k a+fromDescList xs = fromDistinctDescList (combineEq xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,_) (x@(kx,xx):xs')+    | kx==kz    = combineEq' (kx,xx) xs'+    | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__+{-# INLINABLE fromDescList #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > 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++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+  = fromAscListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromAscListWith #-}+#endif++-- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.+-- /The precondition (input list is descending) is not checked./+--+-- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- @since 0.5.8++fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWith f xs+  = fromDescListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromDescListWith #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > 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++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs+  = fromDistinctAscList (combineEq f xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq _ xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,zz) (x@(kx,xx):xs')+    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs'+    | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__+{-# INLINABLE fromAscListWithKey #-}+#endif++-- | /O(n)/. Build a map from a descending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is descending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWithKey f xs+  = fromDistinctDescList (combineEq f xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq _ xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,zz) (x@(kx,xx):xs')+    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs'+    | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__+{-# INLINABLE fromDescListWithKey #-}+#endif+++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > 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++-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList [] = Tip+fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+  where+    go !_ t [] = t+    go s l ((kx, x) : xs) = case create s xs of+                                (r :*: ys) -> let !t' = link kx x l r+                                              in go (s `shiftL` 1) t' ys++    create !_ [] = (Tip :*: [])+    create s xs@(x' : xs')+      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_ :*: []) -> res+                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of+                        (r :*: zs) -> (link ky y l r :*: zs)++-- | /O(n)/. Build a map from a descending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True+-- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False+--+-- @since 0.5.8++-- For some reason, when 'singleton' is used in fromDistinctDescList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctDescList :: [(k,a)] -> Map k a+fromDistinctDescList [] = Tip+fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0+  where+     go !_ t [] = t+     go s r ((kx, x) : xs) = case create s xs of+                               (l :*: ys) -> let !t' = link kx x l r+                                             in go (s `shiftL` 1) t' ys++     create !_ [] = (Tip :*: [])+     create s xs@(x' : xs')+       | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')+       | otherwise = case create (s `shiftR` 1) xs of+                       res@(_ :*: []) -> res+                       (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of+                         (l :*: zs) -> (link ky y l r :*: zs)++{-+-- Functions very similar to these were used to implement+-- hedge union, intersection, and difference algorithms that we no+-- longer use. These functions, however, seem likely to be useful+-- in their own right, so I'm leaving them here in case we end up+-- exporting them.++{--------------------------------------------------------------------+  [filterGt b t] filter all keys >[b] from tree [t]+  [filterLt b t] filter all keys <[b] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord k => k -> Map k v -> Map k v+filterGt !_ Tip = Tip+filterGt !b (Bin _ kx x l r) =+  case compare b kx of LT -> link kx x (filterGt b l) r+                       EQ -> r+                       GT -> filterGt b r+#if __GLASGOW_HASKELL__+{-# INLINABLE filterGt #-}+#endif++filterLt :: Ord k => k -> Map k v -> Map k v+filterLt !_ Tip = Tip+filterLt !b (Bin _ kx x l r) =+  case compare kx b of LT -> link kx x l (filterLt b r)+                       EQ -> l+                       GT -> filterLt b l+#if __GLASGOW_HASKELL__+{-# INLINABLE filterLt #-}+#endif+-}++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > 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)++split :: Ord k => k -> Map k a -> (Map k a,Map k a)+split !k0 t0 = toPair $ go k0 t0+  where+    go k t =+      case t of+        Tip            -> Tip :*: Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r+          GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt+          EQ -> (l :*: r)+#if __GLASGOW_HASKELL__+{-# INLINABLE split #-}+#endif++-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+--+-- > 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)+splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)+splitLookup k0 m = case go k0 m of+     StrictTriple l mv r -> (l, mv, r)+  where+    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) (Maybe a) (Map k a)+    go !k t =+      case t of+        Tip            -> StrictTriple Tip Nothing Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let StrictTriple lt z gt = go k l+                    !gt' = link kx x gt r+                in StrictTriple lt z gt'+          GT -> let StrictTriple lt z gt = go k r+                    !lt' = link kx x l lt+                in StrictTriple lt' z gt+          EQ -> StrictTriple l (Just x) r+#if __GLASGOW_HASKELL__+{-# INLINABLE splitLookup #-}+#endif++-- | A variant of 'splitLookup' that indicates only whether the+-- key was present, rather than producing its value. This is used to+-- implement 'intersection' to avoid allocating unnecessary 'Just'+-- constructors.+splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)+splitMember k0 m = case go k0 m of+     StrictTriple l mv r -> (l, mv, r)+  where+    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)+    go !k t =+      case t of+        Tip            -> StrictTriple Tip False Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let StrictTriple lt z gt = go k l+                    !gt' = link kx x gt r+                in StrictTriple lt z gt'+          GT -> let StrictTriple lt z gt = go k r+                    !lt' = link kx x l lt+                in StrictTriple lt' z gt+          EQ -> StrictTriple l True r+#if __GLASGOW_HASKELL__+{-# INLINABLE splitMember #-}+#endif++data StrictTriple a b c = StrictTriple !a !b !c++{--------------------------------------------------------------------+  Utility functions that maintain the balance properties of the tree.+  All constructors assume that all values in [l] < [k] and all values+  in [r] > [k], and that [l] and [r] are valid trees.++  In order of sophistication:+    [Bin sz k x l r]  The type constructor.+    [bin k x l r]     Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance k x l r] Restores the balance and size.+                      Assumes that the original tree was balanced and+                      that [l] or [r] has changed by at most one element.+    [link k x l r]    Restores balance and size.++  Furthermore, we can construct a new tree from two trees. Both operations+  assume that all values in [l] < all values in [r] and that [l] and [r]+  are valid:+    [glue l r]        Glues [l] and [r] together. Assumes that [l] and+                      [r] are already balanced with respect to each other.+    [link2 l r]       Merges two trees and restores balance.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: k -> a -> Map k a -> Map k a -> Map k a+link kx x Tip r  = insertMin kx x r+link kx x l Tip  = insertMax kx x l+link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+  | delta*sizeL < sizeR  = balanceL kz z (link kx x l lz) rz+  | delta*sizeR < sizeL  = balanceR ky y ly (link kx x ry r)+  | otherwise            = bin kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k -> a -> Map k a -> Map k a+insertMax kx x t+  = case t of+      Tip -> singleton kx x+      Bin _ ky y l r+          -> balanceR ky y l (insertMax kx x r)++insertMin kx x t+  = case t of+      Tip -> singleton kx x+      Bin _ ky y l r+          -> balanceL ky y (insertMin kx x l) r++{--------------------------------------------------------------------+  [link2 l r]: merges two trees.+--------------------------------------------------------------------}+link2 :: Map k a -> Map k a -> Map k a+link2 Tip r   = r+link2 l Tip   = l+link2 l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+  | delta*sizeL < sizeR = balanceL ky y (link2 l ly) ry+  | delta*sizeR < sizeL = balanceR kx x lx (link2 rx r)+  | otherwise           = glue l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Map k a -> Map k a -> Map k a+glue Tip r = r+glue l Tip = l+glue l@(Bin sl kl xl ll lr) r@(Bin sr kr xr rl rr)+  | sl > sr = let !(MaxView km m l') = maxViewSure kl xl ll lr in balanceR km m l' r+  | otherwise = let !(MinView km m r') = minViewSure kr xr rl rr in balanceL km m l r'++data MinView k a = MinView !k a !(Map k a)+data MaxView k a = MaxView !k a !(Map k a)++minViewSure :: k -> a -> Map k a -> Map k a -> MinView k a+minViewSure = go+  where+    go k x Tip r = MinView k x r+    go k x (Bin _ kl xl ll lr) r =+      case go kl xl ll lr of+        MinView km xm l' -> MinView km xm (balanceR k x l' r)+{-# NOINLINE minViewSure #-}++maxViewSure :: k -> a -> Map k a -> Map k a -> MaxView k a+maxViewSure = go+  where+    go k x l Tip = MaxView k x l+    go k x l (Bin _ kr xr rl rr) =+      case go kr xr rl rr of+        MaxView km xm r' -> MaxView km xm (balanceL k x l r')+{-# NOINLINE maxViewSure #-}++-- | /O(log n)/. Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])+-- > deleteFindMin empty                                      Error: can not return the minimal element of an empty map++deleteFindMin :: Map k a -> ((k,a),Map k a)+deleteFindMin t = case minViewWithKey t of+  Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)+  Just res -> res++-- | /O(log n)/. Delete and find the maximal element.+--+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])+-- > deleteFindMax empty                                      Error: can not return the maximal element of an empty map++deleteFindMax :: Map k a -> ((k,a),Map k a)+deleteFindMax t = case maxViewWithKey t of+  Nothing -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+  Just res -> res++{--------------------------------------------------------------------+  [balance l x r] balances two trees with value x.+  The sizes of the trees should balance after decreasing the+  size of one of them. (a rotation).++  [delta] is the maximal relative difference between the sizes of+          two trees, it corresponds with the [w] in Adams' paper.+  [ratio] is the ratio between an outer and inner sibling of the+          heavier subtree in an unbalanced setting. It determines+          whether a double or single rotation should be performed+          to restore balance. It is corresponds with the inverse+          of $\alpha$ in Adam's article.++  Note that according to the Adam's paper:+  - [delta] should be larger than 4.646 with a [ratio] of 2.+  - [delta] should be larger than 3.745 with a [ratio] of 1.534.++  But the Adam's paper is erroneous:+  - It can be proved that for delta=2 and delta>=5 there does+    not exist any ratio that would work.+  - Delta=4.5 and ratio=2 does not work.++  That leaves two reasonable variants, delta=3 and delta=4,+  both with ratio=2.++  - A lower [delta] leads to a more 'perfectly' balanced tree.+  - A higher [delta] performs less rebalancing.++  In the benchmarks, delta=3 is faster on insert operations,+  and delta=4 has slightly better deletes. As the insert speedup+  is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+--   balance :: k -> a -> Map k a -> Map k a -> Map k a+--   balance k x l r+--     | sizeL + sizeR <= 1    = Bin sizeX k x l r+--     | sizeR > delta*sizeL   = rotateL k x l r+--     | sizeL > delta*sizeR   = rotateR k x l r+--     | otherwise             = Bin sizeX k x l r+--     where+--       sizeL = size l+--       sizeR = size r+--       sizeX = sizeL + sizeR + 1+--+--   rotateL :: a -> b -> Map a b -> Map a b -> Map a b+--   rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r+--                                     | otherwise               = doubleL k x l r+--+--   rotateR :: a -> b -> Map a b -> Map a b -> Map a b+--   rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r+--                                     | otherwise               = doubleR k x l r+--+--   singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+--   singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3+--   singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)+--+--   doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+--   doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+--   doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.++balance :: k -> a -> Map k a -> Map k a -> Map k a+balance k x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++  (Bin ls lk lx ll lr) -> case r of+           Tip -> case (ll, lr) of+                    (Tip, Tip) -> Bin 2 k x l Tip+                    (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+                    ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+                    ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))+                      | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+                      | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)+           (Bin rs rk rx rl rr)+              | rs > delta*ls  -> case (rl, rr) of+                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+                   (_, _) -> error "Failure in Data.Strict.Map.Autogen.balance"+              | ls > delta*rs  -> case (ll, lr) of+                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+                   (_, _) -> error "Failure in Data.Strict.Map.Autogen.balance"+              | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balance #-}++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case r of+  Tip -> case l of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+           (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+           (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+           (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+             | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+             | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++  (Bin rs _ _ _ _) -> case l of+           Tip -> Bin (1+rs) k x Tip r++           (Bin ls lk lx ll lr)+              | ls > delta*rs  -> case (ll, lr) of+                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+                   (_, _) -> error "Failure in Data.Strict.Map.Autogen.balanceL"+              | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceL #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++  (Bin ls _ _ _ _) -> case r of+           Tip -> Bin (1+ls) k x l Tip++           (Bin rs rk rx rl rr)+              | rs > delta*ls  -> case (rl, rr) of+                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+                   (_, _) -> error "Failure in Data.Strict.Map.Autogen.balanceR"+              | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceR #-}+++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r+  = Bin (size l + size r + 1) k x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+  Eq converts the tree to a list. In a lazy setting, this+  actually seems one of the faster methods to compare two trees+  and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance (Eq k,Eq a) => Eq (Map k a) where+  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance (Ord k, Ord v) => Ord (Map k v) where+    compare m1 m2 = compare (toAscList m1) (toAscList m2)++#if MIN_VERSION_base(4,9,0)+{--------------------------------------------------------------------+  Lifted instances+--------------------------------------------------------------------}++-- | @since 0.5.9+instance Eq2 Map where+    liftEq2 eqk eqv m n =+        size m == size n && liftEq (liftEq2 eqk eqv) (toList m) (toList n)++-- | @since 0.5.9+instance Eq k => Eq1 (Map k) where+    liftEq = liftEq2 (==)++-- | @since 0.5.9+instance Ord2 Map where+    liftCompare2 cmpk cmpv m n =+        liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n)++-- | @since 0.5.9+instance Ord k => Ord1 (Map k) where+    liftCompare = liftCompare2 compare++-- | @since 0.5.9+instance Show2 Map where+    liftShowsPrec2 spk slk spv slv d m =+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)+      where+        sp = liftShowsPrec2 spk slk spv slv+        sl = liftShowList2 spk slk spv slv++-- | @since 0.5.9+instance Show k => Show1 (Map k) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++-- | @since 0.5.9+instance (Ord k, Read k) => Read1 (Map k) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl+#endif++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+  fmap f m  = map f m+#ifdef __GLASGOW_HASKELL__+  _ <$ Tip = Tip+  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+          go (Bin 1 _ v _ _) = v+          go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Tip = mempty+          go (Bin 1 _ v _ _) = f v+          go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+#if MIN_VERSION_base(4,8,0)+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= Map.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Tip = False+          go x (Bin _ _ v l r) = x == v || go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Tip = error "Data.Foldable.maximum (for Data.Strict.Map.Autogen): empty map"+          start (Bin _ _ v l r) = go (go v l) r++          go !m Tip = m+          go m (Bin _ _ v l r) = go (go (max m v) l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Tip = error "Data.Foldable.minimum (for Data.Strict.Map.Autogen): empty map"+          start (Bin _ _ v l r) = go (go v l) r++          go !m Tip = m+          go m (Bin _ _ v l r) = go (go (min m v) l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}+#endif++#if MIN_VERSION_base(4,10,0)+-- | @since 0.6.3.1+instance Bifoldable Map where+  bifold = go+    where go Tip = mempty+          go (Bin 1 k v _ _) = k `mappend` v+          go (Bin _ k v l r) = go l `mappend` (k `mappend` (v `mappend` go r))+  {-# INLINABLE bifold #-}+  bifoldr f g z = go z+    where go z' Tip             = z'+          go z' (Bin _ k v l r) = go (f k (g v (go z' r))) l+  {-# INLINE bifoldr #-}+  bifoldl f g z = go z+    where go z' Tip             = z'+          go z' (Bin _ k v l r) = go (g (f (go z' l) k) v) r+  {-# INLINE bifoldl #-}+  bifoldMap f g t = go t+    where go Tip = mempty+          go (Bin 1 k v _ _) = f k `mappend` g v+          go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r))+  {-# INLINE bifoldMap #-}+#endif++instance (NFData k, NFData a) => NFData (Map k a) where+    rnf Tip = ()+    rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Ord k, Read k, Read e) => Read (Map k e) where+#ifdef __GLASGOW_HASKELL__+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+  showsPrec d m  = showParen (d > 10) $+    showString "fromList " . shows (toList m)++{--------------------------------------------------------------------+  Typeable+--------------------------------------------------------------------}++INSTANCE_TYPEABLE2(Map)++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | /O(1)/.  Decompose a map into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the pieces+-- returned will be in ascending order (all elements in the first submap less than all+-- elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d')],fromList [(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than three submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+--+-- @since 0.5.4+splitRoot :: Map k b -> [Map k b]+splitRoot orig =+  case orig of+    Tip           -> []+    Bin _ k v l r -> [l, singleton k v, r]+{-# INLINE splitRoot #-}
+ src/Data/Strict/Map/Autogen/Internal/Debug.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}+#include "containers.h"++module Data.Strict.Map.Autogen.Internal.Debug where++import Data.Strict.Map.Autogen.Internal (Map (..), size, delta)+import Control.Monad (guard)++-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format. See 'showTreeWith'.+showTree :: (Show k,Show a) => Map k a -> String+showTree m+  = showTreeWith showElem True False m+  where+    showElem k x  = show k ++ ":=" ++ show x+++{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++>  Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t+>  (4,())+>  +--(2,())+>  |  +--(1,())+>  |  +--(3,())+>  +--(5,())+>+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t+>  (4,())+>  |+>  +--(2,())+>  |  |+>  |  +--(1,())+>  |  |+>  |  +--(3,())+>  |+>  +--(5,())+>+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t+>  +--(5,())+>  |+>  (4,())+>  |+>  |  +--(3,())+>  |  |+>  +--(2,())+>     |+>     +--(1,())++-}+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String+showTreeWith showelem hang wide t+  | hang      = (showsTreeHang showelem wide [] t) ""+  | otherwise = (showsTree showelem wide [] [] t) ""++showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS+showsTree showelem wide lbars rbars t+  = case t of+      Tip -> showsBars lbars . showString "|\n"+      Bin _ kx x Tip Tip+          -> showsBars lbars . showString (showelem kx x) . showString "\n"+      Bin _ kx x l r+          -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showelem kx x) . showString "\n" .+             showWide wide lbars .+             showsTree showelem wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS+showsTreeHang showelem wide bars t+  = case t of+      Tip -> showsBars bars . showString "|\n"+      Bin _ kx x Tip Tip+          -> showsBars bars . showString (showelem kx x) . showString "\n"+      Bin _ kx x l r+          -> showsBars bars . showString (showelem kx x) . showString "\n" .+             showWide wide bars .+             showsTreeHang showelem wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang showelem wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal map structure is valid.+--+-- > valid (fromAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b")]) == False++valid :: Ord k => Map k a -> Bool+valid t+  = balanced t && ordered t && validsize t++-- | Test if the keys are ordered correctly.+ordered :: Ord a => Map a b -> Bool+ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t'+      = case t' of+          Tip              -> True+          Bin _ kx _ l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r++-- | Test if a map obeys the balance invariants.+balanced :: Map k a -> Bool+balanced t+  = case t of+      Tip            -> True+      Bin _ _ _ l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                        balanced l && balanced r++-- | Test if each node of a map reports its size correctly.+validsize :: Map a b -> Bool+validsize t = case slowSize t of+      Nothing -> False+      Just _ -> True+  where+    slowSize Tip = Just 0+    slowSize (Bin sz _ _ l r) = do+            ls <- slowSize l+            rs <- slowSize r+            guard (sz == ls + rs + 1)+            return sz
+ src/Data/Strict/Map/Autogen/Internal/DeprecatedShowTree.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP, FlexibleContexts, DataKinds #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE MonoLocalBinds #-}+#endif+#if __GLASGOW_HASKELL__ < 710+-- Why do we need this? Guess it doesn't matter; this is all+-- going away soon.+{-# LANGUAGE Trustworthy #-}+#endif++#include "containers.h"++-- | This module simply holds disabled copies of functions from+-- Data.Strict.Map.Autogen.Internal.Debug.+module Data.Strict.Map.Autogen.Internal.DeprecatedShowTree where++import Data.Strict.Map.Autogen.Internal (Map)+import Data.Strict.ContainersUtils.Autogen.TypeError++-- | This function has moved to 'Data.Strict.Map.Autogen.Internal.Debug.showTree'.+showTree :: Whoops "showTree has moved to Data.Strict.Map.Autogen.Internal.Debug.showTree."+         => Map k a -> String+showTree _ = undefined++-- | This function has moved to 'Data.Strict.Map.Autogen.Internal.Debug.showTreeWith'.+showTreeWith ::+      Whoops "showTreeWith has moved to Data.Strict.Map.Autogen.Internal.Debug.showTreeWith."+   => (k -> a -> String) -> Bool -> Bool -> Map k a -> String+showTreeWith _ _ _ _ = undefined
+ src/Data/Strict/Map/Autogen/Merge/Strict.hs view
@@ -0,0 +1,106 @@+{-# 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.Strict.Map.Autogen.Merge.Strict+-- Copyright   :  (c) David Feuer 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.Strict.Map.Autogen.Merge.Strict.mapMissing'+-- from this module then the results will be forced before they are+-- inserted. If you use 'Data.Strict.Map.Autogen.Merge.Lazy.mapMissing' from+-- "Data.Strict.Map.Autogen.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 '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.Strict.Map.Autogen.Merge.Strict (+    -- ** Simple merge tactic types+      SimpleWhenMissing+    , SimpleWhenMatched++    -- ** General combining function+    , merge++    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched++    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , 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.Strict.Map.Autogen.Strict.Internal
+ src/Data/Strict/Map/Autogen/Strict.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.Map.Autogen.Strict+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Maps (strict interface)+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ 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+-- necessary. When laziness /is/ required, use the functions in "Data.Strict.Map.Autogen.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.+--+-- When deciding if this is the correct data structure to use, consider:+--+-- * 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>+-- package instead.+--+-- 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 qualified Data.Strict.Map.Autogen.Strict as Map+--+-- 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.+--+-- Benchmarks comparing "Data.Strict.Map.Autogen.Strict" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == 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 '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 'Data.Functor.Functor', 'Data.Traversable.Traversable' and+-- 'Data.Data.Data' instances are the same as for the "Data.Strict.Map.Autogen.Lazy" module, so+-- if they are used the resulting maps may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets: a balancing act/\",+--     Journal of Functional Programming 3(4):553-562, October 1993,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Strict.Map.Autogen.Internal.++module Data.Strict.Map.Autogen.Strict+    (+    -- * Map type+    Map              -- instance Eq,Show,Read++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- ** From Descending Lists+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * 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++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining functions+    -- | See "Data.Strict.Map.Autogen.Merge.Strict"++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , 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++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+#ifdef __GLASGOW_HASKELL__+    , showTree+    , showTreeWith+#endif+    , valid+    ) where++import Data.Strict.Map.Autogen.Strict.Internal+import Prelude ()
+ src/Data/Strict/Map/Autogen/Strict/Internal.hs view
@@ -0,0 +1,1740 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Trustworthy #-}+#endif+{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.Map.Autogen.Strict.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- An efficient implementation of ordered maps from keys to values+-- (dictionaries).+--+-- API of this module is strict in both the keys and the values.+-- If you need value-lazy maps, use "Data.Strict.Map.Autogen.Lazy" instead.+-- 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 (although that is rarely needed).+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import qualified Data.Strict.Map.Autogen.Strict as Map+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets: a balancing act/\",+--     Journal of Functional Programming 3(4):553-562, October 1993,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of+-- this condition is not detected and if the size limit is exceeded, its+-- behaviour is undefined.+--+-- 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.Data.Data' instances+-- are the same as for the "Data.Strict.Map.Autogen.Lazy" module, so if they are used+-- on strict maps, the resulting maps will be lazy.+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Strict.Map.Autogen.Internal.++module Data.Strict.Map.Autogen.Strict.Internal+    (+    -- * Strictness properties+    -- $strictness++    -- * Map type+    Map(..)          -- instance Eq,Show,Read+    , L.Size++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , merge+    , runWhenMatched+    , runWhenMissing++    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched++    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , preserveMissing'+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , 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++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey+    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+#if defined(__GLASGOW_HASKELL__)+    , showTree+    , showTreeWith+#endif+    , valid+    ) where++import Prelude hiding (lookup,map,filter,foldr,foldl,null,take,drop,splitAt)++import Data.Strict.Map.Autogen.Internal+  ( Map (..)+  , AreWeStrict (..)+  , WhenMissing (..)+  , WhenMatched (..)+  , runWhenMatched+  , runWhenMissing+  , SimpleWhenMissing+  , SimpleWhenMatched+  , preserveMissing+  , preserveMissing'+  , dropMissing+  , filterMissing+  , filterAMissing+  , merge+  , mergeA+  , (!)+  , (!?)+  , (\\)+  , assocs+  , atKeyImpl+#if MIN_VERSION_base(4,8,0)+  , atKeyPlain+#endif+  , balance+  , balanceL+  , balanceR+  , compose+  , elemAt+  , elems+  , empty+  , delete+  , deleteAt+  , deleteFindMax+  , deleteFindMin+  , deleteMin+  , deleteMax+  , difference+  , disjoint+  , drop+  , dropWhileAntitone+  , filter+  , filterWithKey+  , findIndex+  , findMax+  , findMin+  , foldl+  , foldl'+  , foldlWithKey+  , foldlWithKey'+  , foldMapWithKey+  , foldr+  , foldr'+  , foldrWithKey+  , foldrWithKey'+  , glue+  , insertMax+  , intersection+  , isProperSubmapOf+  , isProperSubmapOfBy+  , isSubmapOf+  , isSubmapOfBy+  , keys+  , keysSet+  , link+  , lookup+  , lookupGE+  , lookupGT+  , lookupIndex+  , lookupLE+  , lookupLT+  , lookupMin+  , lookupMax+  , mapKeys+  , mapKeysMonotonic+  , maxView+  , maxViewWithKey+  , member+  , link2+  , minView+  , minViewWithKey+  , notMember+  , null+  , partition+  , partitionWithKey+  , restrictKeys+  , size+  , spanAntitone+  , split+  , splitAt+  , splitLookup+  , splitRoot+  , take+  , takeWhileAntitone+  , toList+  , toAscList+  , toDescList+  , union+  , unions+  , withoutKeys )++#if defined(__GLASGOW_HASKELL__)+import Data.Strict.Map.Autogen.Internal.DeprecatedShowTree (showTree, showTreeWith)+#endif+import Data.Strict.Map.Autogen.Internal.Debug (valid)++import Control.Applicative (Const (..), liftA3)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import qualified Data.Set.Internal as Set+import qualified Data.Strict.Map.Autogen.Internal as L+import Data.Strict.ContainersUtils.Autogen.StrictPair++import Data.Bits (shiftL, shiftR)+#if __GLASGOW_HASKELL__ >= 709+import Data.Coerce+#endif++#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)+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+--+-- This module satisfies the following strictness properties:+--+-- 1. Key arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+--    the map.+--+-- Here's an example illustrating the first property:+--+-- > delete undefined m  ==  undefined+--+-- Here are some examples that illustrate the second property:+--+-- > map (\ v -> undefined) m  ==  undefined      -- m is not empty+-- > mapKeys (\ k -> undefined) m  ==  undefined  -- m is not empty++-- [Note: Pointer equality for sharing]+--+-- We use pointer equality to enhance sharing between the arguments+-- of some functions and their results. Notably, we use it+-- for insert, delete, union, intersection, and difference. We do+-- *not* use it for functions, like insertWith, unionWithKey,+-- intersectionWith, etc., that allow the user to modify the elements.+-- While we *could* do so, we would only get sharing under fairly+-- narrow conditions and at a relatively high cost. It does not seem+-- worth the price.++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Map.Internal.Note: Local 'go' functions and capturing+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault def k = k `seq` go+  where+    go Tip = def+    go (Bin _ kx x l r) = case compare k kx of+      LT -> go l+      GT -> go r+      EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}++-- | /O(1)/. A map with a single element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = x `seq` Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insertion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > 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'++-- See Map.Internal.Note: Type of local 'go' function+insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+  where+    go :: Ord k => k -> a -> Map k a -> Map k a+    go !kx !x Tip = singleton kx x+    go kx x (Bin sz ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go kx x l) r+            GT -> balanceR ky y l (go kx x r)+            EQ -> Bin sz kx x l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > 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"++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith = go+  where+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !y' = f x y in Bin sy kx y' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithR = go+  where+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !y' = f y x in Bin sy ky y' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithR #-}+#else+{-# INLINE insertWithR #-}+#endif++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > 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"++-- See Map.Internal.Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    -- Forcing `kx` may look redundant, but it's possible `compare` will+    -- be lazy.+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !x' = f kx x y+                  in Bin sy kx x' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKeyR = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    -- Forcing `kx` may look redundant, but it's possible `compare` will+    -- be lazy.+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !y' = f ky y x+                  in Bin sy ky y' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKeyR #-}+#else+{-# INLINE insertWithKeyR #-}+#endif++-- | /O(log n)/. Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|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")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++-- See Map.Internal.Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+                    -> (Maybe a, Map k a)+insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)+    go _ !kx x Tip = Nothing :*: singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> let (found :*: l') = go f kx x l+                  in found :*: balanceL ky y l' r+            GT -> let (found :*: r') = go f kx x r+                  in found :*: balanceR ky y l r'+            EQ -> let x' = f kx x y+                  in x' `seq` (Just y :*: Bin sy kx x' l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > 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++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > 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++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey = go+  where+    go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k (Bin sx kx x l r) =+        case compare k kx of+           LT -> Bin sx kx x (go f k l) r+           GT -> Bin sx kx x l (go f k r)+           EQ -> Bin sx kx x' l r+             where !x' = f kx x+#if __GLASGOW_HASKELL__+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > 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"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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"++-- See Map.Internal.Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+  where+    go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k(Bin sx kx x l r) =+        case compare k kx of+           LT -> balanceR kx x (go f k l) r+           GT -> balanceL kx x l (go f k r)+           EQ -> case f kx x of+                   Just x' -> x' `seq` Bin sx kx x' l r+                   Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > 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")++-- See Map.Internal.Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0+ where+   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+   go _ !_ Tip = (Nothing :*: Tip)+   go f k (Bin sx kx x l r) =+          case compare k kx of+               LT -> let (found :*: l') = go f k l+                     in found :*: balanceR kx x l' r+               GT -> let (found :*: r') = go f k r+                     in found :*: balanceL kx x l r'+               EQ -> case f kx x of+                       Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)+                       Nothing -> (Just x :*: glue l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]++-- See Map.Internal.Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+  where+    go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+    go f !k Tip = case f Nothing of+               Nothing -> Tip+               Just x  -> singleton k x++    go f k (Bin sx kx x l r) = case compare k kx of+               LT -> balance kx x (go f k l) r+               GT -> balance kx x l (go f k r)+               EQ -> case f (Just x) of+                       Just x' -> x' `seq` Bin sx kx x' l r+                       Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE alter #-}+#else+{-# 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@.+--+-- @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 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+--------------------------------------------------------------------}++-- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- invalid index is used.+--+-- > 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 (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f i t = i `seq`+  case t of+    Tip -> error "Map.updateAt: index out of range"+    Bin sx kx x l r -> case compare i sizeL of+      LT -> balanceR kx x (updateAt f i l) r+      GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+      EQ -> case f kx x of+              Just x' -> x' `seq` Bin sx kx x' l r+              Nothing -> glue l r+      where+        sizeL = size l++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++-- | /O(log n)/. Update the value at the minimal key.+--+-- > 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"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+  = updateMinWithKey (\_ x -> f x) m++-- | /O(log n)/. Update the value at the maximal key.+--+-- > 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"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+  = updateMaxWithKey (\_ x -> f x) m+++-- | /O(log n)/. Update the value at the minimal key.+--+-- > 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"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip                 = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+                                           Nothing -> r+                                           Just x' -> x' `seq` Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r)    = balanceR kx x (updateMinWithKey f l) r++-- | /O(log n)/. Update the value at the maximal key.+--+-- > 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"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip                 = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+                                           Nothing -> l+                                           Just x' -> x' `seq` Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r)    = balanceL kx x l (updateMaxWithKey f r)++{--------------------------------------------------------------------+  Union.+--------------------------------------------------------------------}++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unionsWith #-}+#endif++{--------------------------------------------------------------------+  Union with a combining function+--------------------------------------------------------------------}+-- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith _f t1 Tip = t1+unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1+unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2+unionWith _f Tip t2 = t2+unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> link k1 x1' (unionWith f l1 l2) (unionWith f r1 r2)+    where !x1' = maybe x1 (f x1) mb+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWith #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/.+-- Union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey _f t1 Tip = t1+unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1+unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2+unionWithKey _f Tip t2 = t2+unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> link k1 x1' (unionWithKey f l1 l2) (unionWithKey f r1 r2)+    where !x1' = maybe x1 (f k1 x1) mb+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- | /O(n+m)/. Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f = merge preserveMissing dropMissing (zipWithMaybeMatched $ \_ x1 x2 -> f x1 x2)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWith #-}+#endif++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f = merge preserveMissing dropMissing (zipWithMaybeMatched f)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWith _f Tip _ = Tip+intersectionWith _f _ Tip = Tip+intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> let !x1' = f x1 x2 in link k x1' l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWith f l1 l2+    !r1r2 = intersectionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWith #-}+#endif++-- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey _f Tip _ = Tip+intersectionWithKey _f _ Tip = Tip+intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> let !x1' = f k x1 x2 in link k x1' l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWithKey f l1 l2+    !r1r2 = intersectionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWithKey #-}+#endif++-- | Map covariantly over a @'WhenMissing' f k x@.+mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f k x a -> WhenMissing f k 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 k x y a -> WhenMatched f k 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+                    => (k -> x -> y -> Maybe z)+                    -> WhenMatched f k 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+                     => (k -> x -> y -> f (Maybe z))+                     -> WhenMatched f k 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+                => (k -> x -> y -> f z)+                -> WhenMatched f k 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+               => (k -> x -> y -> z) -> WhenMatched f k 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 => (k -> x -> Maybe y) -> WhenMissing f k 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 => (k -> x -> y) -> WhenMissing f k 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+                     => (k -> x -> f (Maybe y)) -> WhenMissing f k 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+                     => (k -> x -> f y) -> WhenMissing f k 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 #-}++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | /O(n+m)/. An unsafe universal combining function.+--+-- WARNING: This function can produce corrupt maps and its results+-- may depend on the internal structures of its inputs. Users should+-- prefer 'Data.Strict.Map.Autogen.Merge.Strict.merge' or+-- 'Data.Strict.Map.Autogen.Merge.Strict.mergeA'.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k+             => (k -> a -> b -> Maybe c)+             -> (Map k a -> Map k c)+             -> (Map k b -> Map k c)+             -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+  where+    go Tip t2 = g2 t2+    go t1 Tip = g1 t1+    go (Bin _ kx x l1 r1) t2 =+      case found of+        Nothing -> case g1 (singleton kx x) of+                     Tip -> link2 l' r'+                     (Bin _ _ x' Tip Tip) -> link kx x' l' r'+                     _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"+        Just x2 -> case f kx x x2 of+                     Nothing -> link2 l' r'+                     Just x' -> link kx x' l' r'+      where+        (l2, found, r2) = splitLookup kx t2+        l' = go l1 l2+        r' = go r1 r2+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+  Just y  -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+  Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.5.8++traverseMaybeWithKey :: Applicative f+                     => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)+traverseMaybeWithKey = go+  where+    go _ Tip = pure Tip+    go f (Bin _ kx x Tip Tip) = maybe Tip (\ !x' -> Bin 1 kx x' Tip Tip) <$> f kx x+    go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)+      where+        combine !l' mx !r' = case mx of+          Nothing -> link2 l' r'+          Just !x' -> link kx x' l' r'++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > 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, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > 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, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go f (Bin _ kx x l r) = case f kx x of+      Left y  -> y `seq` (link kx y l1 r1 :*: link2 l2 r2)+      Right z -> z `seq` (link2 l1 r1 :*: link kx z l2 r2)+     where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map f = go+  where+    go Tip = Tip+    go (Bin sx kx x l r) = let !x' = f x in Bin sx kx x' (go l) (go r)+-- We use `go` to let `map` inline. This is important if `f` is a constant+-- function.++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs+ #-}+#endif++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) =+  let x' = f kx x+  in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k $! g a) xs+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f $! g k a) xs+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | /O(n)/.+-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' \`seq\` (k,v')) <$> f k v) ('toList' m)@+-- That is, it behaves much like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value and the values are+-- forced before they are installed in the result map.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)+traverseWithKey f = go+  where+    go Tip = pure Tip+    go (Bin 1 k v _ _) = (\ !v' -> Bin 1 k v' Tip Tip) <$> f k v+    go (Bin s k v l r) = liftA3 (\ l' !v' r' -> Bin s k v' l' r') (go l) (f k v) (go r)+{-# INLINE traverseWithKey #-}++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+  = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip               = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+  let (a1,l') = mapAccumL f a l+      (a2,x') = f a1 kx x+      (a3,r') = mapAccumL f a2 r+  in x' `seq` (a3,Bin sx kx x' l' r')++-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+  let (a1,r') = mapAccumRWithKey f a r+      (a2,x') = f a1 kx x+      (a3,l') = mapAccumRWithKey f a2 l+  in x' `seq` (a3,Bin sx kx x' l' r')++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@. The value at the greater of the two original keys+-- is used as the first argument to @c@.+--+-- > 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"++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeysWith #-}+#endif++{--------------------------------------------------------------------+  Conversions+--------------------------------------------------------------------}++-- | /O(n)/. Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | /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+-- for the key is retained.+--+-- If the keys of the list are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually.+fromList :: Ord k => [(k,a)] -> Map k a+fromList [] = Tip+fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0+                           | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+  where+    not_ordered _ [] = False+    not_ordered kx ((ky,_) : _) = kx >= ky+    {-# INLINE not_ordered #-}++    fromList' t0 xs = Foldable.foldl' ins t0 xs+      where ins t (k,x) = insert k x t++    go !_ t [] = t+    go _ t [(kx, x)] = x `seq` insertMax kx x t+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs+                              | otherwise = case create s xss of+                                  (r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys+                                  (r, _,  ys) -> x `seq` fromList' (link kx x l r) ys++    -- The create is returning a triple (tree, xs, ys). Both xs and ys+    -- represent not yet processed elements and only one of them can be nonempty.+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree+    -- and must be inserted using fromList'. Otherwise the keys have been+    -- ordered so far.+    create !_ [] = (Tip, [], [])+    create s xs@(xp : xss)+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)+                                    | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, [], _) -> res+                      (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)+                                               | otherwise -> case create (s `shiftR` 1) yss of+                                                   (r, zs, ws) -> y `seq` (link ky y l r, zs, ws)+#if __GLASGOW_HASKELL__+{-# INLINABLE fromList #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromListWith #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- > let f k a1 a2 = (show k) ++ a1 ++ a2+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]+-- > fromListWithKey f [] == empty++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t+#if __GLASGOW_HASKELL__+{-# INLINABLE fromListWithKey #-}+#endif++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.++  Note that if [xs] is ascending then:+    fromAscList xs       == fromList xs+    fromAscListWith f xs == fromListWith f xs++  If [xs] is descending then:+    fromDescList xs       == fromList xs+    fromDescListWith f xs == fromListWith f xs+--------------------------------------------------------------------}++-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+--+-- > 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+fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs+  = fromAscListWithKey (\_ x _ -> x) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromAscList #-}+#endif++-- | /O(n)/. Build a map from a descending list in linear time.+-- /The precondition (input list is descending) is not checked./+--+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]+-- > fromDescList [(5,"a"), (5,"b"), (3,"a")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False+fromDescList :: Eq k => [(k,a)] -> Map k a+fromDescList xs+  = fromDescListWithKey (\_ x _ -> x) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromDescList #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > 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++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+  = fromAscListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromAscListWith #-}+#endif++-- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.+-- /The precondition (input list is descending) is not checked./+--+-- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False++fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWith f xs+  = fromDescListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__+{-# INLINABLE fromDescListWith #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > 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++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs+  = fromDistinctAscList (combineEq f xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq _ xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,zz) (x@(kx,xx):xs')+    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'+    | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__+{-# INLINABLE fromAscListWithKey #-}+#endif++-- | /O(n)/. Build a map from a descending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is descending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False++fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWithKey f xs+  = fromDistinctDescList (combineEq f xs)+  where+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+  combineEq _ xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z@(kz,zz) (x@(kx,xx):xs')+    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'+    | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__+{-# INLINABLE fromDescListWithKey #-}+#endif++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > 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++-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList [] = Tip+fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+  where+    go !_ t [] = t+    go s l ((kx, x) : xs) =+      case create s xs of+        (r :*: ys) -> x `seq` let !t' = link kx x l r+                           in go (s `shiftL` 1) t' ys++    create !_ [] = (Tip :*: [])+    create s xs@(x' : xs')+      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_ :*: []) -> res+                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of+                        (r :*: zs) -> y `seq` (link ky y l r :*: zs)++-- | /O(n)/. Build a map from a descending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True+-- > valid (fromDistinctDescList [(5,"a"), (3,"b"), (3,"a")]) == False++-- For some reason, when 'singleton' is used in fromDistinctDescList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctDescList :: [(k,a)] -> Map k a+fromDistinctDescList [] = Tip+fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+  where+    go !_ t [] = t+    go s r ((kx, x) : xs) =+      case create s xs of+        (l :*: ys) -> x `seq` let !t' = link kx x l r+                              in go (s `shiftL` 1) t' ys++    create !_ [] = (Tip :*: [])+    create s xs@(x' : xs')+      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_ :*: []) -> res+                      (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of+                        (l :*: zs) -> y `seq` (link ky y l r :*: zs)
+ src/Data/Strict/Map/Internal.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Strict.Map.Internal where++import Data.Map.Lazy                  as L+import Data.Strict.Map.Autogen.Strict as S++import Control.Monad+import Data.Binary+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex+import Data.Semigroup (Semigroup (..)) -- helps with compatibility+import Data.Strict.Classes++instance (Eq k, Ord k) => Strict (L.Map k v) (S.Map k v) where+  toStrict = S.fromList . L.toList+  toLazy = L.fromList . S.toList+  {-# INLINE toStrict #-}+  {-# INLINE toLazy #-}++-- code copied from indexed-traversable++instance FunctorWithIndex k (S.Map k) where+  imap = S.mapWithKey+  {-# INLINE imap #-}++instance FoldableWithIndex k (S.Map k) where+  ifoldMap = S.foldMapWithKey+  {-# INLINE ifoldMap #-}+  ifoldr   = S.foldrWithKey+  {-# INLINE ifoldr #-}+  ifoldl'  = S.foldlWithKey' . flip+  {-# INLINE ifoldl' #-}++instance TraversableWithIndex k (S.Map k) where+  itraverse = S.traverseWithKey+  {-# INLINE itraverse #-}++-- code copied from binary++instance (Binary k, Binary e) => Binary (S.Map k e) where+    put m = put (S.size m) <> mapM_ put (S.toAscList m)+    get   = liftM S.fromDistinctAscList get
+ src/Data/Strict/Sequence.hs view
@@ -0,0 +1,19 @@+{- | Fully-strict version of "Data.Sequence"++Unlike "Data.Sequence" t'Data.Sequence.Seq' the instances of our {- haddock+ #1251 -} t'Data.Strict.Sequence.Seq' are all strict as well.++You should be able to switch from the former simply by changing your module+imports, and your package dependency from @containers@ to @strict-containers@.+If this doesn't work, please file a bug.++The documentation in the auto-generated modules have not been updated in a+particularly sophisticated way, so may sound weird or contradictory. In those+cases, please re-interpret such weird wording in the context of the above.+-}+module Data.Strict.Sequence+  ( module Data.Strict.Sequence.Autogen+  ) where++import Data.Strict.Sequence.Internal+import Data.Strict.Sequence.Autogen
+ src/Data/Strict/Sequence/Autogen.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE CPP #-}+#ifdef __HADDOCK_VERSION__+{-# OPTIONS_GHC -Wno-unused-imports #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.Sequence.Autogen+-- Copyright   :  (c) Ross Paterson 2005+--                (c) Louis Wasserman 2009+--                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and+--                    Milan Straka 2014+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = Finite sequences+--+-- The @'Seq' a@ type represents a finite sequence of values of+-- type @a@.+--+-- Sequences generally behave very much like lists.+--+-- * The class instances for sequences are all based very closely on those for+-- lists.+--+-- * Many functions in this module have the same names as functions in+-- the "Prelude" or in "Data.List". In almost all cases, these functions+-- behave analogously. For example, 'filter' filters a sequence in exactly the+-- same way that @"Prelude".'Prelude.filter'@ filters a list. The only major+-- exception is the 'lookup' function, which is based on the function by+-- that name in "Data.IntMap" rather than the one in "Prelude".+--+-- There are two major differences between sequences and lists:+--+-- * Sequences support a wider variety of efficient operations than+-- do lists. Notably, they offer+--+--     * Constant-time access to both the front and the rear with+--     '<|', '|>', 'viewl', 'viewr'. For recent GHC versions, this can+--     be done more conveniently using the bidirectional patterns 'Empty',+--     ':<|', and ':|>'. See the detailed explanation in the \"Pattern synonyms\"+--     section.+--     * Logarithmic-time concatenation with '><'+--     * Logarithmic-time splitting with 'splitAt', 'take' and 'drop'+--     * Logarithmic-time access to any element with+--     'lookup', '!?', 'index', 'insertAt', 'deleteAt', 'adjust', and 'update'+--+--   Note that sequences are typically /slower/ than lists when using only+--   operations for which they have the same big-\(O\) complexity: sequences+--   make rather mediocre stacks!+--+-- * Whereas lists can be either finite or infinite, sequences are+-- always finite. As a result, a sequence is strict in its+-- length. Ignoring efficiency, you can imagine that 'Seq' is defined+--+--     @ data Seq a = Empty | a :<| !(Seq a) @+--+--     This means that many operations on sequences are stricter than+--     those on lists. For example,+--+--     @ (1 : undefined) !! 0 = 1 @+--+--     but+--+--     @ (1 :<| undefined) ``index`` 0 = undefined @+--+-- Sequences may also be compared to immutable+-- [arrays](https://hackage.haskell.org/package/array)+-- or [vectors](https://hackage.haskell.org/package/vector).+-- Like these structures, sequences support fast indexing,+-- although not as fast. But editing an immutable array or vector,+-- or combining it with another, generally requires copying the+-- entire structure; sequences generally avoid that, copying only+-- the portion that has changed.+--+-- == Detailed performance information+--+-- An amortized running time is given for each operation, with /n/ referring+-- to the length of the sequence and /i/ being the integral index used by+-- some operations. These bounds hold even in a persistent (shared) setting.+--+-- Despite sequences being structurally strict from a semantic standpoint,+-- they are in fact implemented using laziness internally. As a result,+-- many operations can be performed /incrementally/, producing their results+-- as they are demanded. This greatly improves performance in some cases. These+-- functions include+--+-- * The 'Functor' methods 'fmap' and '<$', along with 'mapWithIndex'+-- * The 'Applicative' methods '<*>', '*>', and '<*'+-- * The zips: 'zipWith', 'zip', etc.+-- * 'inits', 'tails'+-- * 'fromFunction', 'replicate', 'intersperse', and 'cycleTaking'+-- * 'reverse'+-- * 'chunksOf'+--+-- Note that the 'Monad' method, '>>=', is not particularly lazy. It will+-- take time proportional to the sum of the logarithms of the individual+-- result sequences to produce anything whatsoever.+--+-- Several functions take special advantage of sharing to produce+-- results using much less time and memory than one might expect. These+-- are documented individually for functions, but also include certain+-- class methods:+--+-- '<$' and '*>' each take time and space proportional+-- to the logarithm of the size of their result.+--+-- '<*' takes time and space proportional to the product of the length+-- of its first argument and the logarithm of the length of its second+-- argument.+--+-- == Warning+--+-- The size of a 'Seq' must not exceed @maxBound::Int@. Violation+-- of this condition is not detected and if the size limit is exceeded, the+-- behaviour of the sequence is undefined. This is unlikely to occur in most+-- applications, but some care may be required when using '><', '<*>', '*>', or+-- '>>', particularly repeatedly and particularly in combination with+-- 'replicate' or 'fromFunction'.+--+-- == Implementation+--+-- The implementation uses 2-3 finger trees annotated with sizes,+-- as described in section 4.2 of+--+--    * Ralf Hinze and Ross Paterson,+--      [\"Finger trees: a simple general-purpose data structure\"]+--      (http://staff.city.ac.uk/~ross/papers/FingerTree.html),+--      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+--+-----------------------------------------------------------------------------+++module Data.Strict.Sequence.Autogen (+    -- * Finite sequences+#if defined(DEFINE_PATTERN_SYNONYMS)+    Seq (Empty, (:<|), (:|>)),+    -- $patterns+#else+    Seq,+#endif+    -- * Construction+    empty,          -- :: Seq a+    singleton,      -- :: a -> Seq a+    (<|),           -- :: a -> Seq a -> Seq a+    (|>),           -- :: Seq a -> a -> Seq a+    (><),           -- :: Seq a -> Seq a -> Seq a+    fromList,       -- :: [a] -> Seq a+    fromFunction,   -- :: Int -> (Int -> a) -> Seq a+    fromArray,      -- :: Ix i => Array i a -> Seq a+    -- ** Repetition+    replicate,      -- :: Int -> a -> Seq a+    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)+    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)+    cycleTaking,    -- :: Int -> Seq a -> Seq a+    -- ** Iterative construction+    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a+    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a+    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a+    -- * Deconstruction+    -- | Additional functions for deconstructing sequences are available+    -- via the 'Data.Foldable.Foldable' instance of 'Seq'.++    -- ** Queries+    null,           -- :: Seq a -> Bool+    length,         -- :: Seq a -> Int+    -- ** Views+    ViewL(..),+    viewl,          -- :: Seq a -> ViewL a+    ViewR(..),+    viewr,          -- :: Seq a -> ViewR a+    -- * Scans+    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a+    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b+    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    -- * Sublists+    tails,          -- :: Seq a -> Seq (Seq a)+    inits,          -- :: Seq a -> Seq (Seq a)+    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)+    -- ** Sequential searches+    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    filter,         -- :: (a -> Bool) -> Seq a -> Seq a+    -- * Sorting+    sort,           -- :: Ord a => Seq a -> Seq a+    sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a+    sortOn,         -- :: Ord b => (a -> b) -> Seq a -> Seq a+    unstableSort,   -- :: Ord a => Seq a -> Seq a+    unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a+    unstableSortOn, -- :: Ord b => (a -> b) -> Seq a -> Seq a+    -- * Indexing+    lookup,         -- :: Int -> Seq a -> Maybe a+    (!?),           -- :: Seq a -> Int -> Maybe a+    index,          -- :: Seq a -> Int -> a+    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a+    update,         -- :: Int -> a -> Seq a -> Seq a+    take,           -- :: Int -> Seq a -> Seq a+    drop,           -- :: Int -> Seq a -> Seq a+    insertAt,       -- :: Int -> a -> Seq a -> Seq a+    deleteAt,       -- :: Int -> Seq a -> Seq a+    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)+    -- ** Indexing with predicates+    -- | These functions perform sequential searches from the left+    -- or right ends of the sequence, returning indices of matching+    -- elements.+    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]+    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]+    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]+    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]+    -- * Folds+    -- | 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+    -- * Transformations+    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b+    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)+    reverse,        -- :: Seq a -> Seq a+    intersperse,    -- :: a -> Seq a -> Seq a+    -- ** Zips and unzip+    zip,            -- :: Seq a -> Seq b -> Seq (a, b)+    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)+    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)+    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)+    unzipWith       -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)+    ) where++import Data.Strict.Sequence.Autogen.Internal+import Data.Strict.Sequence.Autogen.Internal.Sorting+import Prelude ()+#ifdef __HADDOCK_VERSION__+import Control.Monad (Monad (..))+import Control.Applicative (Applicative (..))+import Data.Functor (Functor (..))+#endif++{- $patterns++== Pattern synonyms++Much like lists can be constructed and matched using the+@:@ and @[]@ constructors, sequences can be constructed and+matched using the 'Empty', ':<|', and ':|>' pattern synonyms.++=== Note++These patterns are only available with GHC version 8.0 or later,+and version 8.2 works better with them. When writing for such recent+versions of GHC, the patterns can be used in place of 'empty',+'<|', '|>', 'viewl', and 'viewr'.++=== __Pattern synonym examples__++Import the patterns:++@+import Data.Strict.Sequence.Autogen (Seq (..))+@++Look at the first three elements of a sequence++@+getFirst3 :: Seq a -> Maybe (a,a,a)+getFirst3 (x1 :<| x2 :<| x3 :<| _xs) = Just (x1,x2,x3)+getFirst3 _ = Nothing+@++@+\> getFirst3 ('fromList' [1,2,3,4]) = Just (1,2,3)+\> getFirst3 ('fromList' [1,2]) = Nothing+@++Move the last two elements from the end of the first list+onto the beginning of the second one.++@+shift2Right :: Seq a -> Seq a -> (Seq a, Seq a)+shift2Right Empty ys = (Empty, ys)+shift2Right (Empty :|> x) ys = (Empty, x :<| ys)+shift2Right (xs :|> x1 :|> x2) = (xs, x1 :<| x2 :<| ys)+@++@+\> shift2Right ('fromList' []) ('fromList' [10]) = ('fromList' [], 'fromList' [10])+\> shift2Right ('fromList' [9]) ('fromList' [10]) = ('fromList' [], 'fromList' [9,10])+\> shift2Right ('fromList' [8,9]) ('fromList' [10]) = ('fromList' [], 'fromList' [8,9,10])+\> shift2Right ('fromList' [7,8,9]) ('fromList' [10]) = ('fromList' [7], 'fromList' [8,9,10])+@+-}
+ src/Data/Strict/Sequence/Autogen/Internal.hs view
@@ -0,0 +1,4926 @@+{-# LANGUAGE CPP #-}+#include "containers.h"+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+#endif+#ifdef DEFINE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+#endif+{-# LANGUAGE PatternGuards #-}++{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Strict.Sequence.Autogen.Internal+-- Copyright   :  (c) Ross Paterson 2005+--                (c) Louis Wasserman 2009+--                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and+--                    Milan Straka 2014+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- General purpose finite sequences.+-- Apart from being finite and having strict operations, sequences+-- also differ from lists in supporting a wider variety of operations+-- efficiently.+--+-- An amortized running time is given for each operation, with \( n \) referring+-- to the length of the sequence and \( i \) being the integral index used by+-- some operations. These bounds hold even in a persistent (shared) setting.+--+-- The implementation uses 2-3 finger trees annotated with sizes,+-- as described in section 4.2 of+--+--    * Ralf Hinze and Ross Paterson,+--      \"Finger trees: a simple general-purpose data structure\",+--      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+--      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>+--+-- /Note/: Many of these operations have the same names as similar+-- operations on lists in the "Prelude". The ambiguity may be resolved+-- using either qualification or the @hiding@ clause.+--+-- /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@.  Violation+-- of this condition is not detected and if the size limit is exceeded, the+-- behaviour of the sequence is undefined.  This is unlikely to occur in most+-- applications, but some care may be required when using '><', '<*>', '*>', or+-- '>>', particularly repeatedly and particularly in combination with+-- 'replicate' or 'fromFunction'.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++module Data.Strict.Sequence.Autogen.Internal (+    Elem(..), FingerTree(..), Node(..), Digit(..), Sized(..), MaybeForce,+#if defined(DEFINE_PATTERN_SYNONYMS)+    Seq (.., Empty, (:<|), (:|>)),+#else+    Seq (..),+#endif+    State(..),+    execState,+    foldDigit,+    foldNode,+    foldWithIndexDigit,+    foldWithIndexNode,++    -- * Construction+    empty,          -- :: Seq a+    singleton,      -- :: a -> Seq a+    (<|),           -- :: a -> Seq a -> Seq a+    (|>),           -- :: Seq a -> a -> Seq a+    (><),           -- :: Seq a -> Seq a -> Seq a+    fromList,       -- :: [a] -> Seq a+    fromFunction,   -- :: Int -> (Int -> a) -> Seq a+    fromArray,      -- :: Ix i => Array i a -> Seq a+    -- ** Repetition+    replicate,      -- :: Int -> a -> Seq a+    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)+    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)+    cycleTaking,    -- :: Int -> Seq a -> Seq a+    -- ** Iterative construction+    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a+    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a+    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a+    -- * Deconstruction+    -- | Additional functions for deconstructing sequences are available+    -- via the 'Foldable' instance of 'Seq'.++    -- ** Queries+    null,           -- :: Seq a -> Bool+    length,         -- :: Seq a -> Int+    -- ** Views+    ViewL(..),+    viewl,          -- :: Seq a -> ViewL a+    ViewR(..),+    viewr,          -- :: Seq a -> ViewR a+    -- * Scans+    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a+    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b+    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    -- * Sublists+    tails,          -- :: Seq a -> Seq (Seq a)+    inits,          -- :: Seq a -> Seq (Seq a)+    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)+    -- ** Sequential searches+    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    filter,         -- :: (a -> Bool) -> Seq a -> Seq a+    -- * Indexing+    lookup,         -- :: Int -> Seq a -> Maybe a+    (!?),           -- :: Seq a -> Int -> Maybe a+    index,          -- :: Seq a -> Int -> a+    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a+    update,         -- :: Int -> a -> Seq a -> Seq a+    take,           -- :: Int -> Seq a -> Seq a+    drop,           -- :: Int -> Seq a -> Seq a+    insertAt,       -- :: Int -> a -> Seq a -> Seq a+    deleteAt,       -- :: Int -> Seq a -> Seq a+    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)+    -- ** Indexing with predicates+    -- | These functions perform sequential searches from the left+    -- or right ends of the sequence, returning indices of matching+    -- elements.+    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]+    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]+    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]+    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]+    -- * Folds+    -- | General folds are available via the '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+    -- * Transformations+    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b+    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)+    reverse,        -- :: Seq a -> Seq a+    intersperse,    -- :: a -> Seq a -> Seq a+    liftA2Seq,      -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+    -- ** Zips and unzips+    zip,            -- :: Seq a -> Seq b -> Seq (a, b)+    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)+    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)+    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)+    unzipWith,      -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)+    deep,+    node2,+    node3,+    ) where++import Prelude hiding (+    Functor(..),+#if MIN_VERSION_base(4,11,0)+    (<>),+#endif+#if MIN_VERSION_base(4,8,0)+    Applicative, (<$>), foldMap, Monoid,+#endif+    null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1,+    scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,+    unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)+import qualified Data.List+import Control.Applicative (Applicative(..), (<$>), (<**>),  Alternative,+                            liftA2, liftA3)+import qualified Control.Applicative as Applicative+import Control.DeepSeq (NFData(rnf))+import Control.Monad (MonadPlus(..))+import Data.Monoid (Monoid(..))+import Data.Functor (Functor(..))+import Data.Strict.ContainersUtils.Autogen.State (State(..), execState)+import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList)++#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Semigroup+import Data.Functor.Classes+#endif+import Data.Traversable+import Data.Typeable++-- GHC specific stuff+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build)+import Text.Read (Lexeme(Ident), lexP, parens, prec,+    readPrec, readListPrec, readListPrecDefault)+import Data.Data+import Data.String (IsString(..))+#endif+#if __GLASGOW_HASKELL__+import GHC.Generics (Generic, Generic1)+#endif++-- Array stuff, with GHC.Arr on GHC+import Data.Array (Ix, Array)+import qualified Data.Array+#ifdef __GLASGOW_HASKELL__+import qualified GHC.Arr+#endif++import Data.Strict.ContainersUtils.Autogen.Coercions ((.#), (.^#))+-- Coercion on GHC 7.8++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+import qualified GHC.Exts+#else+#endif++-- Identity functor on base 4.8 (GHC 7.10+)+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+#endif++#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif++import Data.Strict.ContainersUtils.Autogen.StrictPair (StrictPair (..), toPair)+import Control.Monad.Zip (MonadZip (..))+import Control.Monad.Fix (MonadFix (..), fix)++default ()++-- We define our own copy here, for Monoid only, even though this+-- is now a Semigroup operator in base. The essential reason is that+-- we have absolutely no use for semigroups in this module. Everything+-- that needs to sum things up requires a Monoid constraint to deal+-- with empty sequences. I'm not sure if there's a risk of walking+-- through dictionaries to reach <> from Monoid, but I see no reason+-- to risk it.+infixr 6 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}++infixr 5 `consTree`+infixl 5 `snocTree`+infixr 5 `appendTree0`++infixr 5 ><+infixr 5 <|, :<+infixl 5 |>, :>++#ifdef DEFINE_PATTERN_SYNONYMS+infixr 5 :<|+infixl 5 :|>++#if __GLASGOW_HASKELL__ >= 801+{-# COMPLETE (:<|), Empty #-}+{-# COMPLETE (:|>), Empty #-}+#endif++-- | A bidirectional pattern synonym matching an empty sequence.+--+-- @since 0.5.8+pattern Empty :: Seq a+pattern Empty = Seq EmptyT++-- | A bidirectional pattern synonym viewing the front of a non-empty+-- sequence.+--+-- @since 0.5.8+pattern (:<|) :: a -> Seq a -> Seq a+pattern x :<| xs <- (viewl -> x :< xs)+  where+    x :<| xs = x <| xs++-- | A bidirectional pattern synonym viewing the rear of a non-empty+-- sequence.+--+-- @since 0.5.8+pattern (:|>) :: Seq a -> a -> Seq a+pattern xs :|> x <- (viewr -> xs :> x)+  where+    xs :|> x = xs |> x+#endif++class Sized a where+    size :: a -> Int++-- In much the same way that Sized lets us handle the+-- sizes of elements and nodes uniformly, MaybeForce lets+-- us handle their strictness (or lack thereof) uniformly.+-- We can `mseq` something and not have to worry about+-- whether it's an element or a node.+class MaybeForce a where+  maybeRwhnf :: a -> ()++mseq :: MaybeForce a => a -> b -> b+mseq a b = case maybeRwhnf a of () -> b+{-# INLINE mseq #-}++infixr 0 $!?+($!?) :: MaybeForce a => (a -> b) -> a -> b+f $!? a = case maybeRwhnf a of () -> f a+{-# INLINE ($!?) #-}++instance MaybeForce (Elem a) where+  maybeRwhnf _ = ()+  {-# INLINE maybeRwhnf #-}++instance MaybeForce (Node a) where+  maybeRwhnf !_ = ()+  {-# INLINE maybeRwhnf #-}++-- A wrapper making mseq = seq+newtype ForceBox a = ForceBox a+instance MaybeForce (ForceBox a) where+  maybeRwhnf !_ = ()+instance Sized (ForceBox a) where+  size _ = 1++-- | General-purpose finite sequences.+newtype Seq a = Seq (FingerTree (Elem a))++instance Functor Seq where+    fmap = fmapSeq+#ifdef __GLASGOW_HASKELL__+    x <$ s = replicate (length s) x+#endif++fmapSeq :: (a -> b) -> Seq a -> Seq b+fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)+#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] fmapSeq #-}+{-# RULES+"fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.+{-# RULES+"fmapSeq/coerce" fmapSeq coerce = coerce+ #-}+#endif++getSeq :: Seq a -> FingerTree (Elem a)+getSeq (Seq xs) = xs++instance Foldable Seq where+    foldMap f = foldMap (f .# getElem) .# getSeq+    foldr f z = foldr (f .# getElem) z .# getSeq+    foldl f z = foldl (f .^# getElem) z .# getSeq++#if __GLASGOW_HASKELL__+    {-# INLINABLE foldMap #-}+    {-# INLINABLE foldr #-}+    {-# INLINABLE foldl #-}+#endif++    foldr' f z = foldr' (f .# getElem) z .# getSeq+    foldl' f z = foldl' (f .^# getElem) z .# getSeq++#if __GLASGOW_HASKELL__+    {-# INLINABLE foldr' #-}+    {-# INLINABLE foldl' #-}+#endif++    foldr1 f (Seq xs) = getElem (foldr1 f' xs)+      where f' (Elem x) (Elem y) = Elem (f x y)++    foldl1 f (Seq xs) = getElem (foldl1 f' xs)+      where f' (Elem x) (Elem y) = Elem (f x y)++#if MIN_VERSION_base(4,8,0)+    length = length+    {-# INLINE length #-}+    null   = null+    {-# INLINE null #-}+#endif++instance Traversable Seq where+#if __GLASGOW_HASKELL__+    {-# INLINABLE traverse #-}+#endif+    traverse _ (Seq EmptyT) = pure (Seq EmptyT)+    traverse f' (Seq (Single (Elem x'))) =+        (\x'' -> Seq (Single (Elem x''))) <$> f' x'+    traverse f' (Seq (Deep s' pr' m' sf')) =+        liftA3+            (\pr'' m'' sf'' -> Seq (Deep s' pr'' m'' sf''))+            (traverseDigitE f' pr')+            (traverseTree (traverseNodeE f') m')+            (traverseDigitE f' sf')+      where+        traverseTree+            :: Applicative f+            => (Node a -> f (Node b))+            -> FingerTree (Node a)+            -> f (FingerTree (Node b))+        traverseTree _ EmptyT = pure EmptyT+        traverseTree f (Single x) = Single <$> f x+        traverseTree f (Deep s pr m sf) =+            liftA3+                (Deep s)+                (traverseDigitN f pr)+                (traverseTree (traverseNodeN f) m)+                (traverseDigitN f sf)+        traverseDigitE+            :: Applicative f+            => (a -> f b) -> Digit (Elem a) -> f (Digit (Elem b))+        traverseDigitE f (One (Elem a)) =+            (\a' -> One (Elem a')) <$>+            f a+        traverseDigitE f (Two (Elem a) (Elem b)) =+            liftA2+                (\a' b' -> Two (Elem a') (Elem b'))+                (f a)+                (f b)+        traverseDigitE f (Three (Elem a) (Elem b) (Elem c)) =+            liftA3+                (\a' b' c' ->+                      Three (Elem a') (Elem b') (Elem c'))+                (f a)+                (f b)+                (f c)+        traverseDigitE f (Four (Elem a) (Elem b) (Elem c) (Elem d)) =+            liftA3+                (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d'))+                (f a)+                (f b)+                (f c) <*> +                (f d)+        traverseDigitN+            :: Applicative f+            => (Node a -> f (Node b)) -> Digit (Node a) -> f (Digit (Node b))+        traverseDigitN f t = traverse f t+        traverseNodeE+            :: Applicative f+            => (a -> f b) -> Node (Elem a) -> f (Node (Elem b))+        traverseNodeE f (Node2 s (Elem a) (Elem b)) =+            liftA2+                (\a' b' -> Node2 s (Elem a') (Elem b'))+                (f a)+                (f b)+        traverseNodeE f (Node3 s (Elem a) (Elem b) (Elem c)) =+            liftA3+                (\a' b' c' ->+                      Node3 s (Elem a') (Elem b') (Elem c'))+                (f a)+                (f b)+                (f c)+        traverseNodeN+            :: Applicative f+            => (Node a -> f (Node b)) -> Node (Node a) -> f (Node (Node b))+        traverseNodeN f t = traverse f t++instance NFData a => NFData (Seq a) where+    rnf (Seq xs) = rnf xs++instance Monad Seq where+    return = pure+    xs >>= f = foldl' add empty xs+      where add ys x = ys >< f x+    (>>) = (*>)++-- | @since 0.5.11+instance MonadFix Seq where+    mfix = mfixSeq++-- This is just like the instance for lists, but we can take advantage of+-- constant-time length and logarithmic-time indexing to speed things up.+-- Using fromFunction, we make this about as lazy as we can.+mfixSeq :: (a -> Seq a) -> Seq a+mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k))+  where+    err = error "mfix for Data.Strict.Sequence.Autogen.Seq applied to strict function"++-- | @since 0.5.4+instance Applicative Seq where+    pure = singleton+    xs *> ys = cycleNTimes (length xs) ys+    (<*>) = apSeq+#if MIN_VERSION_base(4,10,0)+    liftA2 = liftA2Seq+#endif+    xs <* ys = beforeSeq xs ys++apSeq :: Seq (a -> b) -> Seq a -> Seq b+apSeq fs xs@(Seq xsFT) = case viewl fs of+  EmptyL -> empty+  firstf :< fs' -> case viewr fs' of+    EmptyR -> fmap firstf xs+    Seq fs''FT :> lastf -> case rigidify xsFT of+         RigidEmpty -> empty+         RigidOne (Elem x) -> fmap ($x) fs+         RigidTwo (Elem x1) (Elem x2) ->+            Seq $ ap2FT firstf fs''FT lastf (x1, x2)+         RigidThree (Elem x1) (Elem x2) (Elem x3) ->+            Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)+         RigidFull r@(Rigid s pr _m sf) -> Seq $+               Deep (s * length fs)+                    (fmap (fmap firstf) (nodeToDigit pr))+                    (liftA2Middle (fmap firstf) (fmap lastf) fmap fs''FT r)+                    (fmap (fmap lastf) (nodeToDigit sf))+{-# NOINLINE [1] apSeq #-}++{-# RULES+"ap/fmap1" forall f xs ys . apSeq (fmapSeq f xs) ys = liftA2Seq f xs ys+"ap/fmap2" forall f gs xs . apSeq gs (fmapSeq f xs) =+                              liftA2Seq (\g x -> g (f x)) gs xs+"fmap/ap" forall f gs xs . fmapSeq f (gs `apSeq` xs) =+                             liftA2Seq (\g x -> f (g x)) gs xs+"fmap/liftA2" forall f g m n . fmapSeq f (liftA2Seq g m n) =+                       liftA2Seq (\x y -> f (g x y)) m n+"liftA2/fmap1" forall f g m n . liftA2Seq f (fmapSeq g m) n =+                       liftA2Seq (\x y -> f (g x) y) m n+"liftA2/fmap2" forall f g m n . liftA2Seq f m (fmapSeq g n) =+                       liftA2Seq (\x y -> f x (g y)) m n+ #-}++ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)+ap2FT firstf fs lastf (x,y) =+                 Deep (size fs * 2 + 4)+                      (Two (Elem $ firstf x) (Elem $ firstf y))+                      (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)+                      (Two (Elem $ lastf x) (Elem $ lastf y))++ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)+ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)+                        (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))+                        (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs)+                        (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))++lift2FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b) -> FingerTree (Elem c)+lift2FT f firstx xs lastx (y1,y2) =+                 Deep (size xs * 2 + 4)+                      (Two (Elem $ f firstx y1) (Elem $ f firstx y2))+                      (mapMulFT 2 (\(Elem x) -> Node2 2 (Elem (f x y1)) (Elem (f x y2))) xs)+                      (Two (Elem $ f lastx y1) (Elem $ f lastx y2))++lift3FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b,b) -> FingerTree (Elem c)+lift3FT f firstx xs lastx (y1,y2,y3) =+                 Deep (size xs * 3 + 6)+                      (Three (Elem $ f firstx y1) (Elem $ f firstx y2) (Elem $ f firstx y3))+                      (mapMulFT 3 (\(Elem x) -> Node3 3 (Elem (f x y1)) (Elem (f x y2)) (Elem (f x y3))) xs)+                      (Three (Elem $ f lastx y1) (Elem $ f lastx y2) (Elem $ f lastx y3))++liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+liftA2Seq f xs ys@(Seq ysFT) = case viewl xs of+  EmptyL -> empty+  firstx :< xs' -> case viewr xs' of+    EmptyR -> f firstx <$> ys+    Seq xs''FT :> lastx -> case rigidify ysFT of+      RigidEmpty -> empty+      RigidOne (Elem y) -> fmap (\x -> f x y) xs+      RigidTwo (Elem y1) (Elem y2) ->+        Seq $ lift2FT f firstx xs''FT lastx (y1, y2)+      RigidThree (Elem y1) (Elem y2) (Elem y3) ->+        Seq $ lift3FT f firstx xs''FT lastx (y1, y2, y3)+      RigidFull r@(Rigid s pr _m sf) -> Seq $+        Deep (s * length xs)+             (fmap (fmap (f firstx)) (nodeToDigit pr))+             (liftA2Middle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r)+             (fmap (fmap (f lastx)) (nodeToDigit sf))+  where+    lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c+#if __GLASGOW_HASKELL__ >= 708+    lift_elem = coerce+#else+    lift_elem f x (Elem y) = Elem (f x y)+#endif+{-# NOINLINE [1] liftA2Seq #-}+++data Rigidified a = RigidEmpty+                  | RigidOne a+                  | RigidTwo a a+                  | RigidThree a a a+                  | RigidFull (Rigid a)+#ifdef TESTING+                  deriving Show+#endif++-- | A finger tree whose top level has only Two and/or Three digits, and whose+-- other levels have only One and Two digits. A Rigid tree is precisely what one+-- gets by unzipping/inverting a 2-3 tree, so it is precisely what we need to+-- turn a finger tree into in order to transform it into a 2-3 tree.+data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)+#ifdef TESTING+             deriving Show+#endif++-- | A finger tree whose digits are all ones and twos+data Thin a = EmptyTh+            | SingleTh a+            | DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)+#ifdef TESTING+            deriving Show+#endif++data Digit12 a = One12 a | Two12 a a+#ifdef TESTING+        deriving Show+#endif++-- | Sometimes, we want to emphasize that we are viewing a node as a top-level+-- digit of a 'Rigid' tree.+type Digit23 a = Node a++-- | 'liftA2Middle' does most of the hard work of computing @liftA2 f xs ys@.  It+-- produces the center part of a finger tree, with a prefix corresponding to+-- the first element of @xs@ and a suffix corresponding to its last element omitted;+-- the missing suffix and prefix are added by the caller.  For the recursive+-- call, it squashes the prefix and the suffix into the center tree. Once it+-- 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.+--+-- @f@ 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 @f@ explicitly through the+-- recursion.+--+-- === Description of parameters+--+-- ==== Types+--+-- @a@ remains constant through recursive calls (in the @DeepTh@ case),+-- while @b@ and @c@ do not: 'liftAMiddle' calls itself at types @Node b@ and+-- @Node c@.+--+-- ==== Values+--+-- 'liftA2Middle' is used when the original @xs :: Sequence a@ has at+-- least two elements, so it can be decomposed by taking off the first and last+-- elements:+--+-- > xs = firstx <: midxs :> lastx+--+-- - the first two arguments @ffirstx, flastx :: b -> c@ are equal to+--   @f firstx@ and @f lastx@, where @f :: a -> b -> c@ is the third argument.+--   This ensures sharing when @f@ computes some data upon being partially+--   applied to its first argument. The way @f@ gets accumulated also ensures+--   sharing for the middle section.+--+-- - the fourth argument is the middle part @midxs@, always constant.+--+-- - the last argument, a tuple of type @Rigid b@, holds all the elements of+--   @ys@, in three parts: a middle part around which the recursion is+--   structured, surrounded by a prefix and a suffix that accumulate+--   elements on the side as we walk down the middle.+--+-- === Invariants+--+-- > 1. Viewing the various trees as the lists they represent+-- >    (the types of the toList functions are given a few paragraphs below):+-- >+-- >    toListFTN result+-- >      =  (ffirstx                    <$> (toListThinN m ++ toListD sf))+-- >      ++ (f      <$> toListFTE midxs <*> (toListD pr ++ toListThinN m ++ toListD sf))+-- >      ++ (flastx                     <$> (toListD pr ++ toListThinN m))+-- >+-- > 2. s = size m + size pr + size sf+-- >+-- > 3. size (ffirstx y) = size (flastx y) = size (f x y) = size y+-- >      for any (x :: a) (y :: b)+--+-- Projecting invariant 1 on sizes, using 2 and 3 to simplify, we have the+-- following corollary.+-- It is weaker than invariant 1, but it may be easier to keep track of.+--+-- > 1a. size result = s * (size midxs + 1) + size m+--+-- In invariant 1, the types of the auxiliary functions are as follows+-- for reference:+--+-- > toListFTE   :: FingerTree (Elem a) -> [a]+-- > toListFTN   :: FingerTree (Node c) -> [c]+-- > toListThinN :: Thin (Node b) -> [b]+-- > toListD     :: Digit12 b -> [b]+liftA2Middle+  :: (b -> c)              -- ^ @ffirstx@+  -> (b -> c)              -- ^ @flastx@+  -> (a -> b -> c)         -- ^ @f@+  -> FingerTree (Elem a)   -- ^ @midxs@+  -> Rigid b               -- ^ @Rigid s pr m sf@ (@pr@: prefix, @sf@: suffix)+  -> FingerTree (Node c)++-- Not at the bottom yet++liftA2Middle+    ffirstx+    flastx+    f+    midxs+    (Rigid s pr (DeepTh sm prm mm sfm) sf)+    -- note: size (DeepTh sm pr mm sfm) = sm = size pr + size mm + size sfm+    = Deep (sm + s * (size midxs + 1)) -- note: sm = s - size pr - size sf+           (fmap (fmap ffirstx) (digit12ToDigit prm))+           (liftA2Middle+               (fmap ffirstx)+               (fmap flastx)+               (fmap . f)+               midxs+               (Rigid s (squashL pr prm) mm (squashR sfm sf)))+           (fmap (fmap flastx) (digit12ToDigit sfm))++-- At the bottom++liftA2Middle+    ffirstx+    flastx+    f+    midxs+    (Rigid s pr EmptyTh sf)+    = deep+           (One (fmap ffirstx sf))+           (mapMulFT s (\(Elem x) -> fmap (fmap (f x)) converted) midxs)+           (One (fmap flastx pr))+   where converted = node2 pr sf++liftA2Middle+    ffirstx+    flastx+    f+    midxs+    (Rigid s pr (SingleTh q) sf)+    = deep+           (Two (fmap ffirstx q) (fmap ffirstx sf))+           (mapMulFT s (\(Elem x) -> fmap (fmap (f x)) converted) midxs)+           (Two (fmap flastx pr) (fmap flastx q))+   where converted = node3 pr q sf++digit12ToDigit :: Digit12 a -> Digit a+digit12ToDigit (One12 a) = One a+digit12ToDigit (Two12 a b) = Two a b++-- Squash the first argument down onto the left side of the second.+squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)+squashL m (One12 n) = node2 m n+squashL m (Two12 n1 n2) = node3 m n1 n2++-- Squash the second argument down onto the right side of the first+squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)+squashR (One12 n) m = node2 n m+squashR (Two12 n1 n2) m = node3 n1 n2 m+++-- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size+-- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the+-- function is applied to the "leaves" of the 'FingerTree' (i.e., given a+-- @FingerTree (Elem a)@, it applies the function to elements of type @Elem+-- a@), replacing the leaves with subtrees of at least the same height, e.g.,+-- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations+-- match up properly.+mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b+mapMulFT !_ _ EmptyT = EmptyT+mapMulFT _mul f (Single a) = Single (f a)+mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)++mapMulNode :: Int -> (a -> b) -> Node a -> Node b+mapMulNode mul f (Node2 s a b)   = Node2 (mul * s) (f a) (f b)+mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)++-- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'+-- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have+-- only two and three digits at the top level and only one and two+-- digits elsewhere. If the tree has fewer than four elements, 'rigidify'+-- will simply extract them, and will not build a tree.+rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)+-- The patterns below just fix up the top level of the tree; 'rigidify'+-- delegates the hard work to 'thin'.++rigidify EmptyT = RigidEmpty++rigidify (Single q) = RigidOne q++-- The left digit is Two or Three+rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf+rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf++-- The left digit is Four+rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf++-- The left digit is One+rigidify (Deep s (One a) m sf) = case viewLTree m of+   ConsLTree (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf+   ConsLTree (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf+   EmptyLTree -> case sf of+     One b -> RigidTwo a b+     Two b c -> RigidThree a b c+     Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)+     Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)++-- | /O(log n)/ (incremental) Takes a tree whose left side has been rigidified+-- and finishes the job.+rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)++-- The right digit is Two, Three, or Four+rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)+rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)+rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)++-- The right digit is One+rigidifyRight s pr m (One e) = case viewRTree m of+    SnocRTree m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)+    SnocRTree m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)+    EmptyRTree -> case pr of+      Node2 _ a b -> RigidThree a b e+      Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)++-- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones+-- and twos.+thin :: Sized a => FingerTree a -> Thin a+-- Note that 'thin12' will produce a 'DeepTh' constructor immediately before+-- recursively calling 'thin'.+thin EmptyT = EmptyTh+thin (Single a) = SingleTh a+thin (Deep s pr m sf) =+  case pr of+    One a -> thin12 s (One12 a) m sf+    Two a b -> thin12 s (Two12 a b) m sf+    Three a b c  -> thin12 s (One12 a) (node2 b c `consTree` m) sf+    Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf++thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a+thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)+thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)+thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)+thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)++-- | \( O(n) \). Intersperse an element between the elements of a sequence.+--+-- @+-- intersperse a empty = empty+-- 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 = case viewl xs of+  EmptyL -> empty+  p :< ps -> p <| (ps <**> (const y <| singleton id))+-- We used to use+--+-- intersperse y xs = drop 1 $ xs <**> (const y <| singleton id)+--+-- but if length xs = ((maxBound :: Int) `quot` 2) + 1 then+--+-- length (xs <**> (const y <| singleton id)) will wrap around to negative+-- and the drop won't work. The new implementation can produce a result+-- right up to maxBound :: Int++instance MonadPlus Seq where+    mzero = empty+    mplus = (><)++-- | @since 0.5.4+instance Alternative Seq where+    empty = empty+    (<|>) = (><)++instance Eq a => Eq (Seq a) where+    xs == ys = length xs == length ys && toList xs == toList ys++instance Ord a => Ord (Seq a) where+    compare xs ys = compare (toList xs) (toList ys)++#ifdef TESTING+instance Show a => Show (Seq a) where+    showsPrec p (Seq x) = showsPrec p x+#else+instance Show a => Show (Seq a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)+#endif++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.9+instance Show1 Seq where+  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $+        showString "fromList " . shwList (toList xs)++-- | @since 0.5.9+instance Eq1 Seq where+    liftEq eq xs ys = length xs == length ys && liftEq eq (toList xs) (toList ys)++-- | @since 0.5.9+instance Ord1 Seq where+    liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys)+#endif++instance Read a => Read (Seq a) where+#ifdef __GLASGOW_HASKELL__+    readPrec = parens $ prec 10 $ do+        Ident "fromList" <- lexP+        xs <- readPrec+        return (fromList xs)++    readListPrec = readListPrecDefault+#else+    readsPrec p = readParen (p > 10) $ \ r -> do+        ("fromList",s) <- lex r+        (xs,t) <- reads s+        return (fromList xs,t)+#endif++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.9+instance Read1 Seq where+  liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do+    ("fromList",s) <- lex r+    (xs,t) <- readLst s+    pure (fromList xs, t)+#endif++instance Monoid (Seq a) where+    mempty = empty+#if MIN_VERSION_base(4,9,0)+    mappend = (Semigroup.<>)+#else+    mappend = (><)+#endif++#if MIN_VERSION_base(4,9,0)+-- | @since 0.5.7+instance Semigroup.Semigroup (Seq a) where+    (<>)    = (><)+    stimes = cycleNTimes . fromIntegral+#endif++INSTANCE_TYPEABLE1(Seq)++#if __GLASGOW_HASKELL__+instance Data a => Data (Seq a) where+    gfoldl f z s    = case viewl s of+        EmptyL  -> z empty+        x :< xs -> z (<|) `f` x `f` xs++    gunfold k z c   = case constrIndex c of+        1 -> z empty+        2 -> k (k (z (<|)))+        _ -> error "gunfold"++    toConstr xs+      | null xs     = emptyConstr+      | otherwise   = consConstr++    dataTypeOf _    = seqDataType++    dataCast1 f     = gcast1 f++emptyConstr, consConstr :: Constr+emptyConstr = mkConstr seqDataType "empty" [] Prefix+consConstr  = mkConstr seqDataType "<|" [] Infix++seqDataType :: DataType+seqDataType = mkDataType "Data.Strict.Sequence.Autogen.Seq" [emptyConstr, consConstr]+#endif++-- Finger trees++data FingerTree a+    = EmptyT+    | Single !a+    | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 FingerTree++-- | @since 0.6.1+deriving instance Generic (FingerTree a)+#endif++instance Sized a => Sized (FingerTree a) where+    {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}+    {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}+    size EmptyT             = 0+    size (Single x)         = size x+    size (Deep v _ _ _)     = v++instance Foldable FingerTree where+    foldMap _ EmptyT = mempty+    foldMap f' (Single x') = f' x'+    foldMap f' (Deep _ pr' m' sf') = +        foldMapDigit f' pr' <>+        foldMapTree (foldMapNode f') m' <>+        foldMapDigit f' sf'+      where+        foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m+        foldMapTree _ EmptyT = mempty+        foldMapTree f (Single x) = f x+        foldMapTree f (Deep _ pr m sf) = +            foldMapDigitN f pr <>+            foldMapTree (foldMapNodeN f) m <>+            foldMapDigitN f sf++        foldMapDigit :: Monoid m => (a -> m) -> Digit a -> m+        foldMapDigit f t = foldDigit (<>) f t++        foldMapDigitN :: Monoid m => (Node a -> m) -> Digit (Node a) -> m+        foldMapDigitN f t = foldDigit (<>) f t++        foldMapNode :: Monoid m => (a -> m) -> Node a -> m+        foldMapNode f t = foldNode (<>) f t++        foldMapNodeN :: Monoid m => (Node a -> m) -> Node (Node a) -> m+        foldMapNodeN f t = foldNode (<>) f t+#if __GLASGOW_HASKELL__+    {-# INLINABLE foldMap #-}+#endif++    foldr _ z' EmptyT = z'+    foldr f' z' (Single x') = x' `f'` z'+    foldr f' z' (Deep _ pr' m' sf') =+        foldrDigit f' (foldrTree (foldrNode f') (foldrDigit f' z' sf') m') pr'+      where+        foldrTree :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b+        foldrTree _ z EmptyT = z+        foldrTree f z (Single x) = x `f` z+        foldrTree f z (Deep _ pr m sf) =+            foldrDigitN f (foldrTree (foldrNodeN f) (foldrDigitN f z sf) m) pr++        foldrDigit :: (a -> b -> b) -> b -> Digit a -> b+        foldrDigit f z t = foldr f z t++        foldrDigitN :: (Node a -> b -> b) -> b -> Digit (Node a) -> b+        foldrDigitN f z t = foldr f z t++        foldrNode :: (a -> b -> b) -> Node a -> b -> b+        foldrNode f t z = foldr f z t++        foldrNodeN :: (Node a -> b -> b) -> Node (Node a) -> b -> b+        foldrNodeN f t z = foldr f z t+    {-# INLINE foldr #-}+++    foldl _ z' EmptyT = z'+    foldl f' z' (Single x') = z' `f'` x'+    foldl f' z' (Deep _ pr' m' sf') =+        foldlDigit f' (foldlTree (foldlNode f') (foldlDigit f' z' pr') m') sf'+      where+        foldlTree :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b+        foldlTree _ z EmptyT = z+        foldlTree f z (Single x) = z `f` x+        foldlTree f z (Deep _ pr m sf) =+            foldlDigitN f (foldlTree (foldlNodeN f) (foldlDigitN f z pr) m) sf++        foldlDigit :: (b -> a -> b) -> b -> Digit a -> b+        foldlDigit f z t = foldl f z t++        foldlDigitN :: (b -> Node a -> b) -> b -> Digit (Node a) -> b+        foldlDigitN f z t = foldl f z t++        foldlNode :: (b -> a -> b) -> b -> Node a -> b+        foldlNode f z t = foldl f z t++        foldlNodeN :: (b -> Node a -> b) -> b -> Node (Node a) -> b+        foldlNodeN f z t = foldl f z t+    {-# INLINE foldl #-}++    foldr' _ z' EmptyT = z'+    foldr' f' z' (Single x') = f' x' z'+    foldr' f' z' (Deep _ pr' m' sf') =+        (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr'+      where+        foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b+        foldrTree' _ z EmptyT = z+        foldrTree' f z (Single x) = f x $! z+        foldrTree' f z (Deep _ pr m sf) =+            (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr++        foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b+        foldrDigit' f z t = foldr' f z t++        foldrNode' :: (a -> b -> b) -> Node a -> b -> b+        foldrNode' f t z = foldr' f z t++        foldrNodeN' :: (Node a -> b -> b) -> Node (Node a) -> b -> b+        foldrNodeN' f t z = foldr' f z t+    {-# INLINE foldr' #-}++    foldl' _ z' EmptyT = z'+    foldl' f' z' (Single x') = f' z' x'+    foldl' f' z' (Deep _ pr' m' sf') =+        (foldlDigit' f' $!+         (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m')+            sf'+      where+        foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b+        foldlTree' _ z EmptyT = z+        foldlTree' f z (Single xs) = f z xs+        foldlTree' f z (Deep _ pr m sf) =+            (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf++        foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b+        foldlDigit' f z t = foldl' f z t++        foldlNode' :: (b -> a -> b) -> b -> Node a -> b+        foldlNode' f z t = foldl' f z t+    {-# INLINE foldl' #-}++    foldr1 _ EmptyT = error "foldr1: empty sequence"+    foldr1 _ (Single x) = x+    foldr1 f (Deep _ pr m sf) =+        foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr++    foldl1 _ EmptyT = error "foldl1: empty sequence"+    foldl1 _ (Single x) = x+    foldl1 f (Deep _ pr m sf) =+        foldl f (foldl (foldl f) (foldl1 f pr) m) sf++instance Functor FingerTree where+    fmap _ EmptyT = EmptyT+    fmap f (Single x) = Single (f x)+    fmap f (Deep v pr m sf) =+        Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)++instance Traversable FingerTree where+    traverse _ EmptyT = pure EmptyT+    traverse f (Single x) = Single <$> f x+    traverse f (Deep v pr m sf) =+        liftA3 (Deep v) (traverse f pr) (traverse (traverse f) m)+            (traverse f sf)++instance NFData a => NFData (FingerTree a) where+    rnf EmptyT = ()+    rnf (Single x) = rnf x+    rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m++{-# INLINE deep #-}+deep            :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a+deep pr m sf    =  Deep (size pr + size m + size sf) pr m sf++{-# INLINE pullL #-}+pullL :: Int -> FingerTree (Node a) -> Digit a -> FingerTree a+pullL s m sf = case viewLTree m of+    EmptyLTree          -> digitToTree' s sf+    ConsLTree pr m'     -> Deep s (nodeToDigit pr) m' sf++{-# INLINE pullR #-}+pullR :: Int -> Digit a -> FingerTree (Node a) -> FingerTree a+pullR s pr m = case viewRTree m of+    EmptyRTree          -> digitToTree' s pr+    SnocRTree m' sf     -> Deep s pr m' (nodeToDigit sf)++-- Digits++data Digit a+    = One !a+    | Two !a !a+    | Three !a !a !a+    | Four !a !a !a !a+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 Digit++-- | @since 0.6.1+deriving instance Generic (Digit a)+#endif++foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b+foldDigit _     f (One a) = f a+foldDigit (<+>) f (Two a b) = f a <+> f b+foldDigit (<+>) f (Three a b c) = f a <+> f b <+> f c+foldDigit (<+>) f (Four a b c d) = f a <+> f b <+> f c <+> f d+{-# INLINE foldDigit #-}++instance Foldable Digit where+    foldMap = foldDigit mappend++    foldr f z (One a) = a `f` z+    foldr f z (Two a b) = a `f` (b `f` z)+    foldr f z (Three a b c) = a `f` (b `f` (c `f` z))+    foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))+    {-# INLINE foldr #-}++    foldl f z (One a) = z `f` a+    foldl f z (Two a b) = (z `f` a) `f` b+    foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c+    foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d+    {-# INLINE foldl #-}++    foldr' f z (One a) = f a z+    foldr' f z (Two a b) = f a $! f b z+    foldr' f z (Three a b c) = f a $! f b $! f c z+    foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z+    {-# INLINE foldr' #-}++    foldl' f z (One a) = f z a+    foldl' f z (Two a b) = (f $! f z a) b+    foldl' f z (Three a b c) = (f $! (f $! f z a) b) c+    foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d+    {-# INLINE foldl' #-}++    foldr1 _ (One a) = a+    foldr1 f (Two a b) = a `f` b+    foldr1 f (Three a b c) = a `f` (b `f` c)+    foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))++    foldl1 _ (One a) = a+    foldl1 f (Two a b) = a `f` b+    foldl1 f (Three a b c) = (a `f` b) `f` c+    foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d++instance Functor Digit where+    {-# INLINE fmap #-}+    fmap f (One a) = One (f a)+    fmap f (Two a b) = Two (f a) (f b)+    fmap f (Three a b c) = Three (f a) (f b) (f c)+    fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)++instance Traversable Digit where+    {-# INLINE traverse #-}+    traverse f (One a) = One <$> f a+    traverse f (Two a b) = liftA2 Two (f a) (f b)+    traverse f (Three a b c) = liftA3 Three (f a) (f b) (f c)+    traverse f (Four a b c d) = liftA3 Four (f a) (f b) (f c) <*> f d++instance NFData a => NFData (Digit a) where+    rnf (One a) = rnf a+    rnf (Two a b) = rnf a `seq` rnf b+    rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c+    rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d++instance Sized a => Sized (Digit a) where+    {-# INLINE size #-}+    size = foldl1 (+) . fmap size++{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}+digitToTree     :: Sized a => Digit a -> FingerTree a+digitToTree (One a) = Single a+digitToTree (Two a b) = deep (One a) EmptyT (One b)+digitToTree (Three a b c) = deep (Two a b) EmptyT (One c)+digitToTree (Four a b c d) = deep (Two a b) EmptyT (Two c d)++-- | Given the size of a digit and the digit itself, efficiently converts+-- it to a FingerTree.+digitToTree' :: Int -> Digit a -> FingerTree a+digitToTree' n (Four a b c d) = Deep n (Two a b) EmptyT (Two c d)+digitToTree' n (Three a b c) = Deep n (Two a b) EmptyT (One c)+digitToTree' n (Two a b) = Deep n (One a) EmptyT (One b)+digitToTree' !_n (One a) = Single a++-- Nodes++data Node a+    = Node2 {-# UNPACK #-} !Int !a !a+    | Node3 {-# UNPACK #-} !Int !a !a !a+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 Node++-- | @since 0.6.1+deriving instance Generic (Node a)+#endif++foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b+foldNode (<+>) f (Node2 _ a b) = f a <+> f b+foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c+{-# INLINE foldNode #-}++instance Foldable Node where+    foldMap = foldNode mappend++    foldr f z (Node2 _ a b) = a `f` (b `f` z)+    foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))+    {-# INLINE foldr #-}++    foldl f z (Node2 _ a b) = (z `f` a) `f` b+    foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c+    {-# INLINE foldl #-}++    foldr' f z (Node2 _ a b) = f a $! f b z+    foldr' f z (Node3 _ a b c) = f a $! f b $! f c z+    {-# INLINE foldr' #-}++    foldl' f z (Node2 _ a b) = (f $! f z a) b+    foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c+    {-# INLINE foldl' #-}++instance Functor Node where+    {-# INLINE fmap #-}+    fmap f (Node2 v a b) = Node2 v (f a) (f b)+    fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)++instance Traversable Node where+    {-# INLINE traverse #-}+    traverse f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)+    traverse f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)++instance NFData a => NFData (Node a) where+    rnf (Node2 _ a b) = rnf a `seq` rnf b+    rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c++instance Sized (Node a) where+    size (Node2 v _ _)      = v+    size (Node3 v _ _ _)    = v++{-# INLINE node2 #-}+node2           :: Sized a => a -> a -> Node a+node2 a b       =  Node2 (size a + size b) a b++{-# INLINE node3 #-}+node3           :: Sized a => a -> a -> a -> Node a+node3 a b c     =  Node3 (size a + size b + size c) a b c++nodeToDigit :: Node a -> Digit a+nodeToDigit (Node2 _ a b) = Two a b+nodeToDigit (Node3 _ a b c) = Three a b c++-- Elements++newtype Elem a  =  Elem { getElem :: a }+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 Elem++-- | @since 0.6.1+deriving instance Generic (Elem a)+#endif++instance Sized (Elem a) where+    size _ = 1++instance Functor Elem where+#if __GLASGOW_HASKELL__ >= 708+-- This cuts the time for <*> by around a fifth.+    fmap = coerce+#else+    fmap f (Elem x) = Elem (f x)+#endif++instance Foldable Elem where+    foldr f z (Elem x) = f x z+#if __GLASGOW_HASKELL__ >= 708+    foldMap = coerce+    foldl = coerce+    foldl' = coerce+#else+    foldMap f (Elem x) = f x+    foldl f z (Elem x) = f z x+    foldl' f z (Elem x) = f z x+#endif++instance Traversable Elem where+    traverse f (Elem x) = Elem <$> f x++instance NFData a => NFData (Elem a) where+    rnf (Elem x) = rnf x++-------------------------------------------------------+-- Applicative construction+-------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+newtype Identity a = Identity {runIdentity :: a}++instance Functor Identity where+    fmap f (Identity x) = Identity (f x)++instance Applicative Identity where+    pure = Identity+    Identity f <*> Identity x = Identity (f x)+#endif++-- | 'applicativeTree' takes an Applicative-wrapped construction of a+-- piece of a FingerTree, assumed to always have the same size (which+-- is put in the second argument), and replicates it as many times as+-- specified.  This is a generalization of 'replicateA', which itself+-- is a generalization of many Data.Strict.Sequence.Autogen methods.+{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}+{-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}+-- Special note: the Identity specialization automatically does node sharing,+-- reducing memory usage of the resulting tree to /O(log n)/.+applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)+applicativeTree n !mSize m = case n of+    0 -> pure EmptyT+    1 -> fmap Single m+    2 -> deepA one emptyTree one+    3 -> deepA two emptyTree one+    4 -> deepA two emptyTree two+    5 -> deepA three emptyTree two+    6 -> deepA three emptyTree three+    _ -> case n `quotRem` 3 of+           (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three+           (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two+           (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two+      where !mSize' = 3 * mSize+            n3 = liftA3 (Node3 mSize') m m m+  where+    one = fmap One m+    two = liftA2 Two m m+    three = liftA3 Three m m m+    deepA = liftA3 (Deep (n * mSize))+    emptyTree = pure EmptyT++data RCountMid a = RCountMid+  !(Node a)  -- End of the first+  !Int -- Number of units in the middle+  !(Node a)  -- Beginning of the last++{-+We could generalize beforeSeq quite easily to++  beforeSeq :: (a -> c) -> Seq a -> Seq b -> Seq c++This would let us add a rewrite rule++  fmap f xs <* ys  ==>  beforeSeq f xs ys++We don't currently bother because I don't yet know of a practical use for (<*)+for sequences; a rewrite rule to optimize it seems like extreme overkill.+-}++beforeSeq :: Seq a -> Seq b -> Seq a+beforeSeq xs ys = replicateEach (length ys) xs++-- | Replicate each element of a sequence the given number of times.+--+-- @replicateEach 3 [1,2] = [1,1,1,2,2,2]@+-- @replicateEach n xs = xs >>= replicate n@+replicateEach :: Int -> Seq a -> Seq a+-- The main idea is that we construct a function that takes an element and+-- produces a 2-3 tree representing that element replicated lenys times. We map+-- that function over the sequence to (mostly) produce the desired fingertree. But+-- if we *just* did that, we'd end up with a fingertree of 2-3 trees of the given+-- size, not of elements. So we need to work our way down to the appropriate+-- level by building the left side of the fingertree corresponding to the first+-- 2-3 tree and the right side corresponding to the last one, along with the+-- 2-3 trees corresponding to the right side of the first and the left side of+-- the last.+replicateEach lenys xs = case viewl xs of+  EmptyL -> empty+  firstx :< xs' -> case viewr xs' of+    EmptyR -> replicate lenys firstx+    Seq midxs :> lastx -> case lenys of+      0 -> empty+      1 -> xs+      2 ->+        Seq $ rep2EachFT fxE midxs lxE+      3 ->+        Seq $ rep3EachFT fxE midxs lxE+      _ -> Seq $ case lenys `quotRem` 3 of  -- lenys > 3+             (q,0) -> Deep (lenys * length xs) fd3+               (repEachMiddle_ lift_elem (RCountMid fn3 (q - 2) ln3))+               ld3+                   where+                    lift_elem a = let n3a = n3 a in (n3a, n3a, n3a)+             (q,1) -> Deep (lenys * length xs) fd2+               (repEachMiddle_ lift_elem (RCountMid fn2 (q - 1) ln2))+               ld2+                   where+                    lift_elem a = let n2a = n2 a in (n2a, n3 a, n2a)+             (q,_) -> Deep (lenys * length xs) fd3+               (repEachMiddle_ lift_elem (RCountMid fn2 (q - 1) ln3))+               ld2+                   where+                    lift_elem a = let n3a = n3 a in (n3a, n3a, n2 a)+        where+          repEachMiddle_ = repEachMiddle midxs lenys 3 fn3 ln3+          fd2 = Two fxE fxE+          fd3 = Three fxE fxE fxE+          ld2 = Two lxE lxE+          ld3 = Three lxE lxE lxE+          fn2 = Node2 2 fxE fxE+          fn3 = Node3 3 fxE fxE fxE+          ln2 = Node2 2 lxE lxE+          ln3 = Node3 3 lxE lxE lxE+          n3 a = Node3 3 (Elem a) (Elem a) (Elem a)+          n2 a = Node2 2 (Elem a) (Elem a)+      where+          fxE = Elem firstx+          lxE = Elem lastx++rep2EachFT :: Elem a -> FingerTree (Elem a) -> Elem a -> FingerTree (Elem a)+rep2EachFT firstx xs lastx =+                 Deep (size xs * 2 + 4)+                      (Two firstx firstx)+                      (mapMulFT 2 (\ex -> Node2 2 ex ex) xs)+                      (Two lastx lastx)++rep3EachFT :: Elem a -> FingerTree (Elem a) -> Elem a -> FingerTree (Elem a)+rep3EachFT firstx xs lastx =+                 Deep (size xs * 3 + 6)+                      (Three firstx firstx firstx)+                      (mapMulFT 3 (\ex -> Node3 3 ex ex ex) xs)+                      (Three lastx lastx lastx)++-- Invariants for repEachMiddle:+--+-- 1. midxs is constant: the middle bit in the original sequence (xs = (first <: Seq midxs :> last))+-- 2. lenys is constant: the length of ys+-- 3. firstx and pr repeat the same element: the first one in the original sequence xs+-- 4. lastx  and sf repeat the same element: the last  one in the original sequence xs+-- 5. sizec = size firstx = size lastx+-- 6. lenys = deep_count * sizec + size pr + size pf+-- 7. let (lft, fill, rght) = fill23 x, for any x:+--      7a. All three sequences repeat the element x+--      7b. size fill = sizec+--      7c. size lft  = size sf+--      7d. size rght = size pr+-- 8. size result = deep_count * sizec + lenys * (size midxs + 1)+repEachMiddle+  :: FingerTree (Elem a)  -- midxs+  -> Int                  -- lenys+  -> Int                  -- sizec+  -> Node c               -- firstx+  -> Node c               -- lastx+  -> (a -> (Node c, Node c, Node c))  -- fill23+  -> RCountMid c          -- (RCountMid pr deep_count sf)+  -> FingerTree (Node c)  -- result++-- At the bottom++repEachMiddle midxs lenys+            !_sizec+            _firstx+            _lastx+            fill23+            (RCountMid pr 0 sf)+     = Deep (lenys * (size midxs + 1))+            (One pr)+            (mapMulFT lenys fill23_final midxs)+            (One sf)+   where+     -- fill23_final ::  Elem a -> Node (Node c)+     fill23_final (Elem a) = case fill23 a of+        -- See the note on lift_fill23 for an explanation of this+        -- lazy pattern.+        ~(lft, _fill, rght) -> Node2 (size pr + size sf) lft rght++repEachMiddle midxs lenys+            !sizec+            firstx+            lastx+            fill23+            (RCountMid pr 1 sf)+     = Deep (sizec + lenys * (size midxs + 1))+            (Two pr firstx)+            (mapMulFT lenys fill23_final midxs)+            (Two lastx sf)+   where+     -- fill23_final ::  Elem a -> Node (Node c)+     fill23_final (Elem a) = case fill23 a of+        -- See the note on lift_fill23 for an explanation of this+        -- lazy pattern.+        ~(lft, fill, rght) -> Node3 (size pr + size sf + sizec) lft fill rght++-- Not at the bottom yet++repEachMiddle midxs lenys+            !sizec+            firstx+            lastx+            fill23+            (RCountMid pr deep_count sf)  -- deep_count > 1+  = case deep_count `quotRem` 3 of+      (q,0)+       -> deep'+        (Two firstx firstx)+        (repEachMiddle_+           (lift_fill23 TOT3 TOT2 fill23)+           (RCountMid pr' (q - 1) sf'))+        (One lastx)+       where+        pr' = node2 firstx pr+        sf' = node3 lastx lastx sf+      (q,1)+       -> deep'+        (Two firstx firstx)+        (repEachMiddle_+           (lift_fill23 TOT3 TOT3 fill23)+           (RCountMid pr' (q - 1) sf'))+        (Two lastx lastx)+       where+        pr' = node3 firstx firstx pr+        sf' = node3 lastx lastx sf+      (q,_) -- the remainder is 2+       -> deep'+        (One firstx)+        (repEachMiddle_+           (lift_fill23 TOT2 TOT2 fill23)+           (RCountMid pr' q sf'))+        (One lastx)+       where+        pr' = node2 firstx pr+        sf' = node2 lastx sf++  where+    deep' = Deep (deep_count * sizec + lenys * (size midxs + 1))+    repEachMiddle_ = repEachMiddle midxs lenys sizec' fn3 ln3+    sizec' = 3 * sizec+    fn3 = Node3 sizec' firstx firstx firstx+    ln3 = Node3 sizec' lastx lastx lastx+    spr = size pr+    ssf = size sf+    lift_fill23+      :: TwoOrThree+      -> TwoOrThree+      -> (a -> (b, b, b))+      -> a -> (Node b, Node b, Node b)+    lift_fill23 !tl !tr f a = (lft', fill', rght')+      where+        -- We use a strict pattern match on the recursive call.  This means+        -- that we build the 2-3 trees from the *bottom up* instead of from the+        -- *top down*. We do it this way for two reasons:+        --+        -- 1. The trees are never very deep, so we don't get much locality+        -- benefit from building them lazily.+        --+        -- 2. Building the trees lazily would require us to build four thunks+        -- at each level of each tree, which seems just a bit pricy.+        --+        -- Does this break the incremental optimality? I don't believe it does.+        -- As far as I can tell, each sequence operation that inspects one of+        -- these trees either inspects only its root (to get its size for+        -- indexing purposes) or descends all the way to the bottom. So we're+        -- strict here, and lazy in the construction of+        -- the root in fill23_final.+        !(lft, fill, rght) = f a+        !fill' = Node3 (3 * sizec) fill fill fill+        !lft' = case tl of+          TOT2 -> Node2 (ssf + sizec) lft fill+          TOT3 -> Node3 (ssf + 2 * sizec) lft fill fill+        !rght' = case tr of+          TOT2 -> Node2 (spr + sizec) rght fill+          TOT3 -> Node3 (spr + 2 * sizec) rght fill fill++data TwoOrThree = TOT2 | TOT3++------------------------------------------------------------------------+-- Construction+------------------------------------------------------------------------++-- | \( O(1) \). The empty sequence.+empty           :: Seq a+empty           =  Seq EmptyT++-- | \( O(1) \). A singleton sequence.+singleton       :: a -> Seq a+singleton x     =  Seq (Single (Elem x))++-- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ copies of @x@.+replicate       :: Int -> a -> Seq a+replicate n x+  | n >= 0      = runIdentity (replicateA n (Identity x))+  | otherwise   = error "replicate takes a nonnegative integer argument"++-- | 'replicateA' is an 'Applicative' version of 'replicate', and makes+-- \( O(\log n) \) calls to 'liftA2' and 'pure'.+--+-- > replicateA n x = sequenceA (replicate n x)+replicateA :: Applicative f => Int -> f a -> f (Seq a)+replicateA n x+  | n >= 0      = Seq <$> applicativeTree n 1 (Elem <$> x)+  | otherwise   = error "replicateA takes a nonnegative integer argument"+{-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-}++-- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.+--+-- > replicateM n x = sequence (replicate n x)+--+-- For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM'+-- is a synonym for 'replicateA'.+#if MIN_VERSION_base(4,8,0)+replicateM :: Applicative m => Int -> m a -> m (Seq a)+replicateM = replicateA+#else+replicateM :: Monad m => Int -> m a -> m (Seq a)+replicateM n x+  | n >= 0      = Applicative.unwrapMonad (replicateA n (Applicative.WrapMonad x))+  | otherwise   = error "replicateM takes a nonnegative integer argument"+#endif++-- | /O(/log/ k)/. @'cycleTaking' k xs@ forms a sequence of length @k@ by+-- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if+-- @k@ is 0.+--+-- prop> cycleTaking k = fromList . take k . cycle . toList++-- 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+cycleTaking n !_xs | n <= 0 = empty+cycleTaking _n xs  | null xs = error "cycleTaking cannot take a positive number of elements from an empty cycle."+cycleTaking n xs = cycleNTimes reps xs >< take final xs+  where+    (reps, final) = n `quotRem` length xs++-- \( O(\log(kn)) \). @'cycleNTimes' k xs@ concatenates @k@ copies of @xs@. This+-- operation uses time and additional space logarithmic in the size of its+-- result.+cycleNTimes :: Int -> Seq a -> Seq a+cycleNTimes n !xs+  | n <= 0    = empty+  | n == 1    = xs+cycleNTimes n (Seq xsFT) = case rigidify xsFT of+             RigidEmpty -> empty+             RigidOne (Elem x) -> replicate n x+             RigidTwo x1 x2 -> Seq $+               Deep (n*2) pair+                    (runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))+                    pair+               where pair = Two x1 x2+             RigidThree x1 x2 x3 -> Seq $+               Deep (n*3) triple+                    (runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))+                    triple+               where triple = Three x1 x2 x3+             RigidFull r@(Rigid s pr _m sf) -> Seq $+                   Deep (n*s)+                        (nodeToDigit pr)+                        (cycleNMiddle (n-2) r)+                        (nodeToDigit sf)++cycleNMiddle+  :: Int+     -> Rigid c+     -> FingerTree (Node c)++-- Not at the bottom yet++cycleNMiddle !n+           (Rigid s pr (DeepTh sm prm mm sfm) sf)+    = Deep (sm + s * (n + 1)) -- note: sm = s - size pr - size sf+           (digit12ToDigit prm)+           (cycleNMiddle n+                       (Rigid s (squashL pr prm) mm (squashR sfm sf)))+           (digit12ToDigit sfm)++-- At the bottom++cycleNMiddle n+           (Rigid s pr EmptyTh sf)+     = deep+            (One sf)+            (runIdentity $ applicativeTree n s (Identity converted))+            (One pr)+   where converted = node2 pr sf++cycleNMiddle n+           (Rigid s pr (SingleTh q) sf)+     = deep+            (Two q sf)+            (runIdentity $ applicativeTree n s (Identity converted))+            (Two pr q)+   where converted = node3 pr q sf+++-- | \( O(1) \). Add an element to the left end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(<|)            :: a -> Seq a -> Seq a+x <| Seq xs     =  Seq (Elem x `consTree` xs)++{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}+consTree        :: Sized a => a -> FingerTree a -> FingerTree a+consTree a EmptyT       = Single a+consTree a (Single b)   = deep (One a) EmptyT (One b)+-- As described in the paper, we force the middle of a tree+-- *before* consing onto it; this preserves the amortized+-- bounds but prevents repeated consing from building up+-- gigantic suspensions.+consTree a (Deep s (Four b c d e) m sf) = m `seq`+    Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf+consTree a (Deep s (Three b c d) m sf) =+    Deep (size a + s) (Four a b c d) m sf+consTree a (Deep s (Two b c) m sf) =+    Deep (size a + s) (Three a b c) m sf+consTree a (Deep s (One b) m sf) =+    Deep (size a + s) (Two a b) m sf++cons' :: a -> Seq a -> Seq a+cons' x (Seq xs) = Seq (Elem x `consTree'` xs)++snoc' :: Seq a -> a -> Seq a+snoc' (Seq xs) x = Seq (xs `snocTree'` Elem x)++{-# SPECIALIZE consTree' :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE consTree' :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}+consTree'        :: Sized a => a -> FingerTree a -> FingerTree a+consTree' a EmptyT       = Single a+consTree' a (Single b)   = deep (One a) EmptyT (One b)+-- As described in the paper, we force the middle of a tree+-- *before* consing onto it; this preserves the amortized+-- bounds but prevents repeated consing from building up+-- gigantic suspensions.+consTree' a (Deep s (Four b c d e) m sf) =+    Deep (size a + s) (Two a b) m' sf+  where !m' = abc `consTree'` m+        !abc = node3 c d e+consTree' a (Deep s (Three b c d) m sf) =+    Deep (size a + s) (Four a b c d) m sf+consTree' a (Deep s (Two b c) m sf) =+    Deep (size a + s) (Three a b c) m sf+consTree' a (Deep s (One b) m sf) =+    Deep (size a + s) (Two a b) m sf++-- | \( O(1) \). Add an element to the right end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(|>)            :: Seq a -> a -> Seq a+Seq xs |> x     =  Seq (xs `snocTree` Elem x)++{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}+{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}+snocTree        :: Sized a => FingerTree a -> a -> FingerTree a+snocTree EmptyT a       =  Single a+snocTree (Single a) b   =  deep (One a) EmptyT (One b)+-- See note on `seq` in `consTree`.+snocTree (Deep s pr m (Four a b c d)) e = m `seq`+    Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)+snocTree (Deep s pr m (Three a b c)) d =+    Deep (s + size d) pr m (Four a b c d)+snocTree (Deep s pr m (Two a b)) c =+    Deep (s + size c) pr m (Three a b c)+snocTree (Deep s pr m (One a)) b =+    Deep (s + size b) pr m (Two a b)++{-# SPECIALIZE snocTree' :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}+{-# SPECIALIZE snocTree' :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}+snocTree'        :: Sized a => FingerTree a -> a -> FingerTree a+snocTree' EmptyT a       =  Single a+snocTree' (Single a) b   =  deep (One a) EmptyT (One b)+-- See note on `seq` in `consTree`.+snocTree' (Deep s pr m (Four a b c d)) e =+    Deep (s + size e) pr m' (Two d e)+  where !m' = m `snocTree'` abc+        !abc = node3 a b c+snocTree' (Deep s pr m (Three a b c)) d =+    Deep (s + size d) pr m (Four a b c d)+snocTree' (Deep s pr m (Two a b)) c =+    Deep (s + size c) pr m (Three a b c)+snocTree' (Deep s pr m (One a)) b =+    Deep (s + size b) pr m (Two a b)++-- | \( O(\log(\min(n_1,n_2))) \). Concatenate two sequences.+(><)            :: Seq a -> Seq a -> Seq a+Seq xs >< Seq ys = Seq (appendTree0 xs ys)++-- The appendTree/addDigits gunk below is machine generated++appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)+appendTree0 EmptyT xs =+    xs+appendTree0 xs EmptyT =+    xs+appendTree0 (Single x) xs =+    x `consTree` xs+appendTree0 xs (Single x) =+    xs `snocTree` x+appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =+    Deep (s1 + s2) pr1 m sf2+  where !m = addDigits0 m1 sf1 pr2 m2++addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))+addDigits0 m1 (One a) (One b) m2 =+    appendTree1 m1 (node2 a b) m2+addDigits0 m1 (One a) (Two b c) m2 =+    appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (One a) (Three b c d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (One a) (Four b c d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (One c) m2 =+    appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (Two a b) (Two c d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Two a b) (Three c d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (Four c d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (One d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Three a b c) (Two d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Three a b c) (Three d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (Four d e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Four a b c d) (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Four a b c d) (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2++appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree1 EmptyT !a xs =+    a `consTree` xs+appendTree1 xs !a EmptyT =+    xs `snocTree` a+appendTree1 (Single x) !a xs =+    x `consTree` a `consTree` xs+appendTree1 xs !a (Single x) =+    xs `snocTree` a `snocTree` x+appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + s2) pr1 m sf2+  where !m = addDigits1 m1 sf1 a pr2 m2++addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits1 m1 (One a) b (One c) m2 =+    appendTree1 m1 (node3 a b c) m2+addDigits1 m1 (One a) b (Two c d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (One a) b (Three c d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (One a) b (Four c d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (One d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (Two a b) c (Two d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Two a b) c (Three d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (Four d e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Three a b c) d (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Three a b c) d (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Four a b c d) e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2++appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree2 EmptyT !a !b xs =+    a `consTree` b `consTree` xs+appendTree2 xs !a !b EmptyT =+    xs `snocTree` a `snocTree` b+appendTree2 (Single x) a b xs =+    x `consTree` a `consTree` b `consTree` xs+appendTree2 xs a b (Single x) =+    xs `snocTree` a `snocTree` b `snocTree` x+appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + size b + s2) pr1 m sf2+  where !m = addDigits2 m1 sf1 a b pr2 m2++addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits2 m1 (One a) b c (One d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits2 m1 (One a) b c (Two d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (One a) b c (Three d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (One a) b c (Four d e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (Two a b) c d (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Two a b) c d (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Three a b c) d e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (One g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2++appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree3 EmptyT !a !b !c xs =+    a `consTree` b `consTree` c `consTree` xs+appendTree3 xs !a !b !c EmptyT =+    xs `snocTree` a `snocTree` b `snocTree` c+appendTree3 (Single x) a b c xs =+    x `consTree` a `consTree` b `consTree` c `consTree` xs+appendTree3 xs a b c (Single x) =+    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x+appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + size b + size c + s2) pr1 m sf2+  where !m = addDigits3 m1 sf1 a b c pr2 m2++addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits3 m1 (One a) !b !c !d (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits3 m1 (One a) b c d (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (One a) b c d (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (One a) b c d (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) !c !d !e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (Two a b) c d e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) !d !e !f (One g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) !e !f !g (One h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2++appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree4 EmptyT !a !b !c !d xs =+    a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs !a !b !c !d EmptyT =+    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d+appendTree4 (Single x) a b c d xs =+    x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs a b c d (Single x) =+    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x+appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + size b + size c + size d + s2) pr1 m sf2+  where !m = addDigits4 m1 sf1 a b c d pr2 m2++addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits4 m1 (One a) !b !c !d !e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits4 m1 (One a) b c d e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (One a) b c d e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) !c !d !e !f (One g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) !d !e !f !g (One h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (One i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (Two i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (Three i j k) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (Four i j k l) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2++-- | Builds a sequence from a seed value.  Takes time linear in the+-- number of generated elements.  /WARNING:/ If the number of generated+-- elements is infinite, this method will not terminate.+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a+unfoldr f = unfoldr' empty+  -- uses tail recursion rather than, for instance, the List implementation.+  where unfoldr' !as b = maybe as (\ (a, b') -> unfoldr' (as `snoc'` a) b') (f b)++-- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.+unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a+unfoldl f = unfoldl' empty+  where unfoldl' !as b = maybe as (\ (b', a) -> unfoldl' (a `cons'` as) b') (f b)++-- | \( O(n) \).  Constructs a sequence by repeated application of a function+-- to a seed value.+--+-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))+iterateN :: Int -> (a -> a) -> a -> Seq a+iterateN n f x+  | n >= 0      = replicateA n (State (\ y -> (f y, y))) `execState` x+  | otherwise   = error "iterateN takes a nonnegative integer argument"++------------------------------------------------------------------------+-- Deconstruction+------------------------------------------------------------------------++-- | \( O(1) \). Is this the empty sequence?+null            :: Seq a -> Bool+null (Seq EmptyT) = True+null _            =  False++-- | \( O(1) \). The number of elements in the sequence.+length          :: Seq a -> Int+length (Seq xs) =  size xs++-- Views++data ViewLTree a = ConsLTree a (FingerTree a) | EmptyLTree+data ViewRTree a = SnocRTree (FingerTree a) a | EmptyRTree++-- | View of the left end of a sequence.+data ViewL a+    = EmptyL        -- ^ empty sequence+    | a :< Seq a    -- ^ leftmost element and the rest of the sequence+    deriving (Eq, Ord, Show, Read)++#ifdef __GLASGOW_HASKELL__+deriving instance Data a => Data (ViewL a)++-- | @since 0.5.8+deriving instance Generic1 ViewL++-- | @since 0.5.8+deriving instance Generic (ViewL a)+#endif++INSTANCE_TYPEABLE1(ViewL)++instance Functor ViewL where+    {-# INLINE fmap #-}+    fmap _ EmptyL       = EmptyL+    fmap f (x :< xs)    = f x :< fmap f xs++instance Foldable ViewL where+    foldr _ z EmptyL = z+    foldr f z (x :< xs) = f x (foldr f z xs)++    foldl _ z EmptyL = z+    foldl f z (x :< xs) = foldl f (f z x) xs++    foldl1 _ EmptyL = error "foldl1: empty view"+    foldl1 f (x :< xs) = foldl f x xs++#if MIN_VERSION_base(4,8,0)+    null EmptyL = True+    null (_ :< _) = False++    length EmptyL = 0+    length (_ :< xs) = 1 + length xs+#endif++instance Traversable ViewL where+    traverse _ EmptyL       = pure EmptyL+    traverse f (x :< xs)    = liftA2 (:<) (f x) (traverse f xs)++-- | \( O(1) \). Analyse the left end of a sequence.+viewl           ::  Seq a -> ViewL a+viewl (Seq xs)  =  case viewLTree xs of+    EmptyLTree -> EmptyL+    ConsLTree (Elem x) xs' -> x :< Seq xs'++{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> ViewLTree (Elem a) #-}+{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> ViewLTree (Node a) #-}+viewLTree       :: Sized a => FingerTree a -> ViewLTree a+viewLTree EmptyT                = EmptyLTree+viewLTree (Single a)            = ConsLTree a EmptyT+viewLTree (Deep s (One a) m sf) = ConsLTree a (pullL (s - size a) m sf)+viewLTree (Deep s (Two a b) m sf) =+    ConsLTree a (Deep (s - size a) (One b) m sf)+viewLTree (Deep s (Three a b c) m sf) =+    ConsLTree a (Deep (s - size a) (Two b c) m sf)+viewLTree (Deep s (Four a b c d) m sf) =+    ConsLTree a (Deep (s - size a) (Three b c d) m sf)++-- | View of the right end of a sequence.+data ViewR a+    = EmptyR        -- ^ empty sequence+    | Seq a :> a    -- ^ the sequence minus the rightmost element,+            -- and the rightmost element+    deriving (Eq, Ord, Show, Read)++#ifdef __GLASGOW_HASKELL__+deriving instance Data a => Data (ViewR a)++-- | @since 0.5.8+deriving instance Generic1 ViewR++-- | @since 0.5.8+deriving instance Generic (ViewR a)+#endif++INSTANCE_TYPEABLE1(ViewR)++instance Functor ViewR where+    {-# INLINE fmap #-}+    fmap _ EmptyR       = EmptyR+    fmap f (xs :> x)    = fmap f xs :> f x++instance Foldable ViewR where+    foldMap _ EmptyR = mempty+    foldMap f (xs :> x) = foldMap f xs <> f x++    foldr _ z EmptyR = z+    foldr f z (xs :> x) = foldr f (f x z) xs++    foldl _ z EmptyR = z+    foldl f z (xs :> x) = foldl f z xs `f` x++    foldr1 _ EmptyR = error "foldr1: empty view"+    foldr1 f (xs :> x) = foldr f x xs+#if MIN_VERSION_base(4,8,0)+    null EmptyR = True+    null (_ :> _) = False++    length EmptyR = 0+    length (xs :> _) = length xs + 1+#endif++instance Traversable ViewR where+    traverse _ EmptyR       = pure EmptyR+    traverse f (xs :> x)    = liftA2 (:>) (traverse f xs) (f x)++-- | \( O(1) \). Analyse the right end of a sequence.+viewr           ::  Seq a -> ViewR a+viewr (Seq xs)  =  case viewRTree xs of+    EmptyRTree -> EmptyR+    SnocRTree xs' (Elem x) -> Seq xs' :> x++{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> ViewRTree (Elem a) #-}+{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> ViewRTree (Node a) #-}+viewRTree       :: Sized a => FingerTree a -> ViewRTree a+viewRTree EmptyT                = EmptyRTree+viewRTree (Single z)            = SnocRTree EmptyT z+viewRTree (Deep s pr m (One z)) = SnocRTree (pullR (s - size z) pr m) z+viewRTree (Deep s pr m (Two y z)) =+    SnocRTree (Deep (s - size z) pr m (One y)) z+viewRTree (Deep s pr m (Three x y z)) =+    SnocRTree (Deep (s - size z) pr m (Two x y)) z+viewRTree (Deep s pr m (Four w x y z)) =+    SnocRTree (Deep (s - size z) pr m (Three w x y)) z++------------------------------------------------------------------------+-- Scans+--+-- These are not particularly complex applications of the Traversable+-- functor, though making the correspondence with Data.List exact+-- requires the use of (<|) and (|>).+--+-- Note that save for the single (<|) or (|>), we maintain the original+-- structure of the Seq, not having to do any restructuring of our own.+--+-- wasserman.louis@gmail.com, 5/23/09+------------------------------------------------------------------------++-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced+-- values from the left:+--+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a+scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:+--+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]+scanl1 :: (a -> a -> a) -> Seq a -> Seq a+scanl1 f xs = case viewl xs of+    EmptyL          -> error "scanl1 takes a nonempty sequence as an argument"+    x :< xs'        -> scanl f x xs'++-- | 'scanr' is the right-to-left dual of 'scanl'.+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b+scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.+scanr1 :: (a -> a -> a) -> Seq a -> Seq a+scanr1 f xs = case viewr xs of+    EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"+    xs' :> x        -> scanr f x xs'++-- Indexing++-- | \( O(\log(\min(i,n-i))) \). The element at the specified position,+-- counting from 0.  The argument should thus be a non-negative+-- integer less than the size of the sequence.+-- If the position is out of range, 'index' fails with an error.+--+-- prop> xs `index` i = toList xs !! i+--+-- Caution: 'index' necessarily delays retrieving the requested+-- element until the result is forced. It can therefore lead to a space+-- leak if the result is stored, unforced, in another structure. To retrieve+-- an element immediately without forcing it, use 'lookup' or '(!?)'.+index           :: Seq a -> Int -> a+index (Seq xs) i+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of+                Place _ (Elem x) -> x+  | otherwise   = +      error $ "index out of bounds in call to: Data.Strict.Sequence.Autogen.index " ++ show i++-- | \( O(\log(\min(i,n-i))) \). The element at the specified position,+-- counting from 0. If the specified position is negative or at+-- least the length of the sequence, 'lookup' returns 'Nothing'.+--+-- prop> 0 <= i < length xs ==> lookup i xs == Just (toList xs !! i)+-- prop> i < 0 || i >= length xs ==> lookup i xs = Nothing+--+-- Unlike 'index', this can be used to retrieve an element without+-- forcing it. For example, to insert the fifth element of a sequence+-- @xs@ into a 'Data.Map.Lazy.Map' @m@ at key @k@, you could use+--+-- @+-- case lookup 5 xs of+--   Nothing -> m+--   Just x -> 'Data.Map.Lazy.insert' k x m+-- @+--+-- @since 0.5.8+lookup            :: Int -> Seq a -> Maybe a+lookup i (Seq xs)+  -- Note: we perform the lookup *before* applying the Just constructor+  -- to ensure that we don't hold a reference to the whole sequence in+  -- a thunk. If we applied the Just constructor around the case, the+  -- actual lookup wouldn't be performed unless and until the value was+  -- forced.+  | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of+                Place _ (Elem x) -> Just x+  | otherwise = Nothing++-- | \( O(\log(\min(i,n-i))) \). A flipped, infix version of `lookup`.+--+-- @since 0.5.8+(!?) ::           Seq a -> Int -> Maybe a+(!?) = flip lookup++data Place a = Place {-# UNPACK #-} !Int a+#ifdef TESTING+    deriving Show+#endif++{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}+lookupTree :: Sized a => Int -> FingerTree a -> Place a+lookupTree !_ EmptyT = error "lookupTree of empty tree"+lookupTree i (Single x) = Place i x+lookupTree i (Deep _ pr m sf)+  | i < spr     =  lookupDigit i pr+  | i < spm     =  case lookupTree (i - spr) m of+                   Place i' xs -> lookupNode i' xs+  | otherwise   =  lookupDigit (i - spm) sf+  where+    spr     = size pr+    spm     = spr + size m++{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}+lookupNode :: Sized a => Int -> Node a -> Place a+lookupNode i (Node2 _ a b)+  | i < sa      = Place i a+  | otherwise   = Place (i - sa) b+  where+    sa      = size a+lookupNode i (Node3 _ a b c)+  | i < sa      = Place i a+  | i < sab     = Place (i - sa) b+  | otherwise   = Place (i - sab) c+  where+    sa      = size a+    sab     = sa + size b++{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}+lookupDigit :: Sized a => Int -> Digit a -> Place a+lookupDigit i (One a) = Place i a+lookupDigit i (Two a b)+  | i < sa      = Place i a+  | otherwise   = Place (i - sa) b+  where+    sa      = size a+lookupDigit i (Three a b c)+  | i < sa      = Place i a+  | i < sab     = Place (i - sa) b+  | otherwise   = Place (i - sab) c+  where+    sa      = size a+    sab     = sa + size b+lookupDigit i (Four a b c d)+  | i < sa      = Place i a+  | i < sab     = Place (i - sa) b+  | i < sabc    = Place (i - sab) c+  | otherwise   = Place (i - sabc) d+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++-- | \( O(\log(\min(i,n-i))) \). Replace the element at the specified position.+-- If the position is out of range, the original sequence is returned.+update          :: Int -> a -> Seq a -> Seq a+update i x (Seq xs)+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (updateTree (Elem x) i xs)+  | otherwise   = Seq xs++-- It seems a shame to copy the implementation of the top layer of+-- `adjust` instead of just using `update i x = adjust (const x) i`.+-- With the latter implementation, updating the same position many+-- times could lead to silly thunks building up around that position.+-- The thunks will each look like @const v a@, where @v@ is the new+-- value and @a@ the old.+updateTree      :: Elem a -> Int -> FingerTree (Elem a) -> FingerTree (Elem a)+updateTree _ !_ EmptyT = EmptyT -- Unreachable+updateTree v _i (Single _) = Single v+updateTree v i (Deep s pr m sf)+  | i < spr     = Deep s (updateDigit v i pr) m sf+  | i < spm     = let !m' = adjustTree (updateNode v) (i - spr) m+                  in Deep s pr m' sf+  | otherwise   = Deep s pr m (updateDigit v (i - spm) sf)+  where+    spr     = size pr+    spm     = spr + size m++updateNode      :: Elem a -> Int -> Node (Elem a) -> Node (Elem a)+updateNode v i (Node2 s a b)+  | i < sa      = Node2 s v b+  | otherwise   = Node2 s a v+  where+    sa      = size a+updateNode v i (Node3 s a b c)+  | i < sa      = Node3 s v b c+  | i < sab     = Node3 s a v c+  | otherwise   = Node3 s a b v+  where+    sa      = size a+    sab     = sa + size b++updateDigit     :: Elem a -> Int -> Digit (Elem a) -> Digit (Elem a)+updateDigit v !_i (One _) = One v+updateDigit v i (Two a b)+  | i < sa      = Two v b+  | otherwise   = Two a v+  where+    sa      = size a+updateDigit v i (Three a b c)+  | i < sa      = Three v b c+  | i < sab     = Three a v c+  | otherwise   = Three a b v+  where+    sa      = size a+    sab     = sa + size b+updateDigit v i (Four a b c d)+  | i < sa      = Four v b c d+  | i < sab     = Four a v c d+  | i < sabc    = Four a b v d+  | otherwise   = Four a b c v+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++-- | \( O(\log(\min(i,n-i))) \). Update the element at the specified position.+-- If the position is out of range, the original sequence is returned.+-- The new value is forced before it is installed in the sequence.+--+-- @+-- adjust f i xs =+--  case xs !? i of+--    Nothing -> xs+--    Just x -> let !x' = f x+--              in update i x' xs+-- @+--+-- @since 0.5.8+adjust          :: forall a . (a -> a) -> Int -> Seq a -> Seq a+#if __GLASGOW_HASKELL__ >= 708+adjust f i xs+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (length xs) :: Word) =+      coerce $ adjustTree (\ !_k (ForceBox a) -> ForceBox (f a)) i (coerce xs)+  | otherwise   = xs+#else+-- This is inefficient, but fixing it would take a lot of fuss and bother+-- for little immediate gain. We can deal with that when we have another+-- Haskell implementation to worry about.+adjust f i xs =+  case xs !? i of+    Nothing -> xs+    Just x -> let !x' = f x+              in update i x' xs+#endif++{-# SPECIALIZE adjustTree :: (Int -> ForceBox a -> ForceBox a) -> Int -> FingerTree (ForceBox a) -> FingerTree (ForceBox a) #-}+{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}+adjustTree      :: (Sized a, MaybeForce a) => (Int -> a -> a) ->+             Int -> FingerTree a -> FingerTree a+adjustTree _ !_ EmptyT = EmptyT -- Unreachable+adjustTree f i (Single x) = Single $!? f i x+adjustTree f i (Deep s pr m sf)+  | i < spr     = Deep s (adjustDigit f i pr) m sf+  | i < spm     = let !m' = adjustTree (adjustNode f) (i - spr) m+                  in Deep s pr m' sf+  | otherwise   = Deep s pr m (adjustDigit f (i - spm) sf)+  where+    spr     = size pr+    spm     = spr + size m++{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}+{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}+adjustNode      :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Node a -> Node a+adjustNode f i (Node2 s a b)+  | i < sa      = let fia = f i a in fia `mseq` Node2 s fia b+  | otherwise   = let fisab = f (i - sa) b in fisab `mseq` Node2 s a fisab+  where+    sa      = size a+adjustNode f i (Node3 s a b c)+  | i < sa      = let fia = f i a in fia `mseq` Node3 s fia b c+  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Node3 s a fisab c+  | otherwise   = let fisabc = f (i - sab) c in fisabc `mseq` Node3 s a b fisabc+  where+    sa      = size a+    sab     = sa + size b++{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}+{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}+adjustDigit     :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Digit a -> Digit a+adjustDigit f !i (One a) = One $!? f i a+adjustDigit f i (Two a b)+  | i < sa      = let fia = f i a in fia `mseq` Two fia b+  | otherwise   = let fisab = f (i - sa) b in fisab `mseq` Two a fisab+  where+    sa      = size a+adjustDigit f i (Three a b c)+  | i < sa      = let fia = f i a in fia `mseq` Three fia b c+  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Three a fisab c+  | otherwise   = let fisabc = f (i - sab) c in fisabc `mseq` Three a b fisabc+  where+    sa      = size a+    sab     = sa + size b+adjustDigit f i (Four a b c d)+  | i < sa      = let fia = f i a in fia `mseq` Four fia b c d+  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Four a fisab c d+  | i < sabc    = let fisabc = f (i - sab) c in fisabc `mseq` Four a b fisabc d+  | otherwise   = let fisabcd = f (i - sabc) d in fisabcd `mseq` Four a b c fisabcd+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++-- | \( O(\log(\min(i,n-i))) \). @'insertAt' i x xs@ inserts @x@ into @xs@+-- at the index @i@, shifting the rest of the sequence over.+--+-- @+-- insertAt 2 x (fromList [a,b,c,d]) = fromList [a,b,x,c,d]+-- insertAt 4 x (fromList [a,b,c,d]) = insertAt 10 x (fromList [a,b,c,d])+--                                   = fromList [a,b,c,d,x]+-- @+--+-- prop> insertAt i x xs = take i xs >< singleton x >< drop i xs+--+-- @since 0.5.8+insertAt :: Int -> a -> Seq a -> Seq a+insertAt i a s@(Seq xs)+  | fromIntegral i < (fromIntegral (size xs) :: Word)+      = Seq (insTree (`seq` InsTwo (Elem a)) i xs)+  | i <= 0 = a <| s+  | otherwise = s |> a++data Ins a = InsOne a | InsTwo a a++{-# SPECIALIZE insTree :: (Int -> Elem a -> Ins (Elem a)) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE insTree :: (Int -> Node a -> Ins (Node a)) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}+insTree      :: Sized a => (Int -> a -> Ins a) ->+             Int -> FingerTree a -> FingerTree a+insTree _ !_ EmptyT = EmptyT -- Unreachable+insTree f i (Single x) = case f i x of+  InsOne x' -> Single x'+  InsTwo m n -> deep (One m) EmptyT (One n)+insTree f i (Deep s pr m sf)+  | i < spr     = case insLeftDigit f i pr of+     InsLeftDig pr' -> Deep (s + 1) pr' m sf+     InsDigNode pr' n -> m `seq` Deep (s + 1) pr' (n `consTree` m) sf+  | i < spm     = let !m' = insTree (insNode f) (i - spr) m+                  in Deep (s + 1) pr m' sf+  | otherwise   = case insRightDigit f (i - spm) sf of+     InsRightDig sf' -> Deep (s + 1) pr m sf'+     InsNodeDig n sf' -> m `seq` Deep (s + 1) pr (m `snocTree` n) sf'+  where+    spr     = size pr+    spm     = spr + size m++{-# SPECIALIZE insNode :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Node (Elem a) -> Ins (Node (Elem a)) #-}+{-# SPECIALIZE insNode :: (Int -> Node a -> Ins (Node a)) -> Int -> Node (Node a) -> Ins (Node (Node a)) #-}+insNode :: Sized a => (Int -> a -> Ins a) -> Int -> Node a -> Ins (Node a)+insNode f i (Node2 s a b)+  | i < sa = case f i a of+      InsOne n -> InsOne $ Node2 (s + 1) n b+      InsTwo m n -> InsOne $ Node3 (s + 1) m n b+  | otherwise = case f (i - sa) b of+      InsOne n -> InsOne $ Node2 (s + 1) a n+      InsTwo m n -> InsOne $ Node3 (s + 1) a m n+  where sa = size a+insNode f i (Node3 s a b c)+  | i < sa = case f i a of+      InsOne n -> InsOne $ Node3 (s + 1) n b c+      InsTwo m n -> InsTwo (Node2 (sa + 1) m n) (Node2 (s - sa) b c)+  | i < sab = case f (i - sa) b of+      InsOne n -> InsOne $ Node3 (s + 1) a n c+      InsTwo m n -> InsTwo am nc+        where !am = node2 a m+              !nc = node2 n c+  | otherwise = case f (i - sab) c of+      InsOne n -> InsOne $ Node3 (s + 1) a b n+      InsTwo m n -> InsTwo (Node2 sab a b) (Node2 (s - sab + 1) m n)+  where sa = size a+        sab = sa + size b++data InsDigNode a = InsLeftDig !(Digit a) | InsDigNode !(Digit a) !(Node a)+{-# SPECIALIZE insLeftDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsDigNode (Elem a) #-}+{-# SPECIALIZE insLeftDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsDigNode (Node a) #-}+insLeftDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsDigNode a+insLeftDigit f !i (One a) = case f i a of+  InsOne a' -> InsLeftDig $ One a'+  InsTwo a1 a2 -> InsLeftDig $ Two a1 a2+insLeftDigit f i (Two a b)+  | i < sa = case f i a of+     InsOne a' -> InsLeftDig $ Two a' b+     InsTwo a1 a2 -> InsLeftDig $ Three a1 a2 b+  | otherwise = case f (i - sa) b of+     InsOne b' -> InsLeftDig $ Two a b'+     InsTwo b1 b2 -> InsLeftDig $ Three a b1 b2+  where sa = size a+insLeftDigit f i (Three a b c)+  | i < sa = case f i a of+     InsOne a' -> InsLeftDig $ Three a' b c+     InsTwo a1 a2 -> InsLeftDig $ Four a1 a2 b c+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsLeftDig $ Three a b' c+     InsTwo b1 b2 -> InsLeftDig $ Four a b1 b2 c+  | otherwise = case f (i - sab) c of+     InsOne c' -> InsLeftDig $ Three a b c'+     InsTwo c1 c2 -> InsLeftDig $ Four a b c1 c2+  where sa = size a+        sab = sa + size b+insLeftDigit f i (Four a b c d)+  | i < sa = case f i a of+     InsOne a' -> InsLeftDig $ Four a' b c d+     InsTwo a1 a2 -> InsDigNode (Two a1 a2) (node3 b c d)+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsLeftDig $ Four a b' c d+     InsTwo b1 b2 -> InsDigNode (Two a b1) (node3 b2 c d)+  | i < sabc = case f (i - sab) c of+     InsOne c' -> InsLeftDig $ Four a b c' d+     InsTwo c1 c2 -> InsDigNode (Two a b) (node3 c1 c2 d)+  | otherwise = case f (i - sabc) d of+     InsOne d' -> InsLeftDig $ Four a b c d'+     InsTwo d1 d2 -> InsDigNode (Two a b) (node3 c d1 d2)+  where sa = size a+        sab = sa + size b+        sabc = sab + size c++data InsNodeDig a = InsRightDig !(Digit a) | InsNodeDig !(Node a) !(Digit a)+{-# SPECIALIZE insRightDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsNodeDig (Elem a) #-}+{-# SPECIALIZE insRightDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsNodeDig (Node a) #-}+insRightDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsNodeDig a+insRightDigit f !i (One a) = case f i a of+  InsOne a' -> InsRightDig $ One a'+  InsTwo a1 a2 -> InsRightDig $ Two a1 a2+insRightDigit f i (Two a b)+  | i < sa = case f i a of+     InsOne a' -> InsRightDig $ Two a' b+     InsTwo a1 a2 -> InsRightDig $ Three a1 a2 b+  | otherwise = case f (i - sa) b of+     InsOne b' -> InsRightDig $ Two a b'+     InsTwo b1 b2 -> InsRightDig $ Three a b1 b2+  where sa = size a+insRightDigit f i (Three a b c)+  | i < sa = case f i a of+     InsOne a' -> InsRightDig $ Three a' b c+     InsTwo a1 a2 -> InsRightDig $ Four a1 a2 b c+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsRightDig $ Three a b' c+     InsTwo b1 b2 -> InsRightDig $ Four a b1 b2 c+  | otherwise = case f (i - sab) c of+     InsOne c' -> InsRightDig $ Three a b c'+     InsTwo c1 c2 -> InsRightDig $ Four a b c1 c2+  where sa = size a+        sab = sa + size b+insRightDigit f i (Four a b c d)+  | i < sa = case f i a of+     InsOne a' -> InsRightDig $ Four a' b c d+     InsTwo a1 a2 -> InsNodeDig (node3 a1 a2 b) (Two c d)+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsRightDig $ Four a b' c d+     InsTwo b1 b2 -> InsNodeDig (node3 a b1 b2) (Two c d)+  | i < sabc = case f (i - sab) c of+     InsOne c' -> InsRightDig $ Four a b c' d+     InsTwo c1 c2 -> InsNodeDig (node3 a b c1) (Two c2 d)+  | otherwise = case f (i - sabc) d of+     InsOne d' -> InsRightDig $ Four a b c d'+     InsTwo d1 d2 -> InsNodeDig (node3 a b c) (Two d1 d2)+  where sa = size a+        sab = sa + size b+        sabc = sab + size c++-- | \( O(\log(\min(i,n-i))) \). Delete the element of a sequence at a given+-- index. Return the original sequence if the index is out of range.+--+-- @+-- deleteAt 2 [a,b,c,d] = [a,b,d]+-- deleteAt 4 [a,b,c,d] = deleteAt (-1) [a,b,c,d] = [a,b,c,d]+-- @+--+-- @since 0.5.8+deleteAt :: Int -> Seq a -> Seq a+deleteAt i (Seq xs)+  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq $ delTreeE i xs+  | otherwise = Seq xs++delTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)+delTreeE !_i EmptyT = EmptyT -- Unreachable+delTreeE _i Single{} = EmptyT+delTreeE i (Deep s pr m sf)+  | i < spr = delLeftDigitE i s pr m sf+  | i < spm = case delTree delNodeE (i - spr) m of+     FullTree m' -> Deep (s - 1) pr m' sf+     DefectTree e -> delRebuildMiddle (s - 1) pr e sf+  | otherwise = delRightDigitE (i - spm) s pr m sf+  where spr = size pr+        spm = spr + size m++delNodeE :: Int -> Node (Elem a) -> Del (Elem a)+delNodeE i (Node3 _ a b c) = case i of+  0 -> Full $ Node2 2 b c+  1 -> Full $ Node2 2 a c+  _ -> Full $ Node2 2 a b+delNodeE i (Node2 _ a b) = case i of+  0 -> Defect b+  _ -> Defect a+++delLeftDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)+delLeftDigitE !_i s One{} m sf = pullL (s - 1) m sf+delLeftDigitE i s (Two a b) m sf+  | i == 0 = Deep (s - 1) (One b) m sf+  | otherwise = Deep (s - 1) (One a) m sf+delLeftDigitE i s (Three a b c) m sf+  | i == 0 = Deep (s - 1) (Two b c) m sf+  | i == 1 = Deep (s - 1) (Two a c) m sf+  | otherwise = Deep (s - 1) (Two a b) m sf+delLeftDigitE i s (Four a b c d) m sf+  | i == 0 = Deep (s - 1) (Three b c d) m sf+  | i == 1 = Deep (s - 1) (Three a c d) m sf+  | i == 2 = Deep (s - 1) (Three a b d) m sf+  | otherwise = Deep (s - 1) (Three a b c) m sf++delRightDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)+delRightDigitE !_i s pr m One{} = pullR (s - 1) pr m+delRightDigitE i s pr m (Two a b)+  | i == 0 = Deep (s - 1) pr m (One b)+  | otherwise = Deep (s - 1) pr m (One a)+delRightDigitE i s pr m (Three a b c)+  | i == 0 = Deep (s - 1) pr m (Two b c)+  | i == 1 = Deep (s - 1) pr m (Two a c)+  | otherwise = deep pr m (Two a b)+delRightDigitE i s pr m (Four a b c d)+  | i == 0 = Deep (s - 1) pr m (Three b c d)+  | i == 1 = Deep (s - 1) pr m (Three a c d)+  | i == 2 = Deep (s - 1) pr m (Three a b d)+  | otherwise = Deep (s - 1) pr m (Three a b c)++data DelTree a = FullTree !(FingerTree (Node a)) | DefectTree a++{-# SPECIALIZE delTree :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> FingerTree (Node (Elem a)) -> DelTree (Elem a) #-}+{-# SPECIALIZE delTree :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> FingerTree (Node (Node a)) -> DelTree (Node a) #-}+delTree :: Sized a => (Int -> Node a -> Del a) -> Int -> FingerTree (Node a) -> DelTree a+delTree _f !_i EmptyT = FullTree EmptyT -- Unreachable+delTree f i (Single a) = case f i a of+  Full a' -> FullTree (Single a')+  Defect e -> DefectTree e+delTree f i (Deep s pr m sf)+  | i < spr = case delDigit f i pr of+     FullDig pr' -> FullTree $ Deep (s - 1) pr' m sf+     DefectDig e -> case viewLTree m of+                      EmptyLTree -> FullTree $ delRebuildRightDigit (s - 1) e sf+                      ConsLTree n m' -> FullTree $ delRebuildLeftSide (s - 1) e n m' sf+  | i < spm = case delTree (delNode f) (i - spr) m of+     FullTree m' -> FullTree (Deep (s - 1) pr m' sf)+     DefectTree e -> FullTree $ delRebuildMiddle (s - 1) pr e sf+  | otherwise = case delDigit f (i - spm) sf of+     FullDig sf' -> FullTree $ Deep (s - 1) pr m sf'+     DefectDig e -> case viewRTree m of+                      EmptyRTree -> FullTree $ delRebuildLeftDigit (s - 1) pr e+                      SnocRTree m' n -> FullTree $ delRebuildRightSide (s - 1) pr m' n e+  where spr = size pr+        spm = spr + size m++data Del a = Full !(Node a) | Defect a++{-# SPECIALIZE delNode :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Node (Node (Elem a)) -> Del (Node (Elem a)) #-}+{-# SPECIALIZE delNode :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Node (Node (Node a)) -> Del (Node (Node a)) #-}+delNode :: Sized a => (Int -> Node a -> Del a) -> Int -> Node (Node a) -> Del (Node a)+delNode f i (Node3 s a b c)+  | i < sa = case f i a of+     Full a' -> Full $ Node3 (s - 1) a' b c+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c+         where !sx = size x+       Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) e x y) c+  | i < sab = case f (i - sa) b of+     Full b' -> Full $ Node3 (s - 1) a b' c+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c+         where !sz = size z+       Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) x y e) c+  | otherwise = case f (i - sab) c of+     Full c' -> Full $ Node3 (s - 1) a b c'+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> Full $ Node3 (s - 1) a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> Full $ Node2 (s - 1) a (Node3 (sxy + se) x y e)+  where sa = size a+        sab = sa + size b+delNode f i (Node2 s a b)+  | i < sa = case f i a of+     Full a' -> Full $ Node2 (s - 1) a' b+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)+        where !sx = size x+       Node2 _ x y -> Defect $ Node3 (s - 1) e x y+  | otherwise = case f (i - sa) b of+     Full b' -> Full $ Node2 (s - 1) a b'+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 _ x y -> Defect $ Node3 (s - 1) x y e+  where sa = size a++{-# SPECIALIZE delRebuildRightDigit :: Int -> Elem a -> Digit (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}+{-# SPECIALIZE delRebuildRightDigit :: Int -> Node a -> Digit (Node (Node a)) -> FingerTree (Node (Node a)) #-}+delRebuildRightDigit :: Sized a => Int -> a -> Digit (Node a) -> FingerTree (Node a)+delRebuildRightDigit s p (One a) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (One (Node2 (sp + sx) p x)) EmptyT (One (Node2 (sxyz - sx) y z))+    where !sx = size x+  Node2 sxy x y -> Single (Node3 (sp + sxy) p x y)+delRebuildRightDigit s p (Two a b) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (One b)+    where !sx = size x+  Node2 sxy x y -> Deep s (One (Node3 (sp + sxy) p x y)) EmptyT (One b)+delRebuildRightDigit s p (Three a b c) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (Two b c)+    where !sx = size x+  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (One c)+delRebuildRightDigit s p (Four a b c d) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) EmptyT (Two c d)+    where !sx = size x+  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (Two c d)++{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Elem a)) -> Elem a -> FingerTree (Node (Elem a)) #-}+{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Node a)) -> Node a -> FingerTree (Node (Node a)) #-}+delRebuildLeftDigit :: Sized a => Int -> Digit (Node a) -> a -> FingerTree (Node a)+delRebuildLeftDigit s (One a) p = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (One (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Single (Node3 (sxy + sp) x y p)+delRebuildLeftDigit s (Two a b) p = let !sp = size p in case b of+  Node3 sxyz x y z -> Deep s (Two a (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Deep s (One a) EmptyT (One (Node3 (sxy + sp) x y p))+delRebuildLeftDigit s (Three a b c) p = let !sp = size p in case c of+  Node3 sxyz x y z -> Deep s (Two a b) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Deep s (Two a b) EmptyT (One (Node3 (sxy + sp) x y p))+delRebuildLeftDigit s (Four a b c d) p = let !sp = size p in case d of+  Node3 sxyz x y z -> Deep s (Three a b c) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Deep s (Two a b) EmptyT (Two c (Node3 (sxy + sp) x y p))++delRebuildLeftSide :: Sized a+                   => Int -> a -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)+                   -> FingerTree (Node a)+delRebuildLeftSide s p (Node2 _ a b) m sf = let !sp = size p in case a of+  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) m sf+  Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) m sf+    where !sx = size x+delRebuildLeftSide s p (Node3 _ a b c) m sf = let !sp = size p in case a of+  Node2 sxy x y -> Deep s (Three (Node3 (sp + sxy) p x y) b c) m sf+  Node3 sxyz x y z -> Deep s (Four (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b c) m sf+    where !sx = size x++delRebuildRightSide :: Sized a+                    => Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> a+                    -> FingerTree (Node a)+delRebuildRightSide s pr m (Node2 _ a b) p = let !sp = size p in case b of+  Node2 sxy x y -> Deep s pr m (Two a (Node3 (sxy + sp) x y p))+  Node3 sxyz x y z -> Deep s pr m (Three a (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z+delRebuildRightSide s pr m (Node3 _ a b c) p = let !sp = size p in case c of+  Node2 sxy x y -> Deep s pr m (Three a b (Node3 (sxy + sp) x y p))+  Node3 sxyz x y z -> Deep s pr m (Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z++delRebuildMiddle :: Sized a+                 => Int -> Digit a -> a -> Digit a+                 -> FingerTree a+delRebuildMiddle s (One a) e sf = Deep s (Two a e) EmptyT sf+delRebuildMiddle s (Two a b) e sf = Deep s (Three a b e) EmptyT sf+delRebuildMiddle s (Three a b c) e sf = Deep s (Four a b c e) EmptyT sf+delRebuildMiddle s (Four a b c d) e sf = Deep s (Two a b) (Single (node3 c d e)) sf++data DelDig a = FullDig !(Digit (Node a)) | DefectDig a++{-# SPECIALIZE delDigit :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Digit (Node (Elem a)) -> DelDig (Elem a) #-}+{-# SPECIALIZE delDigit :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Digit (Node (Node a)) -> DelDig (Node a) #-}+delDigit :: Sized a => (Int -> Node a -> Del a) -> Int -> Digit (Node a) -> DelDig a+delDigit f !i (One a) = case f i a of+  Full a' -> FullDig $ One a'+  Defect e -> DefectDig e+delDigit f i (Two a b)+  | i < sa = case f i a of+     Full a' -> FullDig $ Two a' b+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Two (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)+         where !sx = size x+       Node2 sxy x y -> FullDig $ One (Node3 (se + sxy) e x y)+  | otherwise = case f (i - sa) b of+     Full b' -> FullDig $ Two a b'+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> FullDig $ Two (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> FullDig $ One (Node3 (sxy + se) x y e)+  where sa = size a+delDigit f i (Three a b c)+  | i < sa = case f i a of+     Full a' -> FullDig $ Three a' b c+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Three (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c+         where !sx = size x+       Node2 sxy x y -> FullDig $ Two (Node3 (se + sxy) e x y) c+  | i < sab = case f (i - sa) b of+     Full b' -> FullDig $ Three a b' c+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> FullDig $ Three (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c+         where !sz = size z+       Node2 sxy x y -> FullDig $ Two (Node3 (sxy + se) x y e) c+  | otherwise = case f (i - sab) c of+     Full c' -> FullDig $ Three a b c'+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Three a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> FullDig $ Two a (Node3 (sxy + se) x y e)+  where sa = size a+        sab = sa + size b+delDigit f i (Four a b c d)+  | i < sa = case f i a of+     Full a' -> FullDig $ Four a' b c d+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Four (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c d+         where !sx = size x+       Node2 sxy x y -> FullDig $ Three (Node3 (se + sxy) e x y) c d+  | i < sab = case f (i - sa) b of+     Full b' -> FullDig $ Four a b' c d+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> FullDig $ Four (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c d+         where !sz = size z+       Node2 sxy x y -> FullDig $ Three (Node3 (sxy + se) x y e) c d+  | i < sabc = case f (i - sab) c of+     Full c' -> FullDig $ Four a b c' d+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Four a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) d+         where !sz = size z+       Node2 sxy x y -> FullDig $ Three a (Node3 (sxy + se) x y e) d+  | otherwise = case f (i - sabc) d of+     Full d' -> FullDig $ Four a b c d'+     Defect e -> let !se = size e in case c of+       Node3 sxyz x y z -> FullDig $ Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> FullDig $ Three a b (Node3 (sxy + se) x y e)+  where sa = size a+        sab = sa + size b+        sabc = sab + size c+++-- | A generalization of 'fmap', 'mapWithIndex' takes a mapping+-- function that also depends on the element's index, and applies it to every+-- element in the sequence.+mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b+mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'+ where+  {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}+  {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}+  mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b+  mapWithIndexTree _ !_s EmptyT = EmptyT+  mapWithIndexTree f s (Single xs) = Single $ f s xs+  mapWithIndexTree f s (Deep n pr m sf) =+          Deep n+               (mapWithIndexDigit f s pr)+               (mapWithIndexTree (mapWithIndexNode f) sPspr m)+               (mapWithIndexDigit f sPsprm sf)+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}+  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}+  mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b+  mapWithIndexDigit f !s (One a) = One (f s a)+  mapWithIndexDigit f s (Two a b) = Two (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  mapWithIndexDigit f s (Three a b c) =+                                      Three (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+  mapWithIndexDigit f s (Four a b c d) =+                          Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+      !sPsabc = sPsab + size c++  {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}+  {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}+  mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b+  mapWithIndexNode f s (Node2 ns a b) = Node2 ns (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  mapWithIndexNode f s (Node3 ns a b c) =+                                     Node3 ns (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithIndex #-}+{-# RULES+"mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =+  mapWithIndex (\k a -> f k (g k a)) xs+"mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =+  mapWithIndex (\k a -> f k (g a)) xs+"fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =+  mapWithIndex (\k a -> f (g k a)) xs+ #-}+#endif++{-# INLINE foldWithIndexDigit #-}+foldWithIndexDigit :: Sized a => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b+foldWithIndexDigit _ f !s (One a) = f s a+foldWithIndexDigit (<+>) f s (Two a b) = f s a <+> f sPsa b+  where+    !sPsa = s + size a+foldWithIndexDigit (<+>) f s (Three a b c) = f s a <+> f sPsa b <+> f sPsab c+  where+    !sPsa = s + size a+    !sPsab = sPsa + size b+foldWithIndexDigit (<+>) f s (Four a b c d) =+    f s a <+> f sPsa b <+> f sPsab c <+> f sPsabc d+  where+    !sPsa = s + size a+    !sPsab = sPsa + size b+    !sPsabc = sPsab + size c++{-# INLINE foldWithIndexNode #-}+foldWithIndexNode :: Sized a => (m -> m -> m) -> (Int -> a -> m) -> Int -> Node a -> m+foldWithIndexNode (<+>) f !s (Node2 _ a b) = f s a <+> f sPsa b+  where+    !sPsa = s + size a+foldWithIndexNode (<+>) f s (Node3 _ a b c) = f s a <+> f sPsa b <+> f sPsab c+  where+    !sPsa = s + size a+    !sPsab = sPsa + size b++-- A generalization of 'foldMap', 'foldMapWithIndex' takes a folding+-- function that also depends on the element's index, and applies it to every+-- element in the sequence.+--+-- @since 0.5.8+foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Seq a -> m+foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'+ where+  lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m)+#if __GLASGOW_HASKELL__ >= 708+  lift_elem g = coerce g+#else+  lift_elem g = \s (Elem a) -> g s a+#endif+  {-# INLINE lift_elem #-}+-- We have to specialize these functions by hand, unfortunately, because+-- GHC does not specialize until *all* instances are determined.+-- Although the Sized instance is known at compile time, the Monoid+-- instance generally is not.+  foldMapWithIndexTreeE :: Monoid m => (Int -> Elem a -> m) -> Int -> FingerTree (Elem a) -> m+  foldMapWithIndexTreeE _ !_s EmptyT = mempty+  foldMapWithIndexTreeE f s (Single xs) = f s xs+  foldMapWithIndexTreeE f s (Deep _ pr m sf) =+               foldMapWithIndexDigitE f s pr <>+               foldMapWithIndexTreeN (foldMapWithIndexNodeE f) sPspr m <>+               foldMapWithIndexDigitE f sPsprm sf+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  foldMapWithIndexTreeN :: Monoid m => (Int -> Node a -> m) -> Int -> FingerTree (Node a) -> m+  foldMapWithIndexTreeN _ !_s EmptyT = mempty+  foldMapWithIndexTreeN f s (Single xs) = f s xs+  foldMapWithIndexTreeN f s (Deep _ pr m sf) =+               foldMapWithIndexDigitN f s pr <>+               foldMapWithIndexTreeN (foldMapWithIndexNodeN f) sPspr m <>+               foldMapWithIndexDigitN f sPsprm sf+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m+  foldMapWithIndexDigitE f i t = foldWithIndexDigit (<>) f i t++  foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m+  foldMapWithIndexDigitN f i t = foldWithIndexDigit (<>) f i t++  foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m+  foldMapWithIndexNodeE f i t = foldWithIndexNode (<>) f i t++  foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m+  foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t++#if __GLASGOW_HASKELL__+{-# INLINABLE foldMapWithIndex #-}+#endif++-- | 'traverseWithIndex' is a version of 'traverse' that also offers+-- 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+-- We have to specialize these functions by hand, unfortunately, because+-- GHC does not specialize until *all* instances are determined.+-- Although the Sized instance is known at compile time, the Applicative+-- instance generally is not.+  traverseWithIndexTreeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> FingerTree (Elem a) -> f (FingerTree b)+  traverseWithIndexTreeE _ !_s EmptyT = pure EmptyT+  traverseWithIndexTreeE f s (Single xs) = Single <$> f s xs+  traverseWithIndexTreeE f s (Deep n pr m sf) =+          liftA3 (Deep n)+               (traverseWithIndexDigitE f s pr)+               (traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m)+               (traverseWithIndexDigitE f sPsprm sf)+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  traverseWithIndexTreeN :: Applicative f => (Int -> Node a -> f b) -> Int -> FingerTree (Node a) -> f (FingerTree b)+  traverseWithIndexTreeN _ !_s EmptyT = pure EmptyT+  traverseWithIndexTreeN f s (Single xs) = Single <$> f s xs+  traverseWithIndexTreeN f s (Deep n pr m sf) =+          liftA3 (Deep n)+               (traverseWithIndexDigitN f s pr)+               (traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m)+               (traverseWithIndexDigitN f sPsprm sf)+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  traverseWithIndexDigitE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Digit (Elem a) -> f (Digit b)+  traverseWithIndexDigitE f i t = traverseWithIndexDigit f i t++  traverseWithIndexDigitN :: Applicative f => (Int -> Node a -> f b) -> Int -> Digit (Node a) -> f (Digit b)+  traverseWithIndexDigitN f i t = traverseWithIndexDigit f i t++  {-# INLINE traverseWithIndexDigit #-}+  traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b)+  traverseWithIndexDigit f !s (One a) = One <$> f s a+  traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  traverseWithIndexDigit f s (Three a b c) =+                                      liftA3 Three (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+  traverseWithIndexDigit f s (Four a b c d) =+                          liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+      !sPsabc = sPsab + size c++  traverseWithIndexNodeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Node (Elem a) -> f (Node b)+  traverseWithIndexNodeE f i t = traverseWithIndexNode f i t++  traverseWithIndexNodeN :: Applicative f => (Int -> Node a -> f b) -> Int -> Node (Node a) -> f (Node b)+  traverseWithIndexNodeN f i t = traverseWithIndexNode f i t++  {-# INLINE traverseWithIndexNode #-}+  traverseWithIndexNode :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Node a -> f (Node b)+  traverseWithIndexNode f !s (Node2 ns a b) = liftA2 (Node2 ns) (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  traverseWithIndexNode f s (Node3 ns a b c) =+                           liftA3 (Node3 ns) (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+++#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) =+  traverseWithIndex (\k a -> f k (g k a)) xs+"travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =+  traverseWithIndex (\k a -> f k (g a)) xs+ #-}+#endif+{-+It might be nice to be able to rewrite++traverseWithIndex f (fromFunction i g)+to+replicateAWithIndex i (\k -> f k (g k))+and+traverse f (fromFunction i g)+to+replicateAWithIndex i (f . g)++but we don't have replicateAWithIndex as yet.++We might wish for a rule like+"fmapSeq/travWithIndex" forall f g xs . fmapSeq f <$> traverseWithIndex g xs =+  traverseWithIndex (\k a -> f <$> g k a) xs+Unfortunately, this rule could screw up the inliner's treatment of+fmap in general, and it also relies on the arbitrary Functor being+valid.+-}+++-- | \( O(n) \). Convert a given sequence length and a function representing that+-- sequence into a sequence.+--+-- @since 0.5.6.2+fromFunction :: Int -> (Int -> a) -> Seq a+fromFunction len f | len < 0 = error "Data.Strict.Sequence.Autogen.fromFunction called with negative len"+                   | len == 0 = empty+                   | otherwise = Seq $ create (lift_elem f) 1 0 len+  where+    create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a+    create b{-tree_builder-} !s{-tree_size-} !i{-start_index-} trees = case trees of+       1 -> Single $ b i+       2 -> Deep (2*s) (One (b i)) EmptyT (One (b (i+s)))+       3 -> Deep (3*s) (createTwo i) EmptyT (One (b (i+2*s)))+       4 -> Deep (4*s) (createTwo i) EmptyT (createTwo (i+2*s))+       5 -> Deep (5*s) (createThree i) EmptyT (createTwo (i+3*s))+       6 -> Deep (6*s) (createThree i) EmptyT (createThree (i+3*s))+       _ -> case trees `quotRem` 3 of+           (trees', 1) -> Deep (trees*s) (createTwo i)+                              (create mb (3*s) (i+2*s) (trees'-1))+                              (createTwo (i+(2+3*(trees'-1))*s))+           (trees', 2) -> Deep (trees*s) (createThree i)+                              (create mb (3*s) (i+3*s) (trees'-1))+                              (createTwo (i+(3+3*(trees'-1))*s))+           (trees', _) -> Deep (trees*s) (createThree i)+                              (create mb (3*s) (i+3*s) (trees'-2))+                              (createThree (i+(3+3*(trees'-2))*s))+      where+        createTwo j = Two (b j) (b (j + s))+        {-# INLINE createTwo #-}+        createThree j = Three (b j) (b (j + s)) (b (j + 2*s))+        {-# INLINE createThree #-}+        mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))+        {-# INLINE mb #-}++    lift_elem :: (Int -> a) -> (Int -> Elem a)+#if __GLASGOW_HASKELL__ >= 708+    lift_elem g = coerce g+#else+    lift_elem g = Elem . g+#endif+    {-# INLINE lift_elem #-}++-- | \( O(n) \). Create a sequence consisting of the elements of an 'Array'.+-- Note that the resulting sequence elements may be evaluated lazily (as on GHC),+-- so you must force the entire structure to be sure that the original array+-- can be garbage-collected.+--+-- @since 0.5.6.2+fromArray :: Ix i => Array i a -> Seq a+#ifdef __GLASGOW_HASKELL__+fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)+ where+  -- The following definition uses (Ix i) constraing, which is needed for the+  -- other fromArray definition.+  _ = Data.Array.rangeSize (Data.Array.bounds a)+#else+fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)+#endif++-- Splitting++-- | \( O(\log(\min(i,n-i))) \). The first @i@ elements of a sequence.+-- If @i@ is negative, @'take' i s@ yields the empty sequence.+-- If the sequence contains fewer than @i@ elements, the whole sequence+-- is returned.+take :: Int -> Seq a -> Seq a+take i xs@(Seq t)+    -- See note on unsigned arithmetic in splitAt+  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =+      Seq (takeTreeE i t)+  | i <= 0 = empty+  | otherwise = xs++takeTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)+takeTreeE !_i EmptyT = EmptyT+takeTreeE i t@(Single _)+   | i <= 0 = EmptyT+   | otherwise = t+takeTreeE i (Deep s pr m sf)+  | i < spr     = takePrefixE i pr+  | i < spm     = case takeTreeN im m of+            ml :*: xs -> takeMiddleE (im - size ml) spr pr ml xs+  | otherwise   = takeSuffixE (i - spm) s pr m sf+  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++takeTreeN :: Int -> FingerTree (Node a) -> StrictPair (FingerTree (Node a)) (Node a)+takeTreeN !_i EmptyT = error "takeTreeN of empty tree"+takeTreeN _i (Single x) = EmptyT :*: x+takeTreeN i (Deep s pr m sf)+  | i < spr     = takePrefixN i pr+  | i < spm     = case takeTreeN im m of+            ml :*: xs -> takeMiddleN (im - size ml) spr pr ml xs+  | otherwise   = takeSuffixN (i - spm) s pr m sf  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++takeMiddleN :: Int -> Int+             -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a)+             -> StrictPair (FingerTree (Node a)) (Node a)+takeMiddleN i spr pr ml (Node2 _ a b)+  | i < sa      = pullR sprml pr ml :*: a+  | otherwise   = Deep sprmla pr ml (One a) :*: b+  where+    sa      = size a+    sprml   = spr + size ml+    sprmla  = sa + sprml+takeMiddleN i spr pr ml (Node3 _ a b c)+  | i < sa      = pullR sprml pr ml :*: a+  | i < sab     = Deep sprmla pr ml (One a) :*: b+  | otherwise   = Deep sprmlab pr ml (Two a b) :*: c+  where+    sa      = size a+    sab     = sa + size b+    sprml   = spr + size ml+    sprmla  = sa + sprml+    sprmlab = sprmla + size b++takeMiddleE :: Int -> Int+             -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a)+             -> FingerTree (Elem a)+takeMiddleE i spr pr ml (Node2 _ a _)+  | i < 1       = pullR sprml pr ml+  | otherwise   = Deep sprmla pr ml (One a)+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+takeMiddleE i spr pr ml (Node3 _ a b _)+  | i < 1       = pullR sprml pr ml+  | i < 2       = Deep sprmla pr ml (One a)+  | otherwise   = Deep sprmlab pr ml (Two a b)+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+    sprmlab = sprmla + 1++takePrefixE :: Int -> Digit (Elem a) -> FingerTree (Elem a)+takePrefixE !_i (One _) = EmptyT+takePrefixE i (Two a _)+  | i < 1       = EmptyT+  | otherwise   = Single a+takePrefixE i (Three a b _)+  | i < 1       = EmptyT+  | i < 2       = Single a+  | otherwise   = Deep 2 (One a) EmptyT (One b)+takePrefixE i (Four a b c _)+  | i < 1       = EmptyT+  | i < 2       = Single a+  | i < 3       = Deep 2 (One a) EmptyT (One b)+  | otherwise   = Deep 3 (Two a b) EmptyT (One c)++takePrefixN :: Int -> Digit (Node a)+                    -> StrictPair (FingerTree (Node a)) (Node a)+takePrefixN !_i (One a) = EmptyT :*: a+takePrefixN i (Two a b)+  | i < sa      = EmptyT :*: a+  | otherwise   = Single a :*: b+  where+    sa      = size a+takePrefixN i (Three a b c)+  | i < sa      = EmptyT :*: a+  | i < sab     = Single a :*: b+  | otherwise   = Deep sab (One a) EmptyT (One b) :*: c+  where+    sa      = size a+    sab     = sa + size b+takePrefixN i (Four a b c d)+  | i < sa      = EmptyT :*: a+  | i < sab     = Single a :*: b+  | i < sabc    = Deep sab (One a) EmptyT (One b) :*: c+  | otherwise   = Deep sabc (Two a b) EmptyT (One c) :*: d+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++takeSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+   FingerTree (Elem a)+takeSuffixE !_i !s pr m (One _) = pullR (s - 1) pr m+takeSuffixE i s pr m (Two a _)+  | i < 1      = pullR (s - 2) pr m+  | otherwise  = Deep (s - 1) pr m (One a)+takeSuffixE i s pr m (Three a b _)+  | i < 1      = pullR (s - 3) pr m+  | i < 2      = Deep (s - 2) pr m (One a)+  | otherwise  = Deep (s - 1) pr m (Two a b)+takeSuffixE i s pr m (Four a b c _)+  | i < 1      = pullR (s - 4) pr m+  | i < 2      = Deep (s - 3) pr m (One a)+  | i < 3      = Deep (s - 2) pr m (Two a b)+  | otherwise  = Deep (s - 1) pr m (Three a b c)++takeSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+   StrictPair (FingerTree (Node a)) (Node a)+takeSuffixN !_i !s pr m (One a) = pullR (s - size a) pr m :*: a+takeSuffixN i s pr m (Two a b)+  | i < sa      = pullR (s - sa - size b) pr m :*: a+  | otherwise   = Deep (s - size b) pr m (One a) :*: b+  where+    sa      = size a+takeSuffixN i s pr m (Three a b c)+  | i < sa      = pullR (s - sab - size c) pr m :*: a+  | i < sab     = Deep (s - size b - size c) pr m (One a) :*: b+  | otherwise   = Deep (s - size c) pr m (Two a b) :*: c+  where+    sa      = size a+    sab     = sa + size b+takeSuffixN i s pr m (Four a b c d)+  | i < sa      = pullR (s - sa - sbcd) pr m :*: a+  | i < sab     = Deep (s - sbcd) pr m (One a) :*: b+  | i < sabc    = Deep (s - scd) pr m (Two a b) :*: c+  | otherwise   = Deep (s - sd) pr m (Three a b c) :*: d+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c+    sd      = size d+    scd     = size c + sd+    sbcd    = size b + scd++-- | \( O(\log(\min(i,n-i))) \). Elements of a sequence after the first @i@.+-- If @i@ is negative, @'drop' i s@ yields the whole sequence.+-- If the sequence contains fewer than @i@ elements, the empty sequence+-- is returned.+drop            :: Int -> Seq a -> Seq a+drop i xs@(Seq t)+    -- See note on unsigned arithmetic in splitAt+  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =+      Seq (takeTreeER (length xs - i) t)+  | i <= 0 = xs+  | otherwise = empty++-- We implement `drop` using a "take from the rear" strategy.  There's no+-- particular technical reason for this; it just lets us reuse the arithmetic+-- from `take` (which itself reuses the arithmetic from `splitAt`) instead of+-- figuring it out from scratch and ending up with lots of off-by-one errors.+takeTreeER :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)+takeTreeER !_i EmptyT = EmptyT+takeTreeER i t@(Single _)+   | i <= 0 = EmptyT+   | otherwise = t+takeTreeER i (Deep s pr m sf)+  | i < ssf     = takeSuffixER i sf+  | i < ssm     = case takeTreeNR im m of+            xs :*: mr -> takeMiddleER (im - size mr) ssf xs mr sf+  | otherwise   = takePrefixER (i - ssm) s pr m sf+  where+    ssf     = size sf+    ssm     = ssf + size m+    im      = i - ssf++takeTreeNR :: Int -> FingerTree (Node a) -> StrictPair (Node a) (FingerTree (Node a))+takeTreeNR !_i EmptyT = error "takeTreeNR of empty tree"+takeTreeNR _i (Single x) = x :*: EmptyT+takeTreeNR i (Deep s pr m sf)+  | i < ssf     = takeSuffixNR i sf+  | i < ssm     = case takeTreeNR im m of+            xs :*: mr -> takeMiddleNR (im - size mr) ssf xs mr sf+  | otherwise   = takePrefixNR (i - ssm) s pr m sf  where+    ssf     = size sf+    ssm     = ssf + size m+    im      = i - ssf++takeMiddleNR :: Int -> Int+             -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)+             -> StrictPair (Node a) (FingerTree (Node a))+takeMiddleNR i ssf (Node2 _ a b) mr sf+  | i < sb      = b :*: pullL ssfmr mr sf+  | otherwise   = a :*: Deep ssfmrb (One b) mr sf+  where+    sb      = size b+    ssfmr   = ssf + size mr+    ssfmrb  = sb + ssfmr+takeMiddleNR i ssf (Node3 _ a b c) mr sf+  | i < sc      = c :*: pullL ssfmr mr sf+  | i < sbc     = b :*: Deep ssfmrc (One c) mr sf+  | otherwise   = a :*: Deep ssfmrbc (Two b c) mr sf+  where+    sc      = size c+    sbc     = sc + size b+    ssfmr   = ssf + size mr+    ssfmrc  = sc + ssfmr+    ssfmrbc = ssfmrc + size b++takeMiddleER :: Int -> Int+             -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)+             -> FingerTree (Elem a)+takeMiddleER i ssf (Node2 _ _ b) mr sf+  | i < 1       = pullL ssfmr mr sf+  | otherwise   = Deep ssfmrb (One b) mr sf+  where+    ssfmr   = ssf + size mr+    ssfmrb  = 1 + ssfmr+takeMiddleER i ssf (Node3 _ _ b c) mr sf+  | i < 1       = pullL ssfmr mr sf+  | i < 2       = Deep ssfmrc (One c) mr sf+  | otherwise   = Deep ssfmrbc (Two b c) mr sf+  where+    ssfmr   = ssf + size mr+    ssfmrc  = 1 + ssfmr+    ssfmrbc = ssfmr + 2++takeSuffixER :: Int -> Digit (Elem a) -> FingerTree (Elem a)+takeSuffixER !_i (One _) = EmptyT+takeSuffixER i (Two _ b)+  | i < 1       = EmptyT+  | otherwise   = Single b+takeSuffixER i (Three _ b c)+  | i < 1       = EmptyT+  | i < 2       = Single c+  | otherwise   = Deep 2 (One b) EmptyT (One c)+takeSuffixER i (Four _ b c d)+  | i < 1       = EmptyT+  | i < 2       = Single d+  | i < 3       = Deep 2 (One c) EmptyT (One d)+  | otherwise   = Deep 3 (Two b c) EmptyT (One d)++takeSuffixNR :: Int -> Digit (Node a)+                    -> StrictPair (Node a) (FingerTree (Node a))+takeSuffixNR !_i (One a) = a :*: EmptyT+takeSuffixNR i (Two a b)+  | i < sb      = b :*: EmptyT+  | otherwise   = a :*: Single b+  where+    sb      = size b+takeSuffixNR i (Three a b c)+  | i < sc      = c :*: EmptyT+  | i < sbc     = b :*: Single c+  | otherwise   = a :*: Deep sbc (One b) EmptyT (One c)+  where+    sc      = size c+    sbc     = sc + size b+takeSuffixNR i (Four a b c d)+  | i < sd      = d :*: EmptyT+  | i < scd     = c :*: Single d+  | i < sbcd    = b :*: Deep scd (One c) EmptyT (One d)+  | otherwise   = a :*: Deep sbcd (Two b c) EmptyT (One d)+  where+    sd      = size d+    scd     = sd + size c+    sbcd    = scd + size b++takePrefixER :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+   FingerTree (Elem a)+takePrefixER !_i !s (One _) m sf = pullL (s - 1) m sf+takePrefixER i s (Two _ b) m sf+  | i < 1      = pullL (s - 2) m sf+  | otherwise  = Deep (s - 1) (One b) m sf+takePrefixER i s (Three _ b c) m sf+  | i < 1      = pullL (s - 3) m sf+  | i < 2      = Deep (s - 2) (One c) m sf+  | otherwise  = Deep (s - 1) (Two b c) m sf+takePrefixER i s (Four _ b c d) m sf+  | i < 1      = pullL (s - 4) m sf+  | i < 2      = Deep (s - 3) (One d) m sf+  | i < 3      = Deep (s - 2) (Two c d) m sf+  | otherwise  = Deep (s - 1) (Three b c d) m sf++takePrefixNR :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+   StrictPair (Node a) (FingerTree (Node a))+takePrefixNR !_i !s (One a) m sf = a :*: pullL (s - size a) m sf+takePrefixNR i s (Two a b) m sf+  | i < sb      = b :*: pullL (s - sb - size a) m sf+  | otherwise   = a :*: Deep (s - size a) (One b) m sf+  where+    sb      = size b+takePrefixNR i s (Three a b c) m sf+  | i < sc      = c :*: pullL (s - sbc - size a) m sf+  | i < sbc     = b :*: Deep (s - size b - size a) (One c) m sf+  | otherwise   = a :*: Deep (s - size a) (Two b c) m sf+  where+    sc      = size c+    sbc     = sc + size b+takePrefixNR i s (Four a b c d) m sf+  | i < sd      = d :*: pullL (s - sd - sabc) m sf+  | i < scd     = c :*: Deep (s - sabc) (One d) m sf+  | i < sbcd    = b :*: Deep (s - sab) (Two c d) m sf+  | otherwise   = a :*: Deep (s - sa) (Three b c d) m sf+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c+    sd      = size d+    scd     = size c + sd+    sbcd    = size b + scd++-- | \( O(\log(\min(i,n-i))) \). Split a sequence at a given position.+-- @'splitAt' i s = ('take' i s, 'drop' i s)@.+splitAt                  :: Int -> Seq a -> (Seq a, Seq a)+splitAt i xs@(Seq t)+  -- We use an unsigned comparison to make the common case+  -- faster. This only works because our representation of+  -- sizes as (signed) Ints gives us a free high bit to play+  -- with. Note also that there's no sharing to lose in the+  -- case that the length is 0.+  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =+      case splitTreeE i t of+        l :*: r -> (Seq l, Seq r)+  | i <= 0 = (empty, xs)+  | otherwise = (xs, empty)++-- | \( O(\log(\min(i,n-i))) \) A version of 'splitAt' that does not attempt to+-- enhance sharing when the split point is less than or equal to 0, and that+-- gives completely wrong answers when the split point is at least the length+-- of the sequence, unless the sequence is a singleton. This is used to+-- implement zipWith and chunksOf, which are extremely sensitive to the cost of+-- splitting very short sequences. There is just enough of a speed increase to+-- make this worth the trouble.+uncheckedSplitAt :: Int -> Seq a -> (Seq a, Seq a)+uncheckedSplitAt i (Seq xs) = case splitTreeE i xs of+  l :*: r -> (Seq l, Seq r)++data Split a = Split !(FingerTree (Node a)) !(Node a) !(FingerTree (Node a))+#ifdef TESTING+    deriving Show+#endif++splitTreeE :: Int -> FingerTree (Elem a) -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitTreeE !_i EmptyT = EmptyT :*: EmptyT+splitTreeE i t@(Single _)+   | i <= 0 = EmptyT :*: t+   | otherwise = t :*: EmptyT+splitTreeE i (Deep s pr m sf)+  | i < spr     = splitPrefixE i s pr m sf+  | i < spm     = case splitTreeN im m of+            Split ml xs mr -> splitMiddleE (im - size ml) s spr pr ml xs mr sf+  | otherwise   = splitSuffixE (i - spm) s pr m sf+  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++splitTreeN :: Int -> FingerTree (Node a) -> Split a+splitTreeN !_i EmptyT = error "splitTreeN of empty tree"+splitTreeN _i (Single x) = Split EmptyT x EmptyT+splitTreeN i (Deep s pr m sf)+  | i < spr     = splitPrefixN i s pr m sf+  | i < spm     = case splitTreeN im m of+            Split ml xs mr -> splitMiddleN (im - size ml) s spr pr ml xs mr sf+  | otherwise   = splitSuffixN (i - spm) s pr m sf  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++splitMiddleN :: Int -> Int -> Int+             -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)+             -> Split a+splitMiddleN i s spr pr ml (Node2 _ a b) mr sf+  | i < sa      = Split (pullR sprml pr ml) a (Deep (s - sprmla) (One b) mr sf)+  | otherwise   = Split (Deep sprmla pr ml (One a)) b (pullL (s - sprmla - size b) mr sf)+  where+    sa      = size a+    sprml   = spr + size ml+    sprmla  = sa + sprml+splitMiddleN i s spr pr ml (Node3 _ a b c) mr sf+  | i < sa      = Split (pullR sprml pr ml) a (Deep (s - sprmla) (Two b c) mr sf)+  | i < sab     = Split (Deep sprmla pr ml (One a)) b (Deep (s - sprmlab) (One c) mr sf)+  | otherwise   = Split (Deep sprmlab pr ml (Two a b)) c (pullL (s - sprmlab - size c) mr sf)+  where+    sa      = size a+    sab     = sa + size b+    sprml   = spr + size ml+    sprmla  = sa + sprml+    sprmlab = sprmla + size b++splitMiddleE :: Int -> Int -> Int+             -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)+             -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitMiddleE i s spr pr ml (Node2 _ a b) mr sf+  | i < 1       = pullR sprml pr ml :*: Deep (s - sprml) (Two a b) mr sf+  | otherwise   = Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (One b) mr sf+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+splitMiddleE i s spr pr ml (Node3 _ a b c) mr sf = case i of+  0 -> pullR sprml pr ml :*: Deep (s - sprml) (Three a b c) mr sf+  1 -> Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (Two b c) mr sf+  _ -> Deep sprmlab pr ml (Two a b) :*: Deep (s - sprmlab) (One c) mr sf+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+    sprmlab = sprmla + 1++splitPrefixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+                    StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitPrefixE !_i !s (One a) m sf = EmptyT :*: Deep s (One a) m sf+splitPrefixE i s (Two a b) m sf = case i of+  0 -> EmptyT :*: Deep s (Two a b) m sf+  _ -> Single a :*: Deep (s - 1) (One b) m sf+splitPrefixE i s (Three a b c) m sf = case i of+  0 -> EmptyT :*: Deep s (Three a b c) m sf+  1 -> Single a :*: Deep (s - 1) (Two b c) m sf+  _ -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (One c) m sf+splitPrefixE i s (Four a b c d) m sf = case i of+  0 -> EmptyT :*: Deep s (Four a b c d) m sf+  1 -> Single a :*: Deep (s - 1) (Three b c d) m sf+  2 -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (Two c d) m sf+  _ -> Deep 3 (Two a b) EmptyT (One c) :*: Deep (s - 3) (One d) m sf++splitPrefixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+                    Split a+splitPrefixN !_i !s (One a) m sf = Split EmptyT a (pullL (s - size a) m sf)+splitPrefixN i s (Two a b) m sf+  | i < sa      = Split EmptyT a (Deep (s - sa) (One b) m sf)+  | otherwise   = Split (Single a) b (pullL (s - sa - size b) m sf)+  where+    sa      = size a+splitPrefixN i s (Three a b c) m sf+  | i < sa      = Split EmptyT a (Deep (s - sa) (Two b c) m sf)+  | i < sab     = Split (Single a) b (Deep (s - sab) (One c) m sf)+  | otherwise   = Split (Deep sab (One a) EmptyT (One b)) c (pullL (s - sab - size c) m sf)+  where+    sa      = size a+    sab     = sa + size b+splitPrefixN i s (Four a b c d) m sf+  | i < sa      = Split EmptyT a $ Deep (s - sa) (Three b c d) m sf+  | i < sab     = Split (Single a) b $ Deep (s - sab) (Two c d) m sf+  | i < sabc    = Split (Deep sab (One a) EmptyT (One b)) c $ Deep (s - sabc) (One d) m sf+  | otherwise   = Split (Deep sabc (Two a b) EmptyT (One c)) d $ pullL (s - sabc - size d) m sf+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++splitSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+   StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitSuffixE !_i !s pr m (One a) = pullR (s - 1) pr m :*: Single a+splitSuffixE i s pr m (Two a b) = case i of+  0 -> pullR (s - 2) pr m :*: Deep 2 (One a) EmptyT (One b)+  _ -> Deep (s - 1) pr m (One a) :*: Single b+splitSuffixE i s pr m (Three a b c) = case i of+  0 -> pullR (s - 3) pr m :*: Deep 3 (Two a b) EmptyT (One c)+  1 -> Deep (s - 2) pr m (One a) :*: Deep 2 (One b) EmptyT (One c)+  _ -> Deep (s - 1) pr m (Two a b) :*: Single c+splitSuffixE i s pr m (Four a b c d) = case i of+  0 -> pullR (s - 4) pr m :*: Deep 4 (Two a b) EmptyT (Two c d)+  1 -> Deep (s - 3) pr m (One a) :*: Deep 3 (Two b c) EmptyT (One d)+  2 -> Deep (s - 2) pr m (Two a b) :*: Deep 2 (One c) EmptyT (One d)+  _ -> Deep (s - 1) pr m (Three a b c) :*: Single d++splitSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+   Split a+splitSuffixN !_i !s pr m (One a) = Split (pullR (s - size a) pr m) a EmptyT+splitSuffixN i s pr m (Two a b)+  | i < sa      = Split (pullR (s - sa - size b) pr m) a (Single b)+  | otherwise   = Split (Deep (s - size b) pr m (One a)) b EmptyT+  where+    sa      = size a+splitSuffixN i s pr m (Three a b c)+  | i < sa      = Split (pullR (s - sab - size c) pr m) a (deep (One b) EmptyT (One c))+  | i < sab     = Split (Deep (s - size b - size c) pr m (One a)) b (Single c)+  | otherwise   = Split (Deep (s - size c) pr m (Two a b)) c EmptyT+  where+    sa      = size a+    sab     = sa + size b+splitSuffixN i s pr m (Four a b c d)+  | i < sa      = Split (pullR (s - sa - sbcd) pr m) a (Deep sbcd (Two b c) EmptyT (One d))+  | i < sab     = Split (Deep (s - sbcd) pr m (One a)) b (Deep scd (One c) EmptyT (One d))+  | i < sabc    = Split (Deep (s - scd) pr m (Two a b)) c (Single d)+  | otherwise   = Split (Deep (s - sd) pr m (Three a b c)) d EmptyT+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c+    sd      = size d+    scd     = size c + sd+    sbcd    = size b + scd++-- | \(O \Bigl(\bigl(\frac{n}{c}\bigr) \log c\Bigr)\). @chunksOf c xs@ splits @xs@ into chunks of size @c>0@.+-- If @c@ does not divide the length of @xs@ evenly, then the last element+-- of the result will be short.+--+-- Side note: the given performance bound is missing some messy terms that only+-- really affect edge cases. Performance degrades smoothly from \( O(1) \) (for+-- \( c = n \)) to \( O(n) \) (for \( c = 1 \)). The true bound is more like+-- \( O \Bigl( \bigl(\frac{n}{c} - 1\bigr) (\log (c + 1)) + 1 \Bigr) \)+--+-- @since 0.5.8+chunksOf :: Int -> Seq a -> Seq (Seq a)+chunksOf n xs | n <= 0 =+  if null xs+    then empty+    else error "chunksOf: A non-empty sequence can only be broken up into positively-sized chunks."+chunksOf 1 s = fmap singleton s+chunksOf n s = splitMap (uncheckedSplitAt . (*n)) const most (replicate numReps ())+                 >< if null end then empty else singleton end+  where+    (numReps, endLength) = length s `quotRem` n+    (most, end) = splitAt (length s - endLength) s++-- | \( O(n) \).  Returns a sequence of all suffixes of this sequence,+-- longest first.  For example,+--+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]+--+-- Evaluating the \( i \)th suffix takes \( O(\log(\min(i, n-i))) \), but evaluating+-- every suffix in the sequence takes \( O(n) \) due to sharing.+tails                   :: Seq a -> Seq (Seq a)+tails (Seq xs)          = Seq (tailsTree (Elem . Seq) xs) |> empty++-- | \( O(n) \).  Returns a sequence of all prefixes of this sequence,+-- shortest first.  For example,+--+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]+--+-- Evaluating the \( i \)th prefix takes \( O(\log(\min(i, n-i))) \), but evaluating+-- every prefix in the sequence takes \( O(n) \) due to sharing.+inits                   :: Seq a -> Seq (Seq a)+inits (Seq xs)          = empty <| Seq (initsTree (Elem . Seq) xs)++-- This implementation of tails (and, analogously, inits) has the+-- following algorithmic advantages:+--      Evaluating each tail in the sequence takes linear total time,+--      which is better than we could say for+--              @fromList [drop n xs | n <- [0..length xs]]@.+--      Evaluating any individual tail takes logarithmic time, which is+--      better than we can say for either+--              @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.+--+-- Moreover, if we actually look at every tail in the sequence, the+-- following benchmarks demonstrate that this implementation is modestly+-- faster than any of the above:+--+-- Times (ms)+--               min      mean    +/-sd    median    max+-- Seq.tails:   21.986   24.961   10.169   22.417   86.485+-- scanr:       85.392   87.942    2.488   87.425  100.217+-- iterateN:       29.952   31.245    1.574   30.412   37.268+--+-- The algorithm for tails (and, analogously, inits) is as follows:+--+-- A Node in the FingerTree of tails is constructed by evaluating the+-- corresponding tail of the FingerTree of Nodes, considering the first+-- Node in this tail, and constructing a Node in which each tail of this+-- Node is made to be the prefix of the remaining tree.  This ends up+-- working quite elegantly, as the remainder of the tail of the FingerTree+-- of Nodes becomes the middle of a new tail, the suffix of the Node is+-- the prefix, and the suffix of the original tree is retained.+--+-- In particular, evaluating the /i/th tail involves making as+-- many partial evaluations as the Node depth of the /i/th element.+-- In addition, when we evaluate the /i/th tail, and we also evaluate+-- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,+-- each of those /m/ evaluations are shared between the computation of+-- the /i/th and /j/th tails.+--+-- wasserman.louis@gmail.com, 7/16/09++tailsDigit :: Digit a -> Digit (Digit a)+tailsDigit (One a) = One (One a)+tailsDigit (Two a b) = Two (Two a b) (One b)+tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)+tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)++initsDigit :: Digit a -> Digit (Digit a)+initsDigit (One a) = One (One a)+initsDigit (Two a b) = Two (One a) (Two a b)+initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)+initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)++tailsNode :: Node a -> Node (Digit a)+tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)+tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)++initsNode :: Node a -> Node (Digit a)+initsNode (Node2 s a b) = Node2 s (One a) (Two a b)+initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)++{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}+{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}+-- | Given a function to apply to tails of a tree, applies that function+-- to every tail of the specified tree.+tailsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b+tailsTree _ EmptyT = EmptyT+tailsTree f (Single x) = Single (f (Single x))+tailsTree f (Deep n pr m sf) =+    Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))+        (tailsTree f' m)+        (fmap (f . digitToTree) (tailsDigit sf))+  where+    f' ms = let ConsLTree node m' = viewLTree ms in+        fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)++{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}+{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}+-- | Given a function to apply to inits of a tree, applies that function+-- to every init of the specified tree.+initsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b+initsTree _ EmptyT = EmptyT+initsTree f (Single x) = Single (f (Single x))+initsTree f (Deep n pr m sf) =+    Deep n (fmap (f . digitToTree) (initsDigit pr))+        (initsTree f' m)+        (fmap (f . deep pr m) (initsDigit sf))+  where+    f' ms =  let SnocRTree m' node = viewRTree ms in+             fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)++{-# INLINE foldlWithIndex #-}+-- | 'foldlWithIndex' is a version of 'foldl' that also provides access+-- to the index of each element.+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldlWithIndex f z xs = foldl (\ g x !i -> f (g (i - 1)) i x) (const z) xs (length xs - 1)++{-# INLINE foldrWithIndex #-}+-- | 'foldrWithIndex' is a version of 'foldr' that also provides access+-- to the index of each element.+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldrWithIndex f z xs = foldr (\ x g !i -> f i x (g (i+1))) (const z) xs 0++{-# INLINE listToMaybe' #-}+-- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.+listToMaybe' :: [a] -> Maybe a+listToMaybe' = foldr (\ x _ -> Just x) Nothing++-- | \( O(i) \) where \( i \) is the prefix length. 'takeWhileL', applied+-- to a predicate @p@ and a sequence @xs@, returns the longest prefix+-- (possibly empty) of @xs@ of elements that satisfy @p@.+takeWhileL :: (a -> Bool) -> Seq a -> Seq a+takeWhileL p = fst . spanl p++-- | \( O(i) \) where \( i \) is the suffix length.  'takeWhileR', applied+-- to a predicate @p@ and a sequence @xs@, returns the longest suffix+-- (possibly empty) of @xs@ of elements that satisfy @p@.+--+-- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.+takeWhileR :: (a -> Bool) -> Seq a -> Seq a+takeWhileR p = fst . spanr p++-- | \( O(i) \) where \( i \) is the prefix length.  @'dropWhileL' p xs@ returns+-- the suffix remaining after @'takeWhileL' p xs@.+dropWhileL :: (a -> Bool) -> Seq a -> Seq a+dropWhileL p = snd . spanl p++-- | \( O(i) \) where \( i \) is the suffix length.  @'dropWhileR' p xs@ returns+-- the prefix remaining after @'takeWhileR' p xs@.+--+-- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.+dropWhileR :: (a -> Bool) -> Seq a -> Seq a+dropWhileR p = snd . spanr p++-- | \( O(i) \) where \( i \) is the prefix length.  'spanl', applied to+-- a predicate @p@ and a sequence @xs@, returns a pair whose first+-- element is the longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@ and the second element is the remainder of the sequence.+spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+spanl p = breakl (not . p)++-- | \( O(i) \) where \( i \) is the suffix length.  'spanr', applied to a+-- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element+-- is the longest /suffix/ (possibly empty) of @xs@ of elements that+-- satisfy @p@ and the second element is the remainder of the sequence.+spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+spanr p = breakr (not . p)++{-# INLINE breakl #-}+-- | \( O(i) \) where \( i \) is the breakpoint index.  'breakl', applied to a+-- predicate @p@ and a sequence @xs@, returns a pair whose first element+-- is the longest prefix (possibly empty) of @xs@ of elements that+-- /do not satisfy/ @p@ and the second element is the remainder of+-- the sequence.+--+-- @'breakl' p@ is equivalent to @'spanl' (not . p)@.+breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)++{-# INLINE breakr #-}+-- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.+breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)+  where flipPair (x, y) = (y, x)++-- | \( O(n) \).  The 'partition' function takes a predicate @p@ and a+-- sequence @xs@ and returns sequences of those elements which do and+-- do not satisfy the predicate.+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+partition p = toPair . foldl' part (empty :*: empty)+  where+    part (xs :*: ys) x+      | p x         = (xs `snoc'` x) :*: ys+      | otherwise   = xs :*: (ys `snoc'` x)++-- | \( O(n) \).  The 'filter' function takes a predicate @p@ and a sequence+-- @xs@ and returns a sequence of those elements which satisfy the+-- predicate.+filter :: (a -> Bool) -> Seq a -> Seq a+filter p = foldl' (\ xs x -> if p x then xs `snoc'` x else xs) empty++-- Indexing sequences++-- | 'elemIndexL' finds the leftmost index of the specified element,+-- if it is present, and otherwise 'Nothing'.+elemIndexL :: Eq a => a -> Seq a -> Maybe Int+elemIndexL x = findIndexL (x ==)++-- | 'elemIndexR' finds the rightmost index of the specified element,+-- if it is present, and otherwise 'Nothing'.+elemIndexR :: Eq a => a -> Seq a -> Maybe Int+elemIndexR x = findIndexR (x ==)++-- | 'elemIndicesL' finds the indices of the specified element, from+-- left to right (i.e. in ascending order).+elemIndicesL :: Eq a => a -> Seq a -> [Int]+elemIndicesL x = findIndicesL (x ==)++-- | 'elemIndicesR' finds the indices of the specified element, from+-- right to left (i.e. in descending order).+elemIndicesR :: Eq a => a -> Seq a -> [Int]+elemIndicesR x = findIndicesR (x ==)++-- | @'findIndexL' p xs@ finds the index of the leftmost element that+-- satisfies @p@, if any exist.+findIndexL :: (a -> Bool) -> Seq a -> Maybe Int+findIndexL p = listToMaybe' . findIndicesL p++-- | @'findIndexR' p xs@ finds the index of the rightmost element that+-- satisfies @p@, if any exist.+findIndexR :: (a -> Bool) -> Seq a -> Maybe Int+findIndexR p = listToMaybe' . findIndicesR p++{-# INLINE findIndicesL #-}+-- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,+-- in ascending order.+findIndicesL :: (a -> Bool) -> Seq a -> [Int]+#if __GLASGOW_HASKELL__+findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in+                foldrWithIndex g n xs)+#else+findIndicesL p xs = foldrWithIndex g [] xs+  where g i x is = if p x then i:is else is+#endif++{-# INLINE findIndicesR #-}+-- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,+-- in descending order.+findIndicesR :: (a -> Bool) -> Seq a -> [Int]+#if __GLASGOW_HASKELL__+findIndicesR p xs = build (\ c n ->+    let g z i x = if p x then c i z else z in foldlWithIndex g n xs)+#else+findIndicesR p xs = foldlWithIndex g [] xs+  where g is i x = if p x then i:is else is+#endif++------------------------------------------------------------------------+-- Lists+------------------------------------------------------------------------++-- The implementation below is based on an idea by Ross Paterson and+-- implemented by Lennart Spitzner. It avoids the rebuilding the original+-- (|>)-based implementation suffered from. It also avoids the excessive pair+-- allocations Paterson's implementation suffered from.+--+-- David Feuer suggested building in nine-element chunks, which reduces+-- intermediate conses from around (1/2)*n to around (1/8)*n with a concomitant+-- improvement in benchmark constant factors. In fact, it should be even+-- better to work in chunks of 27 `Elem`s and chunks of three `Node`s, rather+-- than nine of each, but it seems hard to avoid a code explosion with+-- such large chunks.+--+-- Paterson's code can be seen, for example, in+-- https://github.com/haskell/containers/blob/74034b3244fa4817c7bef1202e639b887a975d9e/Data.Strict.Sequence.Autogen.hs#L3532+--+-- Given a list+--+-- [1..302]+--+-- the original code forms Three 1 2 3 | [node3 4 5 6, node3 7 8 9, node3 10 11+-- 12, ...] | Two 301 302+--+-- Then it recurses on the middle list. The middle lists become successively+-- shorter as their elements become successively deeper nodes.+--+-- The original implementation of the list shortener, getNodes, included the+-- recursive step++--     getNodes s x1 (x2:x3:x4:xs) = (Node3 s x1 x2 x3:ns, d)+--            where (ns, d) = getNodes s x4 xs++-- This allocates a cons and a lazy pair at each 3-element step. It relies on+-- the Haskell implementation using Wadler's technique, described in "Fixing+-- some space leaks with a garbage collector"+-- http://homepages.inf.ed.ac.uk/wadler/papers/leak/leak.ps.gz, to repeatedly+-- simplify the `d` thunk. Although GHC uses this GC trick, heap profiling at+-- least appears to indicate that the pair constructors and conses build up+-- with this implementation.+--+-- Spitzner's implementation uses a similar approach, but replaces the middle+-- list, in each level, with a customized stream type that finishes off with+-- the final digit in that level and (since it works in nines) in the one+-- above. To work around the nested tree structure, the overall computation is+-- structured using continuation-passing style, with a function that, at the+-- bottom of the tree, deals with a stream that terminates in a nested-pair+-- representation of the entire right side of the tree. Perhaps someone will+-- eventually find a less mind-bending way to accomplish this.++-- | \( O(n) \). Create a sequence from a finite list of elements.+-- There is a function 'toList' in the opposite direction for all+-- instances of the 'Foldable' class, including 'Seq'.+fromList        :: [a] -> Seq a+-- Note: we can avoid map_elem if we wish by scattering+-- Elem applications throughout mkTreeE and getNodesE, but+-- it gets a bit hard to read.+fromList = Seq . mkTree . map_elem+  where+#ifdef __GLASGOW_HASKELL__+    mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a')+#else+    mkTree :: [Elem a] -> FingerTree (Elem a)+#endif+    mkTree [] = EmptyT+    mkTree [x1] = Single x1+    mkTree [x1, x2] = Deep 2 (One x1) EmptyT (One x2)+    mkTree [x1, x2, x3] = Deep 3 (Two x1 x2) EmptyT (One x3)+    mkTree [x1, x2, x3, x4] = Deep 4 (Two x1 x2) EmptyT (Two x3 x4)+    mkTree [x1, x2, x3, x4, x5] = Deep 5 (Three x1 x2 x3) EmptyT (Two x4 x5)+    mkTree [x1, x2, x3, x4, x5, x6] =+      Deep 6 (Three x1 x2 x3) EmptyT (Three x4 x5 x6)+    mkTree [x1, x2, x3, x4, x5, x6, x7] =+      Deep 7 (Two x1 x2) (Single (Node3 3 x3 x4 x5)) (Two x6 x7)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8] =+      Deep 8 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Two x7 x8)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9] =+      Deep 9 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Three x7 x8 x9)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1] =+      Deep 10 (Two x1 x2)+              (Deep 6 (One (Node3 3 x3 x4 x5)) EmptyT (One (Node3 3 x6 x7 x8)))+              (Two y0 y1)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1] =+      Deep 11 (Three x1 x2 x3)+              (Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))+              (Two y0 y1)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2] =+      Deep 12 (Three x1 x2 x3)+              (Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))+              (Three y0 y1 y2)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1, y2, y3, y4] =+      Deep 13 (Two x1 x2)+              (Deep 9 (Two (Node3 3 x3 x4 x5) (Node3 3 x6 x7 x8)) EmptyT (One (Node3 3 y0 y1 y2)))+              (Two y3 y4)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4] =+      Deep 14 (Three x1 x2 x3)+              (Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))+              (Two y3 y4)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4, y5] =+      Deep 15 (Three x1 x2 x3)+              (Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))+              (Three y3 y4 y5)+    mkTree (x1:x2:x3:x4:x5:x6:x7:x8:x9:y0:y1:y2:y3:y4:y5:y6:xs) =+        mkTreeC cont 9 (getNodes 3 (Node3 3 y3 y4 y5) y6 xs)+      where+        d2 = Three x1 x2 x3+        d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)+#ifdef __GLASGOW_HASKELL__+        cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a')+#endif+        cont (!r1, !r2) !sub =+          let !sub1 = Deep (9 + size r1 + size sub) d1 sub r1+          in Deep (3 + size r2 + size sub1) d2 sub1 r2++    getNodes :: forall a . Int+             -> Node a+             -> a+             -> [a]+             -> ListFinal (Node (Node a)) (Digit (Node a), Digit a)+    getNodes !_ n1 x1 [] = LFinal (One n1, One x1)+    getNodes _ n1 x1 [x2] = LFinal (One n1, Two x1 x2)+    getNodes _ n1 x1 [x2, x3] = LFinal (One n1, Three x1 x2 x3)+    getNodes s n1 x1 [x2, x3, x4] = LFinal (Two n1 (Node3 s x1 x2 x3), One x4)+    getNodes s n1 x1 [x2, x3, x4, x5] = LFinal (Two n1 (Node3 s x1 x2 x3), Two x4 x5)+    getNodes s n1 x1 [x2, x3, x4, x5, x6] = LFinal (Two n1 (Node3 s x1 x2 x3), Three x4 x5 x6)+    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), One x7)+    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Two x7 x8)+    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8, x9] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Three x7 x8 x9)+    getNodes s n1 x1 (x2:x3:x4:x5:x6:x7:x8:x9:x10:xs) = LCons n10 (getNodes s (Node3 s x7 x8 x9) x10 xs)+      where !n2 = Node3 s x1 x2 x3+            !n3 = Node3 s x4 x5 x6+            !n10 = Node3 (3*s) n1 n2 n3++    mkTreeC ::+#ifdef __GLASGOW_HASKELL__+               forall a b c .+#endif+               (b -> FingerTree (Node a) -> c)+            -> Int+            -> ListFinal (Node a) b+            -> c+    mkTreeC cont !_ (LFinal b) =+      cont b EmptyT+    mkTreeC cont _ (LCons x1 (LFinal b)) =+      cont b (Single x1)+    mkTreeC cont s (LCons x1 (LCons x2 (LFinal b))) =+      cont b (Deep (2*s) (One x1) EmptyT (One x2))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LFinal b)))) =+      cont b (Deep (3*s) (Two x1 x2) EmptyT (One x3))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b))))) =+      cont b (Deep (4*s) (Two x1 x2) EmptyT (Two x3 x4))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b)))))) =+      cont b (Deep (5*s) (Three x1 x2 x3) EmptyT (Two x4 x5))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b))))))) =+      cont b (Deep (6*s) (Three x1 x2 x3) EmptyT (Three x4 x5 x6))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b)))))))) =+      cont b (Deep (7*s) (Two x1 x2) (Single (Node3 (3*s) x3 x4 x5)) (Two x6 x7))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b))))))))) =+      cont b (Deep (8*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Two x7 x8))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b)))))))))) =+      cont b (Deep (9*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Three x7 x8 x9))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LFinal b))))))))))) =+      cont b (Deep (10*s) (Two x1 x2) (Deep (6*s) (One (Node3 (3*s) x3 x4 x5)) EmptyT (One (Node3 (3*s) x6 x7 x8))) (Two y0 y1))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LFinal b)))))))))))) =+      cont b (Deep (11*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Two y0 y1))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LFinal b))))))))))))) =+      cont b (Deep (12*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Three y0 y1 y2))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b)))))))))))))) =+      cont b (Deep (13*s) (Two x1 x2) (Deep (9*s) (Two (Node3 (3*s) x3 x4 x5) (Node3 (3*s) x6 x7 x8)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b))))))))))))))) =+      cont b (Deep (14*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LFinal b)))))))))))))))) =+      cont b (Deep (15*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Three y3 y4 y5))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) =+      mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs)+      where+#ifdef __GLASGOW_HASKELL__+        cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c+#endif+        cont2 (b, r1, r2) !sub =+          let d2 = Three x1 x2 x3+              d1 = Three (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9) (Node3 (3*s) y0 y1 y2)+              !sub1 = Deep (9*s + size r1 + size sub) d1 sub r1+          in cont b $! Deep (3*s + size r2 + size sub1) d2 sub1 r2++    getNodesC :: Int+              -> Node a+              -> a+              -> ListFinal a b+              -> ListFinal (Node (Node a)) (b, Digit (Node a), Digit a)+    getNodesC !_ n1 x1 (LFinal b) = LFinal $ (b, One n1, One x1)+    getNodesC _  n1  x1 (LCons x2 (LFinal b)) = LFinal $ (b, One n1, Two x1 x2)+    getNodesC _  n1  x1 (LCons x2 (LCons x3 (LFinal b))) = LFinal $ (b, One n1, Three x1 x2 x3)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b)))) =+      let !n2 = Node3 s x1 x2 x3+      in LFinal $ (b, Two n1 n2, One x4)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b))))) =+      let !n2 = Node3 s x1 x2 x3+      in LFinal $ (b, Two n1 n2, Two x4 x5)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b)))))) =+      let !n2 = Node3 s x1 x2 x3+      in LFinal $ (b, Two n1 n2, Three x4 x5 x6)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b))))))) =+      let !n2 = Node3 s x1 x2 x3+          !n3 = Node3 s x4 x5 x6+      in LFinal $ (b, Three n1 n2 n3, One x7)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b)))))))) =+      let !n2 = Node3 s x1 x2 x3+          !n3 = Node3 s x4 x5 x6+      in LFinal $ (b, Three n1 n2 n3, Two x7 x8)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b))))))))) =+      let !n2 = Node3 s x1 x2 x3+          !n3 = Node3 s x4 x5 x6+      in LFinal $ (b, Three n1 n2 n3, Three x7 x8 x9)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons x10 xs))))))))) =+        LCons n10 $ getNodesC s (Node3 s x7 x8 x9) x10 xs+      where !n2 = Node3 s x1 x2 x3+            !n3 = Node3 s x4 x5 x6+            !n10 = Node3 (3*s) n1 n2 n3++    map_elem :: [a] -> [Elem a]+#if __GLASGOW_HASKELL__ >= 708+    map_elem xs = coerce xs+#else+    map_elem xs = Data.List.map Elem xs+#endif+    {-# INLINE map_elem #-}++-- essentially: Free ((,) a) b.+data ListFinal a cont = LFinal !cont | LCons !a (ListFinal a cont)++#if __GLASGOW_HASKELL__ >= 708+instance GHC.Exts.IsList (Seq a) where+    type Item (Seq a) = a+    fromList = fromList+    fromListN = fromList2+    toList = toList+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.7+instance a ~ Char => IsString (Seq a) where+    fromString = fromList+#endif++------------------------------------------------------------------------+-- Reverse+------------------------------------------------------------------------++-- | \( O(n) \). The reverse of a sequence.+reverse :: Seq a -> Seq a+reverse (Seq xs) = Seq (fmapReverseTree id xs)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] reverse #-}++-- | \( O(n) \). Reverse a sequence while mapping over it. This is not+-- currently exported, but is used in rewrite rules.+fmapReverse :: (a -> b) -> Seq a -> Seq b+fmapReverse f (Seq xs) = Seq (fmapReverseTree (lift_elem f) xs)+  where+    lift_elem :: (a -> b) -> (Elem a -> Elem b)+#if __GLASGOW_HASKELL__ >= 708+    lift_elem = coerce+#else+    lift_elem g (Elem a) = Elem (g a)+#endif++-- If we're mapping over a sequence, we can reverse it at the same time+-- at no extra charge.+{-# RULES+"fmapSeq/reverse" forall f xs . fmapSeq f (reverse xs) = fmapReverse f xs+"reverse/fmapSeq" forall f xs . reverse (fmapSeq f xs) = fmapReverse f xs+ #-}+#endif++fmapReverseTree :: (a -> b) -> FingerTree a -> FingerTree b+fmapReverseTree _ EmptyT = EmptyT+fmapReverseTree f (Single x) = Single (f x)+fmapReverseTree f (Deep s pr m sf) =+    Deep s (reverseDigit f sf)+        (fmapReverseTree (reverseNode f) m)+        (reverseDigit f pr)++{-# INLINE reverseDigit #-}+reverseDigit :: (a -> b) -> Digit a -> Digit b+reverseDigit f (One a) = One (f a)+reverseDigit f (Two a b) = Two (f b) (f a)+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)++reverseNode :: (a -> b) -> Node a -> Node b+reverseNode f (Node2 s a b) = Node2 s (f b) (f a)+reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)++------------------------------------------------------------------------+-- Mapping with a splittable value+------------------------------------------------------------------------++-- For zipping, it is useful to build a result by+-- traversing a sequence while splitting up something else.  For zipping, we+-- traverse the first sequence while splitting up the second.+--+-- What makes all this crazy code a good idea:+--+-- Suppose we zip together two sequences of the same length:+--+-- zs = zip xs ys+--+-- We want to get reasonably fast indexing into zs immediately, rather than+-- needing to construct the entire thing first, as the previous implementation+-- required. The first aspect is that we build the result "outside-in" or+-- "top-down", rather than left to right. That gives us access to both ends+-- quickly. But that's not enough, by itself, to give immediate access to the+-- center of zs. For that, we need to be able to skip over larger segments of+-- zs, delaying their construction until we actually need them. The way we do+-- this is to traverse xs, while splitting up ys according to the structure of+-- xs. If we have a Deep _ pr m sf, we split ys into three pieces, and hand off+-- one piece to the prefix, one to the middle, and one to the suffix of the+-- result. The key point is that we don't need to actually do anything further+-- with those pieces until we actually need them; the computations to split+-- them up further and zip them with their matching pieces can be delayed until+-- they're actually needed. We do the same thing for Digits (splitting into+-- between one and four pieces) and Nodes (splitting into two or three). The+-- ultimate result is that we can index into, or split at, any location in zs+-- in polylogarithmic time *immediately*, while still being able to force all+-- the thunks in O(n) time.+--+-- Benchmark info, and alternatives:+--+-- The old zipping code used mapAccumL to traverse the first sequence while+-- cutting down the second sequence one piece at a time.+--+-- An alternative way to express that basic idea is to convert both sequences+-- to lists, zip the lists, and then convert the result back to a sequence.+-- I'll call this the "listy" implementation.+--+-- I benchmarked two operations: Each started by zipping two sequences+-- constructed with replicate and/or fromList. The first would then immediately+-- index into the result. The second would apply deepseq to force the entire+-- result.  The new implementation worked much better than either of the others+-- on the immediate indexing test, as expected. It also worked better than the+-- old implementation for all the deepseq tests. For short sequences, the listy+-- implementation outperformed all the others on the deepseq test. However, the+-- splitting implementation caught up and surpassed it once the sequences grew+-- long enough. It seems likely that by avoiding rebuilding, it interacts+-- better with the cache hierarchy.+--+-- David Feuer, with some guidance from Carter Schonwald, December 2014++-- | \( O(n) \). Constructs a new sequence with the same structure as an existing+-- sequence using a user-supplied mapping function along with a splittable+-- value and a way to split it. The value is split up lazily according to the+-- structure of the sequence, so one piece of the value is distributed to each+-- element of the sequence. The caller should provide a splitter function that+-- takes a number, @n@, and a splittable value, breaks off a chunk of size @n@+-- from the value, and returns that chunk and the remainder as a pair. The+-- following examples will hopefully make the usage clear:+--+-- > zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+-- > zipWith f s1 s2 = splitMap splitAt (\b a -> f a (b `index` 0)) s2' s1'+-- >   where+-- >     minLen = min (length s1) (length s2)+-- >     s1' = take minLen s1+-- >     s2' = take minLen s2+--+-- > mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b+-- > mapWithIndex f = splitMap (\n i -> (i, n+i)) f 0+#ifdef __GLASGOW_HASKELL__+-- We use ScopedTypeVariables to improve performance and make+-- performance less sensitive to minor changes.++-- We INLINE this so GHC can see that the function passed in is+-- strict in its Int argument.+{-# INLINE splitMap #-}+splitMap :: forall s a' b' . (Int -> s -> (s,s)) -> (s -> a' -> b') -> s -> Seq a' -> Seq b'+splitMap splt f0 s0 (Seq xs0) = Seq $ splitMapTreeE (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0+  where+    {-# INLINE splitMapTreeE #-}+    splitMapTreeE :: (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b+    splitMapTreeE  _ _ EmptyT = EmptyT+    splitMapTreeE  f s (Single xs) = Single $ f s xs+    splitMapTreeE  f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)+          where+            !spr = size pr+            !sm = n - spr - size sf+            (prs, r) = splt spr s+            (ms, sfs) = splt sm r++    splitMapTreeN :: (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b+    splitMapTreeN _ _ EmptyT = EmptyT+    splitMapTreeN f s (Single xs) = Single $ f s xs+    splitMapTreeN f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)+          where+            (prs, r) = splt (size pr) s+            (ms, sfs) = splt (size m) r++    {-# INLINE splitMapDigit #-}+    splitMapDigit :: Sized a => (s -> a -> b) -> s -> Digit a -> Digit b+    splitMapDigit f s (One a) = One (f s a)+    splitMapDigit f s (Two a b) = Two (f first a) (f second b)+      where+        (first, second) = splt (size a) s+    splitMapDigit f s (Three a b c) = Three (f first a) (f second b) (f third c)+      where+        (first, r) = splt (size a) s+        (second, third) = splt (size b) r+    splitMapDigit f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)+      where+        (first, s') = splt (size a) s+        (middle, fourth) = splt (size b + size c) s'+        (second, third) = splt (size b) middle++    {-# INLINE splitMapNode #-}+    splitMapNode :: Sized a => (s -> a -> b) -> s -> Node a -> Node b+    splitMapNode f s (Node2 ns a b) = Node2 ns (f first a) (f second b)+      where+        (first, second) = splt (size a) s+    splitMapNode f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)+      where+        (first, r) = splt (size a) s+        (second, third) = splt (size b) r++#else+-- Implementation without ScopedTypeVariables--somewhat slower,+-- and much more sensitive to minor changes in various places.++{-# INLINE splitMap #-}+splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b+splitMap splt' f0 s0 (Seq xs0) = Seq $ splitMapTreeE splt' (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0++{-# INLINE splitMapTreeE #-}+splitMapTreeE :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b+splitMapTreeE _    _ _ EmptyT = EmptyT+splitMapTreeE _    f s (Single xs) = Single $ f s xs+splitMapTreeE splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)+      where+        !spr = size pr+        sm = n - spr - size sf+        (prs, r) = splt spr s+        (ms, sfs) = splt sm r++splitMapTreeN :: (Int -> s -> (s,s)) -> (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b+splitMapTreeN _    _ _ EmptyT = EmptyT+splitMapTreeN _    f s (Single xs) = Single $ f s xs+splitMapTreeN splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)+      where+        (prs, r) = splt (size pr) s+        (ms, sfs) = splt (size m) r++{-# INLINE splitMapDigit #-}+splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b+splitMapDigit _    f s (One a) = One (f s a)+splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)+  where+    (first, second) = splt (size a) s+splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)+  where+    (first, r) = splt (size a) s+    (second, third) = splt (size b) r+splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)+  where+    (first, s') = splt (size a) s+    (middle, fourth) = splt (size b + size c) s'+    (second, third) = splt (size b) middle++{-# INLINE splitMapNode #-}+splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b+splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)+  where+    (first, second) = splt (size a) s+splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)+  where+    (first, r) = splt (size a) s+    (second, third) = splt (size b) r+#endif++------------------------------------------------------------------------+-- Zipping+------------------------------------------------------------------------++-- We use a custom definition of munzip to avoid retaining+-- memory longer than necessary. Using the default definition, if+-- we write+--+-- let (xs,ys) = munzip zs+-- in xs `deepseq` (... ys ...)+--+-- then ys will retain the entire zs sequence until ys itself is fully forced.+-- This implementation uses the selector thunk optimization to prevent that.+-- Unfortunately, that optimization is fragile, so we can't actually guarantee+-- anything.++-- | @ 'mzipWith' = 'zipWith' @+--+-- @ 'munzip' = 'unzip' @+instance MonadZip Seq where+  mzipWith = zipWith+  munzip = unzip++-- | Unzip a sequence of pairs.+--+-- @+-- unzip ps = ps ``seq`` ('fmap' 'fst' ps) ('fmap' 'snd' ps)+-- @+--+-- Example:+--+-- @+-- unzip $ fromList [(1,"a"), (2,"b"), (3,"c")] =+--   (fromList [1,2,3], fromList ["a", "b", "c"])+-- @+--+-- See the note about efficiency at 'unzipWith'.+--+-- @since 0.5.11+unzip :: Seq (a, b) -> (Seq a, Seq b)+unzip xs = unzipWith id xs++-- | \( O(n) \). Unzip a sequence using a function to divide elements.+--+-- @ unzipWith f xs == 'unzip' ('fmap' f xs) @+--+-- Efficiency note:+--+-- @unzipWith@ produces its two results in lockstep. If you calculate+-- @ unzipWith f xs @ and fully force /either/ of the results, then the+-- entire structure of the /other/ one will be built as well. This+-- behavior allows the garbage collector to collect each calculated+-- pair component as soon as it dies, without having to wait for its mate+-- to die. If you do not need this behavior, you may be better off simply+-- calculating the sequence of pairs and using 'fmap' to extract each+-- component sequence.+--+-- @since 0.5.11+unzipWith :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)+unzipWith f = unzipWith' (\x ->+  let+    {-# NOINLINE fx #-}+    fx = f x+    (y,z) = fx+  in (y,z))+-- Why do we lazify `f`? Because we don't want the strictness to depend+-- on exactly how the sequence is balanced. For example, what do we want+-- from+--+-- unzip [(1,2), undefined, (5,6)]?+--+-- The argument could be represented as+--+-- Seq $ Deep 3 (One (Elem (1,2))) EmptyT (Two undefined (Elem (5,6)))+--+-- or as+--+-- Seq $ Deep 3 (Two (Elem (1,2)) undefined) EmptyT (One (Elem (5,6)))+--+-- We don't want the tree balance to determine whether we get+--+-- ([1, undefined, undefined], [2, undefined, undefined])+--+-- or+--+-- ([undefined, undefined, 5], [undefined, undefined, 6])+--+-- so we pretty much have to be completely lazy in the elements.++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] unzipWith #-}++-- We don't need a special rule for unzip:+--+-- unzip (fmap f xs) = unzipWith id f xs,+--+-- which rewrites to unzipWith (id . f) xs+--+-- It's true that if GHC doesn't know the arity of `f` then+-- it won't reduce further, but that doesn't seem like too+-- big a deal here.+{-# RULES+"unzipWith/fmapSeq" forall f g xs. unzipWith f (fmapSeq g xs) =+                                     unzipWith (f . g) xs+ #-}+#endif++class UnzipWith f where+  unzipWith' :: (x -> (a, b)) -> f x -> (f a, f b)++-- This instance is only used at the very top of the tree;+-- the rest of the elements are handled by unzipWithNodeElem+instance UnzipWith Elem where+#if __GLASGOW_HASKELL__ >= 708+  unzipWith' = coerce+#else+  unzipWith' f (Elem a) = case f a of (x, y) -> (Elem x, Elem y)+#endif++-- We're very lazy here for the sake of efficiency. We want to be able to+-- reach any element of either result in logarithmic time. If we pattern+-- match strictly, we'll end up building entire 2-3 trees at once, which+-- would take linear time.+--+-- However, we're not *entirely* lazy! We are careful to build pieces+-- of each sequence as the corresponding pieces of the *other* sequence+-- are demanded. This allows the garbage collector to get rid of each+-- *component* of each result pair as soon as it is dead.+--+-- Note that this instance is used only for *internal* nodes. Nodes+-- containing elements are handled by 'unzipWithNodeElem'+instance UnzipWith Node where+  unzipWith' f (Node2 s x y) =+    ( Node2 s x1 y1+    , Node2 s x2 y2)+    where+      {-# NOINLINE fx #-}+      {-# NOINLINE fy #-}+      fx = strictifyPair (f x)+      fy = strictifyPair (f y)+      (x1, x2) = fx+      (y1, y2) = fy+  unzipWith' f (Node3 s x y z) =+    ( Node3 s x1 y1 z1+    , Node3 s x2 y2 z2)+    where+      {-# NOINLINE fx #-}+      {-# NOINLINE fy #-}+      {-# NOINLINE fz #-}+      fx = strictifyPair (f x)+      fy = strictifyPair (f y)+      fz = strictifyPair (f z)+      (x1, x2) = fx+      (y1, y2) = fy+      (z1, z2) = fz++-- Force both elements of a pair+strictifyPair :: (a, b) -> (a, b)+strictifyPair (!x, !y) = (x, y)++-- We're strict here for the sake of efficiency. The Node instance+-- is lazy, so we don't particularly need to add an extra thunk on top+-- of each node.+instance UnzipWith Digit where+  unzipWith' f (One x)+    | (x1, x2) <- f x+    = (One x1, One x2)+  unzipWith' f (Two x y)+    | (x1, x2) <- f x+    , (y1, y2) <- f y+    = ( Two x1 y1+      , Two x2 y2)+  unzipWith' f (Three x y z)+    | (x1, x2) <- f x+    , (y1, y2) <- f y+    , (z1, z2) <- f z+    = ( Three x1 y1 z1+      , Three x2 y2 z2)+  unzipWith' f (Four x y z w)+    | (x1, x2) <- f x+    , (y1, y2) <- f y+    , (z1, z2) <- f z+    , (w1, w2) <- f w+    = ( Four x1 y1 z1 w1+      , Four x2 y2 z2 w2)++instance UnzipWith FingerTree where+  unzipWith' _ EmptyT = (EmptyT, EmptyT)+  unzipWith' f (Single x)+    | (x1, x2) <- f x+    = (Single x1, Single x2)+  unzipWith' f (Deep s pr m sf)+    | (!pr1, !pr2) <- unzipWith' f pr+    , (!sf1, !sf2) <- unzipWith' f sf+    = (Deep s pr1 m1 sf1, Deep s pr2 m2 sf2)+    where+      {-# NOINLINE m1m2 #-}+      m1m2 = strictifyPair $ unzipWith' (unzipWith' f) m+      (m1, m2) = m1m2++instance UnzipWith Seq where+  unzipWith' _ (Seq EmptyT) = (empty, empty)+  unzipWith' f (Seq (Single (Elem x)))+    | (x1, x2) <- f x+    = (singleton x1, singleton x2)+  unzipWith' f (Seq (Deep s pr m sf))+    | (!pr1, !pr2) <- unzipWith' (unzipWith' f) pr+    , (!sf1, !sf2) <- unzipWith' (unzipWith' f) sf+    = (Seq (Deep s pr1 m1 sf1), Seq (Deep s pr2 m2 sf2))+    where+      {-# NOINLINE m1m2 #-}+      m1m2 = strictifyPair $ unzipWith' (unzipWithNodeElem f) m+      (m1, m2) = m1m2++-- Here we need to be lazy in the children (because they're+-- Elems), but we can afford to be strict in the results+-- of `f` because it's sure to return a pair immediately+-- (unzipWith lazifies the function it's passed).+unzipWithNodeElem :: (x -> (a, b))+       -> Node (Elem x) -> (Node (Elem a), Node (Elem b))+unzipWithNodeElem f (Node2 s (Elem x) (Elem y))+  | (x1, x2) <- f x+  , (y1, y2) <- f y+  = ( Node2 s (Elem x1) (Elem y1)+    , Node2 s (Elem x2) (Elem y2))+unzipWithNodeElem f (Node3 s (Elem x) (Elem y) (Elem z))+  | (x1, x2) <- f x+  , (y1, y2) <- f y+  , (z1, z2) <- f z+  = ( Node3 s (Elem x1) (Elem y1) (Elem z1)+    , Node3 s (Elem x2) (Elem y2) (Elem z2))++-- | \( O(\min(n_1,n_2)) \).  'zip' takes two sequences and returns a sequence+-- of corresponding pairs.  If one input is short, excess elements are+-- discarded from the right end of the longer sequence.+zip :: Seq a -> Seq b -> Seq (a, b)+zip = zipWith (,)++-- | \( O(\min(n_1,n_2)) \).  'zipWith' generalizes 'zip' by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, @zipWith (+)@ is applied to two sequences to take the+-- sequence of corresponding sums.+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith f s1 s2 = zipWith' f s1' s2'+  where+    minLen = min (length s1) (length s2)+    s1' = take minLen s1+    s2' = take minLen s2++-- | A version of zipWith that assumes the sequences have the same length.+zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith' f s1 s2 = splitMap uncheckedSplitAt goLeaf s2 s1+  where+    goLeaf (Seq (Single (Elem b))) a = f a b+    goLeaf _ _ = error "Data.Strict.Sequence.Autogen.zipWith'.goLeaf internal error: not a singleton"++-- | \( O(\min(n_1,n_2,n_3)) \).  'zip3' takes three sequences and returns a+-- sequence of triples, analogous to 'zip'.+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zip3 = zipWith3 (,,)++-- | \( O(\min(n_1,n_2,n_3)) \).  'zipWith3' takes a function which combines+-- three elements, as well as three sequences and returns a sequence of+-- their point-wise combinations, analogous to 'zipWith'.+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'+  where+    minLen = minimum [length s1, length s2, length s3]+    s1' = take minLen s1+    s2' = take minLen s2+    s3' = take minLen s3++zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3++-- | \( O(\min(n_1,n_2,n_3,n_4)) \).  'zip4' takes four sequences and returns a+-- sequence of quadruples, analogous to 'zip'.+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)+zip4 = zipWith4 (,,,)++-- | \( O(\min(n_1,n_2,n_3,n_4)) \).  'zipWith4' takes a function which combines+-- four elements, as well as four sequences and returns a sequence of+-- their point-wise combinations, analogous to 'zipWith'.+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'+  where+    minLen = minimum [length s1, length s2, length s3, length s4]+    s1' = take minLen s1+    s2' = take minLen s2+    s3' = take minLen s3+    s4' = take minLen s4++-- | fromList2, given a list and its length, constructs a completely+-- balanced Seq whose elements are that list using the replicateA+-- generalization.+fromList2 :: Int -> [a] -> Seq a+fromList2 n = execState (replicateA n (State ht))+  where+    ht (x:xs) = (xs, x)+    ht []     = error "fromList2: short list"
+ src/Data/Strict/Sequence/Autogen/Internal/Sorting.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- 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+-- closely.+--+-- = Description+--+-- This module provides the various sorting implementations for+-- "Data.Strict.Sequence.Autogen". Further notes are available in the file sorting.md+-- (in this directory).++module Data.Strict.Sequence.Autogen.Internal.Sorting+  (+   -- * Sort Functions+   sort+  ,sortBy+  ,sortOn+  ,unstableSort+  ,unstableSortBy+  ,unstableSortOn+  ,+   -- * Heaps+   -- $heaps+   Queue(..)+  ,QList(..)+  ,IndexedQueue(..)+  ,IQList(..)+  ,TaggedQueue(..)+  ,TQList(..)+  ,IndexedTaggedQueue(..)+  ,ITQList(..)+  ,+   -- * Merges+   -- $merges+   mergeQ+  ,mergeIQ+  ,mergeTQ+  ,mergeITQ+  ,+   -- * popMin+   -- $popMin+   popMinQ+  ,popMinIQ+  ,popMinTQ+  ,popMinITQ+  ,+   -- * Building+   -- $building+   buildQ+  ,buildIQ+  ,buildTQ+  ,buildITQ+  ,+   -- * Special folds+   -- $folds+   foldToMaybeTree+  ,foldToMaybeWithIndexTree)+  where++import Data.Strict.Sequence.Autogen.Internal+       (Elem(..), Seq(..), Node(..), Digit(..), Sized(..), FingerTree(..),+        replicateA, foldDigit, foldNode, foldWithIndexDigit,+        foldWithIndexNode)+import Data.Strict.ContainersUtils.Autogen.State (State(..), execState)+-- | \( O(n \log n) \).  'sort' sorts the specified 'Seq' by the natural+-- ordering of its elements.  The sort is stable.  If stability is not+-- required, 'unstableSort' can be slightly faster.+--+-- @since 0.3.0+sort :: Ord a => Seq a -> Seq a+sort = sortBy compare++-- | \( O(n \log n) \).  'sortBy' sorts the specified 'Seq' according to the+-- specified comparator.  The sort is stable.  If stability is not required,+-- 'unstableSortBy' can be slightly faster.+--+-- @since 0.3.0+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a+sortBy cmp (Seq xs) =+    maybe+        (Seq EmptyT)+        (execState (replicateA (size xs) (State (popMinIQ cmp))))+        (buildIQ cmp (\s (Elem x) -> IQ s x IQNil) 0 xs)++-- | \( O(n \log n) \). 'sortOn' sorts the specified 'Seq' by comparing+-- the results of a key function applied to each element. @'sortOn' f@ is+-- equivalent to @'sortBy' ('compare' ``Data.Function.on`` f)@, but has the+-- performance advantage of only evaluating @f@ once for each element in the+-- input list. This is called the decorate-sort-undecorate paradigm, or+-- Schwartzian transform.+--+-- An example of using 'sortOn' might be to sort a 'Seq' of strings+-- according to their length:+--+-- > sortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]+--+-- If, instead, 'sortBy' had been used, 'length' would be evaluated on+-- every comparison, giving \( O(n \log n) \) evaluations, rather than+-- \( O(n) \).+--+-- If @f@ is very cheap (for example a record selector, or 'fst'),+-- @'sortBy' ('compare' ``Data.Function.on`` f)@ will be faster than+-- @'sortOn' f@.+--+-- @since 0.5.11+sortOn :: Ord b => (a -> b) -> Seq a -> Seq a+sortOn f (Seq xs) =+    maybe+       (Seq EmptyT)+       (execState (replicateA (size xs) (State (popMinITQ compare))))+       (buildITQ compare (\s (Elem x) -> ITQ s (f x) x ITQNil) 0 xs)++-- | \( O(n \log n) \).  'unstableSort' sorts the specified 'Seq' by+-- the natural ordering of its elements, but the sort is not stable.+-- This algorithm is frequently faster and uses less memory than 'sort'.++-- Notes on the implementation and choice of heap are available in+-- the file sorting.md (in this directory).+--+-- @since 0.3.0+unstableSort :: Ord a => Seq a -> Seq a+unstableSort = unstableSortBy compare++-- | \( O(n \log n) \).  A generalization of 'unstableSort', 'unstableSortBy'+-- takes an arbitrary comparator and sorts the specified sequence.+-- The sort is not stable.  This algorithm is frequently faster and+-- uses less memory than 'sortBy'.+--+-- @since 0.3.0+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a+unstableSortBy cmp (Seq xs) =+    maybe+        (Seq EmptyT)+        (execState (replicateA (size xs) (State (popMinQ cmp))))+        (buildQ cmp (\(Elem x) -> Q x Nil) xs)++-- | \( O(n \log n) \). 'unstableSortOn' sorts the specified 'Seq' by+-- comparing the results of a key function applied to each element.+-- @'unstableSortOn' f@ is equivalent to @'unstableSortBy' ('compare' ``Data.Function.on`` f)@,+-- but has the performance advantage of only evaluating @f@ once for each+-- element in the input list. This is called the+-- decorate-sort-undecorate paradigm, or Schwartzian transform.+--+-- An example of using 'unstableSortOn' might be to sort a 'Seq' of strings+-- according to their length:+--+-- > unstableSortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]+--+-- If, instead, 'unstableSortBy' had been used, 'length' would be evaluated on+-- every comparison, giving \( O(n \log n) \) evaluations, rather than+-- \( O(n) \).+--+-- If @f@ is very cheap (for example a record selector, or 'fst'),+-- @'unstableSortBy' ('compare' ``Data.Function.on`` f)@ will be faster than+-- @'unstableSortOn' f@.+--+-- @since 0.5.11+unstableSortOn :: Ord b => (a -> b) -> Seq a -> Seq a+unstableSortOn f (Seq xs) =+    maybe+       (Seq EmptyT)+       (execState (replicateA (size xs) (State (popMinTQ compare))))+       (buildTQ compare (\(Elem x) -> TQ (f x) x TQNil) xs)++------------------------------------------------------------------------+-- $heaps+--+-- The following are definitions for various specialized pairing heaps.+--+-- All of the heaps are defined to be non-empty, which speeds up the+-- merge functions.+------------------------------------------------------------------------++-- | A simple pairing heap.+data Queue e = Q !e (QList e)+data QList e+    = Nil+    | QCons {-# UNPACK #-} !(Queue e)+            (QList e)++-- | A pairing heap tagged with the original position of elements,+-- to allow for stable sorting.+data IndexedQueue e =+    IQ {-# UNPACK #-} !Int !e (IQList e)+data IQList e+    = IQNil+    | IQCons {-# UNPACK #-} !(IndexedQueue e)+             (IQList e)++-- | A pairing heap tagged with some key for sorting elements, for use+-- in 'unstableSortOn'.+data TaggedQueue a b =+    TQ !a b (TQList a b)+data TQList a b+    = TQNil+    | TQCons {-# UNPACK #-} !(TaggedQueue a b)+             (TQList a b)++-- | A pairing heap tagged with both a key and the original position+-- of its elements, for use in 'sortOn'.+data IndexedTaggedQueue e a =+    ITQ {-# UNPACK #-} !Int !e a (ITQList e a)+data ITQList e a+    = ITQNil+    | ITQCons {-# UNPACK #-} !(IndexedTaggedQueue e a)+              (ITQList e a)++infixr 8 `ITQCons`, `TQCons`, `QCons`, `IQCons`++------------------------------------------------------------------------+-- $merges+--+-- The following are definitions for "merge" for each of the heaps+-- above. Each takes a comparison function which is used to order the+-- elements.+------------------------------------------------------------------------++-- | 'mergeQ' merges two 'Queue's.+mergeQ :: (a -> a -> Ordering) -> Queue a -> Queue a -> Queue a+mergeQ cmp q1@(Q x1 ts1) q2@(Q x2 ts2)+  | cmp x1 x2 == GT = Q x2 (q1 `QCons` ts2)+  | otherwise       = Q x1 (q2 `QCons` ts1)++-- | 'mergeTQ' merges two 'TaggedQueue's, based on the tag value.+mergeTQ :: (a -> a -> Ordering)+        -> TaggedQueue a b+        -> TaggedQueue a b+        -> TaggedQueue a b+mergeTQ cmp q1@(TQ x1 y1 ts1) q2@(TQ x2 y2 ts2)+  | cmp x1 x2 == GT = TQ x2 y2 (q1 `TQCons` ts2)+  | otherwise       = TQ x1 y1 (q2 `TQCons` ts1)++-- | 'mergeIQ' merges two 'IndexedQueue's, taking into account the+-- original position of the elements.+mergeIQ :: (a -> a -> Ordering)+        -> IndexedQueue a+        -> IndexedQueue a+        -> IndexedQueue a+mergeIQ cmp q1@(IQ i1 x1 ts1) q2@(IQ i2 x2 ts2) =+    case cmp x1 x2 of+        LT -> IQ i1 x1 (q2 `IQCons` ts1)+        EQ | i1 <= i2 -> IQ i1 x1 (q2 `IQCons` ts1)+        _ -> IQ i2 x2 (q1 `IQCons` ts2)++-- | 'mergeITQ' merges two 'IndexedTaggedQueue's, based on the tag+-- value, taking into account the original position of the elements.+mergeITQ+    :: (a -> a -> Ordering)+    -> IndexedTaggedQueue a b+    -> IndexedTaggedQueue a b+    -> IndexedTaggedQueue a b+mergeITQ cmp q1@(ITQ i1 x1 y1 ts1) q2@(ITQ i2 x2 y2 ts2) =+    case cmp x1 x2 of+        LT -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)+        EQ | i1 <= i2 -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)+        _ -> ITQ i2 x2 y2 (q1 `ITQCons` ts2)++------------------------------------------------------------------------+-- $popMin+--+-- The following are definitions for @popMin@, a function which+-- constructs a stateful action which pops the smallest element from the+-- queue, where "smallest" is according to the supplied comparison+-- function.+--+-- All of the functions fail on an empty queue.+--+-- Each of these functions is structured something like this:+--+-- @popMinQ cmp (Q x ts) = (mergeQs ts, x)@+--+-- The reason the call to @mergeQs@ is lazy is that it will be bottom+-- for the last element in the queue, preventing us from evaluating the+-- fully sorted sequence.+------------------------------------------------------------------------++-- | Pop the smallest element from the queue, using the supplied+-- comparator.+popMinQ :: (e -> e -> Ordering) -> Queue e -> (Queue e, e)+popMinQ cmp (Q x xs) = (mergeQs xs, x)+  where+    mergeQs (t `QCons` Nil) = t+    mergeQs (t1 `QCons` t2 `QCons` Nil) = t1 <+> t2+    mergeQs (t1 `QCons` t2 `QCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs Nil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeQ cmp++-- | Pop the smallest element from the queue, using the supplied+-- comparator, deferring to the item's original position when the+-- comparator returns 'EQ'.+popMinIQ :: (e -> e -> Ordering) -> IndexedQueue e -> (IndexedQueue e, e)+popMinIQ cmp (IQ _ x xs) = (mergeQs xs, x)+  where+    mergeQs (t `IQCons` IQNil) = t+    mergeQs (t1 `IQCons` t2 `IQCons` IQNil) = t1 <+> t2+    mergeQs (t1 `IQCons` t2 `IQCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs IQNil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeIQ cmp++-- | Pop the smallest element from the queue, using the supplied+-- comparator on the tag.+popMinTQ :: (a -> a -> Ordering) -> TaggedQueue a b -> (TaggedQueue a b, b)+popMinTQ cmp (TQ _ x xs) = (mergeQs xs, x)+  where+    mergeQs (t `TQCons` TQNil) = t+    mergeQs (t1 `TQCons` t2 `TQCons` TQNil) = t1 <+> t2+    mergeQs (t1 `TQCons` t2 `TQCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs TQNil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeTQ cmp++-- | Pop the smallest element from the queue, using the supplied+-- comparator on the tag, deferring to the item's original position+-- when the comparator returns 'EQ'.+popMinITQ :: (e -> e -> Ordering)+          -> IndexedTaggedQueue e b+          -> (IndexedTaggedQueue e b, b)+popMinITQ cmp (ITQ _ _ x xs) = (mergeQs xs, x)+  where+    mergeQs (t `ITQCons` ITQNil) = t+    mergeQs (t1 `ITQCons` t2 `ITQCons` ITQNil) = t1 <+> t2+    mergeQs (t1 `ITQCons` t2 `ITQCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs ITQNil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeITQ cmp++------------------------------------------------------------------------+-- $building+--+-- The following are definitions for functions to build queues, given a+-- comparison function.+------------------------------------------------------------------------++buildQ :: (b -> b -> Ordering) -> (a -> Queue b) -> FingerTree a -> Maybe (Queue b)+buildQ cmp = foldToMaybeTree (mergeQ cmp)++buildIQ+    :: (b -> b -> Ordering)+    -> (Int -> Elem y -> IndexedQueue b)+    -> Int+    -> FingerTree (Elem y)+    -> Maybe (IndexedQueue b)+buildIQ cmp = foldToMaybeWithIndexTree (mergeIQ cmp)++buildTQ+    :: (b -> b -> Ordering)+    -> (a -> TaggedQueue b c)+    -> FingerTree a+    -> Maybe (TaggedQueue b c)+buildTQ cmp = foldToMaybeTree (mergeTQ cmp)++buildITQ+    :: (b -> b -> Ordering)+    -> (Int -> Elem y -> IndexedTaggedQueue b c)+    -> Int+    -> FingerTree (Elem y)+    -> Maybe (IndexedTaggedQueue b c)+buildITQ cmp = foldToMaybeWithIndexTree (mergeITQ cmp)++------------------------------------------------------------------------+-- $folds+--+-- A big part of what makes the heaps fast is that they're non empty,+-- so the merge function can avoid an extra case match. To take+-- advantage of this, though, we need specialized versions of 'foldMap'+-- and 'Data.Strict.Sequence.Autogen.foldMapWithIndex', which can alternate between+-- calling the faster semigroup-like merge when folding over non empty+-- structures (like 'Node' and 'Digit'), and the+-- 'Data.Semirgroup.Option'-like mappend, when folding over structures+-- which can be empty (like 'FingerTree').+------------------------------------------------------------------------++-- | A 'foldMap'-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.+foldToMaybeTree :: (b -> b -> b) -> (a -> b) -> FingerTree a -> Maybe b+foldToMaybeTree _ _ EmptyT = Nothing+foldToMaybeTree _ f (Single xs) = Just (f xs)+foldToMaybeTree (<+>) f (Deep _ pr m sf) =+    Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')+  where+    pr' = foldDigit (<+>) f pr+    sf' = foldDigit (<+>) f sf+    m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m++-- | A 'Data.Strict.Sequence.Autogen.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.+foldToMaybeWithIndexTree :: (b -> b -> b)+                         -> (Int -> Elem y -> b)+                         -> Int+                         -> FingerTree (Elem y)+                         -> Maybe b+foldToMaybeWithIndexTree = foldToMaybeWithIndexTree'+  where+    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> Maybe b #-}+    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> Maybe b #-}+    foldToMaybeWithIndexTree'+        :: Sized a+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> FingerTree a -> Maybe b+    foldToMaybeWithIndexTree' _ _ !_s EmptyT = Nothing+    foldToMaybeWithIndexTree' _ f s (Single xs) = Just (f s xs)+    foldToMaybeWithIndexTree' (<+>) f s (Deep _ pr m sf) =+        Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')+      where+        pr' = digit (<+>) f s pr+        sf' = digit (<+>) f sPsprm sf+        m' = foldToMaybeWithIndexTree' (<+>) (node (<+>) f) sPspr m+        !sPspr = s + size pr+        !sPsprm = sPspr + size m+    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> b #-}+    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Digit (Node y) -> b #-}+    digit+        :: Sized a+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b+    digit = foldWithIndexDigit+    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Node (Elem y) -> b #-}+    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Node (Node y) -> b #-}+    node+        :: Sized a+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Node a -> b+    node = foldWithIndexNode+{-# INLINE foldToMaybeWithIndexTree #-}
+ src/Data/Strict/Sequence/Internal.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Strict.Sequence.Internal where++import Data.Sequence                as L+import Data.Strict.Sequence.Autogen as S++import Data.Binary+import Data.Foldable+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex+import Data.Semigroup (Semigroup (..)) -- helps with compatibility+import Data.Strict.Classes++instance Strict (L.Seq k) (S.Seq k) where+  toStrict = S.fromList . toList+  toLazy = L.fromList . toList+  {-# INLINE toStrict #-}+  {-# INLINE toLazy #-}++-- code copied from indexed-traversable++-- | The position in the 'Seq' is available as the index.+instance FunctorWithIndex Int S.Seq where+  imap = S.mapWithIndex+  {-# INLINE imap #-}++instance FoldableWithIndex Int S.Seq where+  ifoldMap = S.foldMapWithIndex+  {-# INLINE ifoldMap #-}+  ifoldr = S.foldrWithIndex+  {-# INLINE ifoldr #-}+  ifoldl f = S.foldlWithIndex (flip f)+  {-# INLINE ifoldl #-}++instance TraversableWithIndex Int S.Seq where+  itraverse = S.traverseWithIndex+  {-# INLINE itraverse #-}++-- code copied from binary++instance (Binary e) => Binary (S.Seq e) where+    put s = put (S.length s) <> mapM_ put s+    get = do n <- get :: Get Int+             rep S.empty n get+      where rep xs 0 _ = return $! xs+            rep xs n g = xs `seq` n `seq` do+                           x <- g+                           rep (xs S.|> x) (n-1) g
+ src/Data/Strict/Set.hs view
@@ -0,0 +1,10 @@+{- | Module alias of "Data.Set"++This module re-exports "Data.Set" for convenience, so that you can avoid an+additional direct dependency on @containers@ if you want to.+-}+module Data.Strict.Set+  ( module Data.Set+  ) where++import Data.Set
+ src/Data/Strict/Vector.hs view
@@ -0,0 +1,19 @@+{- | Fully-strict version of "Data.Vector"++Unlike "Data.Vector" t'Data.Vector.Vector' the instances of our {- haddock+ #1251 -} t'Data.Strict.Vector.Vector' are all strict as well.++You should be able to switch from the former simply by changing your module+imports, and your package dependency from @vector@ to @strict-containers@.+If this doesn't work, please file a bug.++The documentation in the auto-generated modules have not been updated in a+particularly sophisticated way, so may sound weird or contradictory. In those+cases, please re-interpret such weird wording in the context of the above.+-}+module Data.Strict.Vector+  ( module Data.Strict.Vector.Autogen+  ) where++import Data.Strict.Vector.Internal+import Data.Strict.Vector.Autogen
+ src/Data/Strict/Vector/Autogen.hs view
@@ -0,0 +1,2032 @@+{-# LANGUAGE CPP+           , DeriveDataTypeable+           , FlexibleInstances+           , MultiParamTypeClasses+           , TypeFamilies+           , Rank2Types+           , BangPatterns+  #-}++-- |+-- Module      : Data.Strict.Vector.Autogen+-- Copyright   : (c) Roman Leshchinskiy 2008-2010+-- License     : BSD-style+--+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable+--+-- A library for boxed vectors (that is, polymorphic arrays capable of+-- holding any Haskell value). The vectors come in two flavours:+--+--  * mutable+--+--  * immutable+--+-- and support a rich interface of both list-like operations, and bulk+-- array operations.+--+-- For unboxed arrays, use "Data.Strict.Vector.Autogen.Unboxed"+--++module Data.Strict.Vector.Autogen (+  -- * Boxed vectors+  Vector, MVector,++  -- * Accessors++  -- ** Length information+  length, null,++  -- ** Indexing+  (!), (!?), head, last,+  unsafeIndex, unsafeHead, unsafeLast,++  -- ** Monadic indexing+  indexM, headM, lastM,+  unsafeIndexM, unsafeHeadM, unsafeLastM,++  -- ** Extracting subvectors (slicing)+  slice, init, tail, take, drop, splitAt, uncons, unsnoc,+  unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop,++  -- * Construction++  -- ** Initialisation+  empty, singleton, replicate, generate, iterateN,++  -- ** Monadic initialisation+  replicateM, generateM, iterateNM, create, createT,++  -- ** Unfolding+  unfoldr, unfoldrN, unfoldrExactN,+  unfoldrM, unfoldrNM, unfoldrExactNM,+  constructN, constructrN,++  -- ** Enumeration+  enumFromN, enumFromStepN, enumFromTo, enumFromThenTo,++  -- ** Concatenation+  cons, snoc, (++), concat,++  -- ** Restricting memory usage+  force,++  -- * Modifying vectors++  -- ** Bulk updates+  (//), update, update_,+  unsafeUpd, unsafeUpdate, unsafeUpdate_,++  -- ** Accumulations+  accum, accumulate, accumulate_,+  unsafeAccum, unsafeAccumulate, unsafeAccumulate_,++  -- ** Permutations+  reverse, backpermute, unsafeBackpermute,++  -- ** Safe destructive updates+  modify,++  -- * Elementwise operations++  -- ** Indexing+  indexed,++  -- ** Mapping+  map, imap, concatMap,++  -- ** Monadic mapping+  mapM, imapM, mapM_, imapM_, forM, forM_,+  iforM, iforM_,++  -- ** Zipping+  zipWith, zipWith3, zipWith4, zipWith5, zipWith6,+  izipWith, izipWith3, izipWith4, izipWith5, izipWith6,+  zip, zip3, zip4, zip5, zip6,++  -- ** Monadic zipping+  zipWithM, izipWithM, zipWithM_, izipWithM_,++  -- ** Unzipping+  unzip, unzip3, unzip4, unzip5, unzip6,++  -- * Working with predicates++  -- ** Filtering+  filter, ifilter, filterM, uniq,+  mapMaybe, imapMaybe,+  mapMaybeM, imapMaybeM,+  catMaybes,+  takeWhile, dropWhile,++  -- ** Partitioning+  partition, unstablePartition, partitionWith, span, break,++  -- ** Searching+  elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices,++  -- * Folding+  foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1',+  ifoldl, ifoldl', ifoldr, ifoldr',+  foldMap, foldMap',++  -- ** Specialised folds+  all, any, and, or,+  sum, product,+  maximum, maximumBy, minimum, minimumBy,+  minIndex, minIndexBy, maxIndex, maxIndexBy,++  -- ** Monadic folds+  foldM, ifoldM, foldM', ifoldM',+  fold1M, fold1M',foldM_, ifoldM_,+  foldM'_, ifoldM'_, fold1M_, fold1M'_,++  -- ** Monadic sequencing+  sequence, sequence_,++  -- * Prefix sums (scans)+  prescanl, prescanl',+  postscanl, postscanl',+  scanl, scanl', scanl1, scanl1',+  iscanl, iscanl',+  prescanr, prescanr',+  postscanr, postscanr',+  scanr, scanr', scanr1, scanr1',+  iscanr, iscanr',++  -- ** Comparisons+  eqBy, cmpBy,++  -- * Conversions++  -- ** Lists+  toList, Data.Strict.Vector.Autogen.fromList, Data.Strict.Vector.Autogen.fromListN,++  -- ** Arrays+  fromArray, toArray,++  -- ** Other vector types+  G.convert,++  -- ** Mutable vectors+  freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy+) where++import Data.Strict.Vector.Autogen.Mutable  ( MVector(..) )+import Data.Primitive.Array+import qualified Data.Vector.Fusion.Bundle as Bundle+import qualified Data.Vector.Generic as G++import Control.DeepSeq ( NFData(rnf)+#if MIN_VERSION_deepseq(1,4,3)+                       , NFData1(liftRnf)+#endif+                       )++import Control.Monad ( MonadPlus(..), liftM, ap )+import Control.Monad.ST ( ST, runST )+import Control.Monad.Primitive+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fix ( MonadFix (mfix) )+import Control.Monad.Zip+import Data.Function ( fix )++import Prelude hiding ( length, null,+                        replicate, (++), concat,+                        head, last,+                        init, tail, take, drop, splitAt, reverse,+                        map, concatMap,+                        zipWith, zipWith3, zip, zip3, unzip, unzip3,+                        filter, takeWhile, dropWhile, span, break,+                        elem, notElem,+                        foldl, foldl1, foldr, foldr1,+#if __GLASGOW_HASKELL__ >= 706+                        foldMap,+#endif+                        all, any, and, or, sum, product, minimum, maximum,+                        scanl, scanl1, scanr, scanr1,+                        enumFromTo, enumFromThenTo,+                        mapM, mapM_, sequence, sequence_ )++#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..))+#endif++import Data.Typeable  ( Typeable )+import Data.Data      ( Data(..) )+import Text.Read      ( Read(..), readListPrecDefault )+import Data.Semigroup ( Semigroup(..) )++import qualified Control.Applicative as Applicative+import qualified Data.Foldable as Foldable+import qualified Data.Traversable as Traversable++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid   ( Monoid(..) )+#endif++#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as Exts (IsList(..))+#endif+++-- | Boxed vectors, supporting efficient slicing.+data Vector a = Vector {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !(Array a)+        deriving ( Typeable )++liftRnfV :: (a -> ()) -> Vector a -> ()+liftRnfV elemRnf = foldl' (\_ -> elemRnf) ()++instance NFData a => NFData (Vector a) where+  rnf = liftRnfV rnf+  {-# INLINEABLE rnf #-}++#if MIN_VERSION_deepseq(1,4,3)+-- | @since 0.12.1.0+instance NFData1 Vector where+  liftRnf = liftRnfV+  {-# INLINEABLE liftRnf #-}+#endif++instance Show a => Show (Vector a) where+  showsPrec = G.showsPrec++instance Read a => Read (Vector a) where+  readPrec = G.readPrec+  readListPrec = readListPrecDefault++#if MIN_VERSION_base(4,9,0)+instance Show1 Vector where+    liftShowsPrec = G.liftShowsPrec++instance Read1 Vector where+    liftReadsPrec = G.liftReadsPrec+#endif++#if __GLASGOW_HASKELL__ >= 708++instance Exts.IsList (Vector a) where+  type Item (Vector a) = a+  fromList = Data.Strict.Vector.Autogen.fromList+  fromListN = Data.Strict.Vector.Autogen.fromListN+  toList = toList+#endif++instance Data a => Data (Vector a) where+  gfoldl       = G.gfoldl+  toConstr _   = G.mkVecConstr "Data.Strict.Vector.Autogen.Vector"+  gunfold      = G.gunfold+  dataTypeOf _ = G.mkVecType "Data.Strict.Vector.Autogen.Vector"+  dataCast1    = G.dataCast++type instance G.Mutable Vector = MVector++instance G.Vector Vector a where+  {-# INLINE basicUnsafeFreeze #-}+  basicUnsafeFreeze (MVector i n marr)+    = Vector i n `liftM` unsafeFreezeArray marr++  {-# INLINE basicUnsafeThaw #-}+  basicUnsafeThaw (Vector i n arr)+    = MVector i n `liftM` unsafeThawArray arr++  {-# INLINE basicLength #-}+  basicLength (Vector _ n _) = n++  {-# INLINE basicUnsafeSlice #-}+  basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr++  {-# INLINE basicUnsafeIndexM #-}+  basicUnsafeIndexM (Vector i _ arr) j = indexArrayM arr (i+j)++  {-# INLINE basicUnsafeCopy #-}+  basicUnsafeCopy (MVector i n dst) (Vector j _ src)+    = copyArray dst i src j n++  {-# INLINE elemseq #-}+  elemseq _ = seq++-- See http://trac.haskell.org/vector/ticket/12+instance Eq a => Eq (Vector a) where+  {-# INLINE (==) #-}+  xs == ys = Bundle.eq (G.stream xs) (G.stream ys)++  {-# INLINE (/=) #-}+  xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys))++-- See http://trac.haskell.org/vector/ticket/12+instance Ord a => Ord (Vector a) where+  {-# INLINE compare #-}+  compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys)++  {-# INLINE (<) #-}+  xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT++  {-# INLINE (<=) #-}+  xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT++  {-# INLINE (>) #-}+  xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT++  {-# INLINE (>=) #-}+  xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT++#if MIN_VERSION_base(4,9,0)+instance Eq1 Vector where+  liftEq eq xs ys = Bundle.eqBy eq (G.stream xs) (G.stream ys)++instance Ord1 Vector where+  liftCompare cmp xs ys = Bundle.cmpBy cmp (G.stream xs) (G.stream ys)+#endif++instance Semigroup (Vector a) where+  {-# INLINE (<>) #-}+  (<>) = (++)++  {-# INLINE sconcat #-}+  sconcat = G.concatNE++instance Monoid (Vector a) where+  {-# INLINE mempty #-}+  mempty = empty++  {-# INLINE mappend #-}+  mappend = (++)++  {-# INLINE mconcat #-}+  mconcat = concat++instance Functor Vector where+  {-# INLINE fmap #-}+  fmap = map++#if MIN_VERSION_base(4,8,0)+  {-# INLINE (<$) #-}+  (<$) = map . const+#endif++instance Monad Vector where+  {-# INLINE return #-}+  return = Applicative.pure++  {-# INLINE (>>=) #-}+  (>>=) = flip concatMap++#if !(MIN_VERSION_base(4,13,0))+  {-# INLINE fail #-}+  fail = Fail.fail -- == \ _str -> empty+#endif++-- | @since 0.12.1.0+instance Fail.MonadFail Vector where+  {-# INLINE fail #-}+  fail _ = empty++instance MonadPlus Vector where+  {-# INLINE mzero #-}+  mzero = empty++  {-# INLINE mplus #-}+  mplus = (++)++instance MonadZip Vector where+  {-# INLINE mzip #-}+  mzip = zip++  {-# INLINE mzipWith #-}+  mzipWith = zipWith++  {-# INLINE munzip #-}+  munzip = unzip++-- | Instance has same semantics as one for lists+--+--  @since 0.12.2.0+instance MonadFix Vector where+  -- We take care to dispose of v0 as soon as possible (see headM docs).+  --+  -- It's perfectly safe to use non-monadic indexing within generate+  -- call since intermediate vector won't be created until result's+  -- value is demanded.+  {-# INLINE mfix #-}+  mfix f+    | null v0 = empty+    -- We take first element of resulting vector from v0 and create+    -- rest using generate. Note that cons should fuse with generate+    | otherwise = runST $ do+        h <- headM v0+        return $ cons h $+          generate (lv0 - 1) $+            \i -> fix (\a -> f a ! (i + 1))+    where+      -- Used to calculate size of resulting vector+      v0 = fix (f . head)+      !lv0 = length v0++instance Applicative.Applicative Vector where+  {-# INLINE pure #-}+  pure = singleton++  {-# INLINE (<*>) #-}+  (<*>) = ap++instance Applicative.Alternative Vector where+  {-# INLINE empty #-}+  empty = empty++  {-# INLINE (<|>) #-}+  (<|>) = (++)++instance Foldable.Foldable Vector where+  {-# INLINE foldr #-}+  foldr = foldr++  {-# INLINE foldl #-}+  foldl = foldl++  {-# INLINE foldr1 #-}+  foldr1 = foldr1++  {-# INLINE foldl1 #-}+  foldl1 = foldl1++#if MIN_VERSION_base(4,6,0)+  {-# INLINE foldr' #-}+  foldr' = foldr'++  {-# INLINE foldl' #-}+  foldl' = foldl'+#endif++#if MIN_VERSION_base(4,8,0)+  {-# INLINE toList #-}+  toList = toList++  {-# INLINE length #-}+  length = length++  {-# INLINE null #-}+  null = null++  {-# INLINE elem #-}+  elem = elem++  {-# INLINE maximum #-}+  maximum = maximum++  {-# INLINE minimum #-}+  minimum = minimum++  {-# INLINE sum #-}+  sum = sum++  {-# INLINE product #-}+  product = product+#endif++instance Traversable.Traversable Vector where+  {-# INLINE traverse #-}+  traverse f xs =+      -- Get the length of the vector in /O(1)/ time+      let !n = G.length xs+      -- Use fromListN to be more efficient in construction of resulting vector+      -- Also behaves better with compact regions, preventing runtime exceptions+      in  Data.Strict.Vector.Autogen.fromListN n Applicative.<$> Traversable.traverse f (toList xs)++  {-# INLINE mapM #-}+  mapM = mapM++  {-# INLINE sequence #-}+  sequence = sequence++-- Length information+-- ------------------++-- | /O(1)/ Yield the length of the vector+length :: Vector a -> Int+{-# INLINE length #-}+length = G.length++-- | /O(1)/ Test whether a vector is empty+null :: Vector a -> Bool+{-# INLINE null #-}+null = G.null++-- Indexing+-- --------++-- | O(1) Indexing+(!) :: Vector a -> Int -> a+{-# INLINE (!) #-}+(!) = (G.!)++-- | O(1) Safe indexing+(!?) :: Vector a -> Int -> Maybe a+{-# INLINE (!?) #-}+(!?) = (G.!?)++-- | /O(1)/ First element+head :: Vector a -> a+{-# INLINE head #-}+head = G.head++-- | /O(1)/ Last element+last :: Vector a -> a+{-# INLINE last #-}+last = G.last++-- | /O(1)/ Unsafe indexing without bounds checking+unsafeIndex :: Vector a -> Int -> a+{-# INLINE unsafeIndex #-}+unsafeIndex = G.unsafeIndex++-- | /O(1)/ First element without checking if the vector is empty+unsafeHead :: Vector a -> a+{-# INLINE unsafeHead #-}+unsafeHead = G.unsafeHead++-- | /O(1)/ Last element without checking if the vector is empty+unsafeLast :: Vector a -> a+{-# INLINE unsafeLast #-}+unsafeLast = G.unsafeLast++-- Monadic indexing+-- ----------------++-- | /O(1)/ Indexing in a monad.+--+-- The monad allows operations to be strict in the vector when necessary.+-- Suppose vector copying is implemented like this:+--+-- > copy mv v = ... write mv i (v ! i) ...+--+-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@+-- would unnecessarily retain a reference to @v@ in each element written.+--+-- With 'indexM', copying can be implemented like this instead:+--+-- > copy mv v = ... do+-- >                   x <- indexM v i+-- >                   write mv i x+--+-- Here, no references to @v@ are retained because indexing (but /not/ the+-- elements) is evaluated eagerly.+--+indexM :: Monad m => Vector a -> Int -> m a+{-# INLINE indexM #-}+indexM = G.indexM++-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an+-- explanation of why this is useful.+headM :: Monad m => Vector a -> m a+{-# INLINE headM #-}+headM = G.headM++-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an+-- explanation of why this is useful.+lastM :: Monad m => Vector a -> m a+{-# INLINE lastM #-}+lastM = G.lastM++-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an+-- explanation of why this is useful.+unsafeIndexM :: Monad m => Vector a -> Int -> m a+{-# INLINE unsafeIndexM #-}+unsafeIndexM = G.unsafeIndexM++-- | /O(1)/ First element in a monad without checking for empty vectors.+-- See 'indexM' for an explanation of why this is useful.+unsafeHeadM :: Monad m => Vector a -> m a+{-# INLINE unsafeHeadM #-}+unsafeHeadM = G.unsafeHeadM++-- | /O(1)/ Last element in a monad without checking for empty vectors.+-- See 'indexM' for an explanation of why this is useful.+unsafeLastM :: Monad m => Vector a -> m a+{-# INLINE unsafeLastM #-}+unsafeLastM = G.unsafeLastM++-- Extracting subvectors (slicing)+-- -------------------------------++-- | /O(1)/ Yield a slice of the vector without copying it. The vector must+-- contain at least @i+n@ elements.+slice :: Int   -- ^ @i@ starting index+                 -> Int   -- ^ @n@ length+                 -> Vector a+                 -> Vector a+{-# INLINE slice #-}+slice = G.slice++-- | /O(1)/ Yield all but the last element without copying. The vector may not+-- be empty.+init :: Vector a -> Vector a+{-# INLINE init #-}+init = G.init++-- | /O(1)/ Yield all but the first element without copying. The vector may not+-- be empty.+tail :: Vector a -> Vector a+{-# INLINE tail #-}+tail = G.tail++-- | /O(1)/ Yield at the first @n@ elements without copying. The vector may+-- contain less than @n@ elements in which case it is returned unchanged.+take :: Int -> Vector a -> Vector a+{-# INLINE take #-}+take = G.take++-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may+-- contain less than @n@ elements in which case an empty vector is returned.+drop :: Int -> Vector a -> Vector a+{-# INLINE drop #-}+drop = G.drop++-- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying.+--+-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@+-- but slightly more efficient.+--+-- @since 0.7.1+splitAt :: Int -> Vector a -> (Vector a, Vector a)+{-# INLINE splitAt #-}+splitAt = G.splitAt++-- | /O(1)/ Yield the 'head' and 'tail' of the vector, or 'Nothing' if empty.+--+-- @since 0.12.2.0+uncons :: Vector a -> Maybe (a, Vector a)+{-# INLINE uncons #-}+uncons = G.uncons++-- | /O(1)/ Yield the 'last' and 'init' of the vector, or 'Nothing' if empty.+--+-- @since 0.12.2.0+unsnoc :: Vector a -> Maybe (Vector a, a)+{-# INLINE unsnoc #-}+unsnoc = G.unsnoc++-- | /O(1)/ Yield a slice of the vector without copying. The vector must+-- contain at least @i+n@ elements but this is not checked.+unsafeSlice :: Int   -- ^ @i@ starting index+                       -> Int   -- ^ @n@ length+                       -> Vector a+                       -> Vector a+{-# INLINE unsafeSlice #-}+unsafeSlice = G.unsafeSlice++-- | /O(1)/ Yield all but the last element without copying. The vector may not+-- be empty but this is not checked.+unsafeInit :: Vector a -> Vector a+{-# INLINE unsafeInit #-}+unsafeInit = G.unsafeInit++-- | /O(1)/ Yield all but the first element without copying. The vector may not+-- be empty but this is not checked.+unsafeTail :: Vector a -> Vector a+{-# INLINE unsafeTail #-}+unsafeTail = G.unsafeTail++-- | /O(1)/ Yield the first @n@ elements without copying. The vector must+-- contain at least @n@ elements but this is not checked.+unsafeTake :: Int -> Vector a -> Vector a+{-# INLINE unsafeTake #-}+unsafeTake = G.unsafeTake++-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector+-- must contain at least @n@ elements but this is not checked.+unsafeDrop :: Int -> Vector a -> Vector a+{-# INLINE unsafeDrop #-}+unsafeDrop = G.unsafeDrop++-- Initialisation+-- --------------++-- | /O(1)/ Empty vector+empty :: Vector a+{-# INLINE empty #-}+empty = G.empty++-- | /O(1)/ Vector with exactly one element+singleton :: a -> Vector a+{-# INLINE singleton #-}+singleton = G.singleton++-- | /O(n)/ Vector of the given length with the same value in each position+replicate :: Int -> a -> Vector a+{-# INLINE replicate #-}+replicate = G.replicate++-- | /O(n)/ Construct a vector of the given length by applying the function to+-- each index+generate :: Int -> (Int -> a) -> Vector a+{-# INLINE generate #-}+generate = G.generate++-- | /O(n)/ Apply function \(\max(n - 1, 0)\) times to an initial value, producing a vector+-- of length \(\max(n, 0)\). Zeroth element will contain the initial value, that's why there+-- is one less function application than the number of elements in the produced vector.+--+-- \( \underbrace{x, f (x), f (f (x)), \ldots}_{\max(0,n)\rm{~elements}} \)+--+-- ===__Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.iterateN 0 undefined undefined :: V.Vector String+-- []+-- >>> V.iterateN 4 (\x -> x <> x) "Hi"+-- ["Hi","HiHi","HiHiHiHi","HiHiHiHiHiHiHiHi"]+--+-- @since 0.7.1+iterateN :: Int -> (a -> a) -> a -> Vector a+{-# INLINE iterateN #-}+iterateN = G.iterateN++-- Unfolding+-- ---------++-- | /O(n)/ Construct a vector by repeatedly applying the generator function+-- to a seed. The generator function yields 'Just' the next element and the+-- new seed or 'Nothing' if there are no more elements.+--+-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10+-- >  = <10,9,8,7,6,5,4,3,2,1>+unfoldr :: (b -> Maybe (a, b)) -> b -> Vector a+{-# INLINE unfoldr #-}+unfoldr = G.unfoldr++-- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying+-- the generator function to a seed. The generator function yields 'Just' the+-- next element and the new seed or 'Nothing' if there are no more elements.+--+-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8>+unfoldrN :: Int -> (b -> Maybe (a, b)) -> b -> Vector a+{-# INLINE unfoldrN #-}+unfoldrN = G.unfoldrN++-- | /O(n)/ Construct a vector with exactly @n@ elements by repeatedly applying+-- the generator function to a seed. The generator function yields the+-- next element and the new seed.+--+-- > unfoldrExactN 3 (\n -> (n,n-1)) 10 = <10,9,8>+--+-- @since 0.12.2.0+unfoldrExactN  :: Int -> (b -> (a, b)) -> b -> Vector a+{-# INLINE unfoldrExactN #-}+unfoldrExactN = G.unfoldrExactN++-- | /O(n)/ Construct a vector by repeatedly applying the monadic+-- generator function to a seed. The generator function yields 'Just'+-- the next element and the new seed or 'Nothing' if there are no more+-- elements.+unfoldrM :: (Monad m) => (b -> m (Maybe (a, b))) -> b -> m (Vector a)+{-# INLINE unfoldrM #-}+unfoldrM = G.unfoldrM++-- | /O(n)/ Construct a vector by repeatedly applying the monadic+-- generator function to a seed. The generator function yields 'Just'+-- the next element and the new seed or 'Nothing' if there are no more+-- elements.+unfoldrNM :: (Monad m) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a)+{-# INLINE unfoldrNM #-}+unfoldrNM = G.unfoldrNM++-- | /O(n)/ Construct a vector with exactly @n@ elements by repeatedly+-- applying the monadic generator function to a seed. The generator+-- function yields the next element and the new seed.+--+-- @since 0.12.2.0+unfoldrExactNM :: (Monad m) => Int -> (b -> m (a, b)) -> b -> m (Vector a)+{-# INLINE unfoldrExactNM #-}+unfoldrExactNM = G.unfoldrExactNM++-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the+-- generator function to the already constructed part of the vector.+--+-- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in <a,b,c>+--+constructN :: Int -> (Vector a -> a) -> Vector a+{-# INLINE constructN #-}+constructN = G.constructN++-- | /O(n)/ Construct a vector with @n@ elements from right to left by+-- repeatedly applying the generator function to the already constructed part+-- of the vector.+--+-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in <c,b,a>+--+constructrN :: Int -> (Vector a -> a) -> Vector a+{-# INLINE constructrN #-}+constructrN = G.constructrN++-- Enumeration+-- -----------++-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@+-- etc. This operation is usually more efficient than 'enumFromTo'.+--+-- > enumFromN 5 3 = <5,6,7>+enumFromN :: Num a => a -> Int -> Vector a+{-# INLINE enumFromN #-}+enumFromN = G.enumFromN++-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@,+-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'.+--+-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4>+enumFromStepN :: Num a => a -> a -> Int -> Vector a+{-# INLINE enumFromStepN #-}+enumFromStepN = G.enumFromStepN++-- | /O(n)/ Enumerate values from @x@ to @y@.+--+-- /WARNING:/ This operation can be very inefficient. If at all possible, use+-- 'enumFromN' instead.+enumFromTo :: Enum a => a -> a -> Vector a+{-# INLINE enumFromTo #-}+enumFromTo = G.enumFromTo++-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@.+--+-- /WARNING:/ This operation can be very inefficient. If at all possible, use+-- 'enumFromStepN' instead.+enumFromThenTo :: Enum a => a -> a -> a -> Vector a+{-# INLINE enumFromThenTo #-}+enumFromThenTo = G.enumFromThenTo++-- Concatenation+-- -------------++-- | /O(n)/ Prepend an element+cons :: a -> Vector a -> Vector a+{-# INLINE cons #-}+cons = G.cons++-- | /O(n)/ Append an element+snoc :: Vector a -> a -> Vector a+{-# INLINE snoc #-}+snoc = G.snoc++infixr 5 +++-- | /O(m+n)/ Concatenate two vectors+(++) :: Vector a -> Vector a -> Vector a+{-# INLINE (++) #-}+(++) = (G.++)++-- | /O(n)/ Concatenate all vectors in the list+concat :: [Vector a] -> Vector a+{-# INLINE concat #-}+concat = G.concat++-- Monadic initialisation+-- ----------------------++-- | /O(n)/ Execute the monadic action the given number of times and store the+-- results in a vector.+replicateM :: Monad m => Int -> m a -> m (Vector a)+{-# INLINE replicateM #-}+replicateM = G.replicateM++-- | /O(n)/ Construct a vector of the given length by applying the monadic+-- action to each index+generateM :: Monad m => Int -> (Int -> m a) -> m (Vector a)+{-# INLINE generateM #-}+generateM = G.generateM++-- | /O(n)/ Apply monadic function \(\max(n - 1, 0)\) times to an initial value, producing a vector+-- of length \(\max(n, 0)\). Zeroth element will contain the initial value, that's why there+-- is one less function application than the number of elements in the produced vector.+--+-- For non-monadic version see `iterateN`+--+-- @since 0.12.0.0+iterateNM :: Monad m => Int -> (a -> m a) -> a -> m (Vector a)+{-# INLINE iterateNM #-}+iterateNM = G.iterateNM++-- | Execute the monadic action and freeze the resulting vector.+--+-- @+-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\>+-- @+create :: (forall s. ST s (MVector s a)) -> Vector a+{-# INLINE create #-}+-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120+create p = G.create p++-- | Execute the monadic action and freeze the resulting vectors.+createT :: Traversable.Traversable f => (forall s. ST s (f (MVector s a))) -> f (Vector a)+{-# INLINE createT #-}+createT p = G.createT p++++-- Restricting memory usage+-- ------------------------++-- | /O(n)/ Yield the argument but force it not to retain any extra memory,+-- possibly by copying it.+--+-- This is especially useful when dealing with slices. For example:+--+-- > force (slice 0 2 <huge vector>)+--+-- Here, the slice retains a reference to the huge vector. Forcing it creates+-- a copy of just the elements that belong to the slice and allows the huge+-- vector to be garbage collected.+force :: Vector a -> Vector a+{-# INLINE force #-}+force = G.force++-- Bulk updates+-- ------------++-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector+-- element at position @i@ by @a@.+--+-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7>+--+(//) :: Vector a   -- ^ initial vector (of length @m@)+                -> [(Int, a)] -- ^ list of index/value pairs (of length @n@)+                -> Vector a+{-# INLINE (//) #-}+(//) = (G.//)++-- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs,+-- replace the vector element at position @i@ by @a@.+--+-- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7>+--+update :: Vector a        -- ^ initial vector (of length @m@)+       -> Vector (Int, a) -- ^ vector of index/value pairs (of length @n@)+       -> Vector a+{-# INLINE update #-}+update = G.update++-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the+-- corresponding value @a@ from the value vector, replace the element of the+-- initial vector at position @i@ by @a@.+--+-- > update_ <5,9,2,7>  <2,0,2> <1,3,8> = <3,9,8,7>+--+-- The function 'update' provides the same functionality and is usually more+-- convenient.+--+-- @+-- update_ xs is ys = 'update' xs ('zip' is ys)+-- @+update_ :: Vector a   -- ^ initial vector (of length @m@)+        -> Vector Int -- ^ index vector (of length @n1@)+        -> Vector a   -- ^ value vector (of length @n2@)+        -> Vector a+{-# INLINE update_ #-}+update_ = G.update_++-- | Same as ('//') but without bounds checking.+unsafeUpd :: Vector a -> [(Int, a)] -> Vector a+{-# INLINE unsafeUpd #-}+unsafeUpd = G.unsafeUpd++-- | Same as 'update' but without bounds checking.+unsafeUpdate :: Vector a -> Vector (Int, a) -> Vector a+{-# INLINE unsafeUpdate #-}+unsafeUpdate = G.unsafeUpdate++-- | Same as 'update_' but without bounds checking.+unsafeUpdate_ :: Vector a -> Vector Int -> Vector a -> Vector a+{-# INLINE unsafeUpdate_ #-}+unsafeUpdate_ = G.unsafeUpdate_++-- Accumulations+-- -------------++-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element+-- @a@ at position @i@ by @f a b@.+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.accum (+) (V.fromList [1000.0,2000.0,3000.0]) [(2,4),(1,6),(0,3),(1,10)]+-- [1003.0,2016.0,3004.0]+accum :: (a -> b -> a) -- ^ accumulating function @f@+      -> Vector a      -- ^ initial vector (of length @m@)+      -> [(Int,b)]     -- ^ list of index/value pairs (of length @n@)+      -> Vector a+{-# INLINE accum #-}+accum = G.accum++-- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector+-- element @a@ at position @i@ by @f a b@.+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.accumulate (+) (V.fromList [1000.0,2000.0,3000.0]) (V.fromList [(2,4),(1,6),(0,3),(1,10)])+-- [1003.0,2016.0,3004.0]+accumulate :: (a -> b -> a)  -- ^ accumulating function @f@+            -> Vector a       -- ^ initial vector (of length @m@)+            -> Vector (Int,b) -- ^ vector of index/value pairs (of length @n@)+            -> Vector a+{-# INLINE accumulate #-}+accumulate = G.accumulate++-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the+-- corresponding value @b@ from the the value vector,+-- replace the element of the initial vector at+-- position @i@ by @f a b@.+--+-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4>+--+-- The function 'accumulate' provides the same functionality and is usually more+-- convenient.+--+-- @+-- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs)+-- @+accumulate_ :: (a -> b -> a) -- ^ accumulating function @f@+            -> Vector a      -- ^ initial vector (of length @m@)+            -> Vector Int    -- ^ index vector (of length @n1@)+            -> Vector b      -- ^ value vector (of length @n2@)+            -> Vector a+{-# INLINE accumulate_ #-}+accumulate_ = G.accumulate_++-- | Same as 'accum' but without bounds checking.+unsafeAccum :: (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a+{-# INLINE unsafeAccum #-}+unsafeAccum = G.unsafeAccum++-- | Same as 'accumulate' but without bounds checking.+unsafeAccumulate :: (a -> b -> a) -> Vector a -> Vector (Int,b) -> Vector a+{-# INLINE unsafeAccumulate #-}+unsafeAccumulate = G.unsafeAccumulate++-- | Same as 'accumulate_' but without bounds checking.+unsafeAccumulate_+  :: (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a+{-# INLINE unsafeAccumulate_ #-}+unsafeAccumulate_ = G.unsafeAccumulate_++-- Permutations+-- ------------++-- | /O(n)/ Reverse a vector+reverse :: Vector a -> Vector a+{-# INLINE reverse #-}+reverse = G.reverse++-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the+-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is+-- often much more efficient.+--+-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>+backpermute :: Vector a -> Vector Int -> Vector a+{-# INLINE backpermute #-}+backpermute = G.backpermute++-- | Same as 'backpermute' but without bounds checking.+unsafeBackpermute :: Vector a -> Vector Int -> Vector a+{-# INLINE unsafeBackpermute #-}+unsafeBackpermute = G.unsafeBackpermute++-- Safe destructive updates+-- ------------------------++-- | Apply a destructive operation to a vector. The operation will be+-- performed in place if it is safe to do so and will modify a copy of the+-- vector otherwise.+--+-- @+-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\>+-- @+modify :: (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a+{-# INLINE modify #-}+modify p = G.modify p++-- Indexing+-- --------++-- | /O(n)/ Pair each element in a vector with its index+indexed :: Vector a -> Vector (Int,a)+{-# INLINE indexed #-}+indexed = G.indexed++-- Mapping+-- -------++-- | /O(n)/ Map a function over a vector+map :: (a -> b) -> Vector a -> Vector b+{-# INLINE map #-}+map = G.map++-- | /O(n)/ Apply a function to every element of a vector and its index+imap :: (Int -> a -> b) -> Vector a -> Vector b+{-# INLINE imap #-}+imap = G.imap++-- | Map a function over a vector and concatenate the results.+concatMap :: (a -> Vector b) -> Vector a -> Vector b+{-# INLINE concatMap #-}+concatMap = G.concatMap++-- Monadic mapping+-- ---------------++-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a+-- vector of results+mapM :: Monad m => (a -> m b) -> Vector a -> m (Vector b)+{-# INLINE mapM #-}+mapM = G.mapM++-- | /O(n)/ Apply the monadic action to every element of a vector and its+-- index, yielding a vector of results+imapM :: Monad m => (Int -> a -> m b) -> Vector a -> m (Vector b)+{-# INLINE imapM #-}+imapM = G.imapM++-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the+-- results+mapM_ :: Monad m => (a -> m b) -> Vector a -> m ()+{-# INLINE mapM_ #-}+mapM_ = G.mapM_++-- | /O(n)/ Apply the monadic action to every element of a vector and its+-- index, ignoring the results+imapM_ :: Monad m => (Int -> a -> m b) -> Vector a -> m ()+{-# INLINE imapM_ #-}+imapM_ = G.imapM_++-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a+-- vector of results. Equivalent to @flip 'mapM'@.+forM :: Monad m => Vector a -> (a -> m b) -> m (Vector b)+{-# INLINE forM #-}+forM = G.forM++-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the+-- results. Equivalent to @flip 'mapM_'@.+forM_ :: Monad m => Vector a -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_ = G.forM_++-- | /O(n)/ Apply the monadic action to all elements of the vector and their indices, yielding a+-- vector of results. Equivalent to 'flip' 'imapM'.+--+-- @since 0.12.2.0+iforM :: Monad m => Vector a -> (Int -> a -> m b) -> m (Vector b)+{-# INLINE iforM #-}+iforM = G.iforM++-- | /O(n)/ Apply the monadic action to all elements of the vector and their indices and ignore the+-- results. Equivalent to 'flip' 'imapM_'.+--+-- @since 0.12.2.0+iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()+{-# INLINE iforM_ #-}+iforM_ = G.iforM_++-- Zipping+-- -------++-- | /O(min(m,n))/ Zip two vectors with the given function.+zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c+{-# INLINE zipWith #-}+zipWith = G.zipWith++-- | Zip three vectors with the given function.+zipWith3 :: (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d+{-# INLINE zipWith3 #-}+zipWith3 = G.zipWith3++zipWith4 :: (a -> b -> c -> d -> e)+         -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+{-# INLINE zipWith4 #-}+zipWith4 = G.zipWith4++zipWith5 :: (a -> b -> c -> d -> e -> f)+         -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+         -> Vector f+{-# INLINE zipWith5 #-}+zipWith5 = G.zipWith5++zipWith6 :: (a -> b -> c -> d -> e -> f -> g)+         -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+         -> Vector f -> Vector g+{-# INLINE zipWith6 #-}+zipWith6 = G.zipWith6++-- | /O(min(m,n))/ Zip two vectors with a function that also takes the+-- elements' indices.+izipWith :: (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c+{-# INLINE izipWith #-}+izipWith = G.izipWith++-- | Zip three vectors and their indices with the given function.+izipWith3 :: (Int -> a -> b -> c -> d)+          -> Vector a -> Vector b -> Vector c -> Vector d+{-# INLINE izipWith3 #-}+izipWith3 = G.izipWith3++izipWith4 :: (Int -> a -> b -> c -> d -> e)+          -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+{-# INLINE izipWith4 #-}+izipWith4 = G.izipWith4++izipWith5 :: (Int -> a -> b -> c -> d -> e -> f)+          -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+          -> Vector f+{-# INLINE izipWith5 #-}+izipWith5 = G.izipWith5++izipWith6 :: (Int -> a -> b -> c -> d -> e -> f -> g)+          -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+          -> Vector f -> Vector g+{-# INLINE izipWith6 #-}+izipWith6 = G.izipWith6++-- | Elementwise pairing of array elements.+zip :: Vector a -> Vector b -> Vector (a, b)+{-# INLINE zip #-}+zip = G.zip++-- | zip together three vectors into a vector of triples+zip3 :: Vector a -> Vector b -> Vector c -> Vector (a, b, c)+{-# INLINE zip3 #-}+zip3 = G.zip3++zip4 :: Vector a -> Vector b -> Vector c -> Vector d+     -> Vector (a, b, c, d)+{-# INLINE zip4 #-}+zip4 = G.zip4++zip5 :: Vector a -> Vector b -> Vector c -> Vector d -> Vector e+     -> Vector (a, b, c, d, e)+{-# INLINE zip5 #-}+zip5 = G.zip5++zip6 :: Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector f+     -> Vector (a, b, c, d, e, f)+{-# INLINE zip6 #-}+zip6 = G.zip6++-- Unzipping+-- ---------++-- | /O(min(m,n))/ Unzip a vector of pairs.+unzip :: Vector (a, b) -> (Vector a, Vector b)+{-# INLINE unzip #-}+unzip = G.unzip++unzip3 :: Vector (a, b, c) -> (Vector a, Vector b, Vector c)+{-# INLINE unzip3 #-}+unzip3 = G.unzip3++unzip4 :: Vector (a, b, c, d) -> (Vector a, Vector b, Vector c, Vector d)+{-# INLINE unzip4 #-}+unzip4 = G.unzip4++unzip5 :: Vector (a, b, c, d, e)+       -> (Vector a, Vector b, Vector c, Vector d, Vector e)+{-# INLINE unzip5 #-}+unzip5 = G.unzip5++unzip6 :: Vector (a, b, c, d, e, f)+       -> (Vector a, Vector b, Vector c, Vector d, Vector e, Vector f)+{-# INLINE unzip6 #-}+unzip6 = G.unzip6++-- Monadic zipping+-- ---------------++-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a+-- vector of results+zipWithM :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)+{-# INLINE zipWithM #-}+zipWithM = G.zipWithM++-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes+-- the element index and yield a vector of results+izipWithM :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)+{-# INLINE izipWithM #-}+izipWithM = G.izipWithM++-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the+-- results+zipWithM_ :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m ()+{-# INLINE zipWithM_ #-}+zipWithM_ = G.zipWithM_++-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes+-- the element index and ignore the results+izipWithM_ :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m ()+{-# INLINE izipWithM_ #-}+izipWithM_ = G.izipWithM_++-- Filtering+-- ---------++-- | /O(n)/ Drop elements that do not satisfy the predicate+filter :: (a -> Bool) -> Vector a -> Vector a+{-# INLINE filter #-}+filter = G.filter++-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to+-- values and their indices+ifilter :: (Int -> a -> Bool) -> Vector a -> Vector a+{-# INLINE ifilter #-}+ifilter = G.ifilter++-- | /O(n)/ Drop repeated adjacent elements.+uniq :: (Eq a) => Vector a -> Vector a+{-# INLINE uniq #-}+uniq = G.uniq++-- | /O(n)/ Drop elements when predicate returns Nothing+mapMaybe :: (a -> Maybe b) -> Vector a -> Vector b+{-# INLINE mapMaybe #-}+mapMaybe = G.mapMaybe++-- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing+imapMaybe :: (Int -> a -> Maybe b) -> Vector a -> Vector b+{-# INLINE imapMaybe #-}+imapMaybe = G.imapMaybe++-- | /O(n)/ Return a Vector of all the `Just` values.+--+-- @since 0.12.2.0+catMaybes :: Vector (Maybe a) -> Vector a+{-# INLINE catMaybes #-}+catMaybes = mapMaybe id++-- | /O(n)/ Drop elements that do not satisfy the monadic predicate+filterM :: Monad m => (a -> m Bool) -> Vector a -> m (Vector a)+{-# INLINE filterM #-}+filterM = G.filterM++-- | /O(n)/ Apply monadic function to each element of vector and+-- discard elements returning Nothing.+--+-- @since 0.12.2.0+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Vector a -> m (Vector b)+{-# INLINE mapMaybeM #-}+mapMaybeM = G.mapMaybeM++-- | /O(n)/ Apply monadic function to each element of vector and its index.+-- Discards elements returning Nothing.+--+-- @since 0.12.2.0+imapMaybeM :: Monad m => (Int -> a -> m (Maybe b)) -> Vector a -> m (Vector b)+{-# INLINE imapMaybeM #-}+imapMaybeM = G.imapMaybeM++-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate.+-- Current implementation is not copy-free, unless the result vector is+-- fused away.+takeWhile :: (a -> Bool) -> Vector a -> Vector a+{-# INLINE takeWhile #-}+takeWhile = G.takeWhile++-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate+-- without copying.+dropWhile :: (a -> Bool) -> Vector a -> Vector a+{-# INLINE dropWhile #-}+dropWhile = G.dropWhile++-- Parititioning+-- -------------++-- | /O(n)/ Split the vector in two parts, the first one containing those+-- elements that satisfy the predicate and the second one those that don't. The+-- relative order of the elements is preserved at the cost of a sometimes+-- reduced performance compared to 'unstablePartition'.+partition :: (a -> Bool) -> Vector a -> (Vector a, Vector a)+{-# INLINE partition #-}+partition = G.partition++-- | /O(n)/ Split the vector in two parts, the first one containing those+-- elements that satisfy the predicate and the second one those that don't.+-- The order of the elements is not preserved but the operation is often+-- faster than 'partition'.+unstablePartition :: (a -> Bool) -> Vector a -> (Vector a, Vector a)+{-# INLINE unstablePartition #-}+unstablePartition = G.unstablePartition++-- | /O(n)/ Split the vector into two parts, the first one containing the+-- @`Left`@ elements and the second containing the @`Right`@ elements.+-- The relative order of the elements is preserved.+--+-- @since 0.12.1.0+partitionWith :: (a -> Either b c) -> Vector a -> (Vector b, Vector c)+{-# INLINE partitionWith #-}+partitionWith = G.partitionWith++-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy+-- the predicate and the rest without copying.+span :: (a -> Bool) -> Vector a -> (Vector a, Vector a)+{-# INLINE span #-}+span = G.span++-- | /O(n)/ Split the vector into the longest prefix of elements that do not+-- satisfy the predicate and the rest without copying.+break :: (a -> Bool) -> Vector a -> (Vector a, Vector a)+{-# INLINE break #-}+break = G.break++-- Searching+-- ---------++infix 4 `elem`+-- | /O(n)/ Check if the vector contains an element+elem :: Eq a => a -> Vector a -> Bool+{-# INLINE elem #-}+elem = G.elem++infix 4 `notElem`+-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem')+notElem :: Eq a => a -> Vector a -> Bool+{-# INLINE notElem #-}+notElem = G.notElem++-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing'+-- if no such element exists.+find :: (a -> Bool) -> Vector a -> Maybe a+{-# INLINE find #-}+find = G.find++-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate+-- or 'Nothing' if no such element exists.+findIndex :: (a -> Bool) -> Vector a -> Maybe Int+{-# INLINE findIndex #-}+findIndex = G.findIndex++-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending+-- order.+findIndices :: (a -> Bool) -> Vector a -> Vector Int+{-# INLINE findIndices #-}+findIndices = G.findIndices++-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or+-- 'Nothing' if the vector does not contain the element. This is a specialised+-- version of 'findIndex'.+elemIndex :: Eq a => a -> Vector a -> Maybe Int+{-# INLINE elemIndex #-}+elemIndex = G.elemIndex++-- | /O(n)/ Yield the indices of all occurences of the given element in+-- ascending order. This is a specialised version of 'findIndices'.+elemIndices :: Eq a => a -> Vector a -> Vector Int+{-# INLINE elemIndices #-}+elemIndices = G.elemIndices++-- Folding+-- -------++-- | /O(n)/ Left fold+foldl :: (a -> b -> a) -> a -> Vector b -> a+{-# INLINE foldl #-}+foldl = G.foldl++-- | /O(n)/ Left fold on non-empty vectors+foldl1 :: (a -> a -> a) -> Vector a -> a+{-# INLINE foldl1 #-}+foldl1 = G.foldl1++-- | /O(n)/ Left fold with strict accumulator+foldl' :: (a -> b -> a) -> a -> Vector b -> a+{-# INLINE foldl' #-}+foldl' = G.foldl'++-- | /O(n)/ Left fold on non-empty vectors with strict accumulator+foldl1' :: (a -> a -> a) -> Vector a -> a+{-# INLINE foldl1' #-}+foldl1' = G.foldl1'++-- | /O(n)/ Right fold+foldr :: (a -> b -> b) -> b -> Vector a -> b+{-# INLINE foldr #-}+foldr = G.foldr++-- | /O(n)/ Right fold on non-empty vectors+foldr1 :: (a -> a -> a) -> Vector a -> a+{-# INLINE foldr1 #-}+foldr1 = G.foldr1++-- | /O(n)/ Right fold with a strict accumulator+foldr' :: (a -> b -> b) -> b -> Vector a -> b+{-# INLINE foldr' #-}+foldr' = G.foldr'++-- | /O(n)/ Right fold on non-empty vectors with strict accumulator+foldr1' :: (a -> a -> a) -> Vector a -> a+{-# INLINE foldr1' #-}+foldr1' = G.foldr1'++-- | /O(n)/ Left fold (function applied to each element and its index)+ifoldl :: (a -> Int -> b -> a) -> a -> Vector b -> a+{-# INLINE ifoldl #-}+ifoldl = G.ifoldl++-- | /O(n)/ Left fold with strict accumulator (function applied to each element+-- and its index)+ifoldl' :: (a -> Int -> b -> a) -> a -> Vector b -> a+{-# INLINE ifoldl' #-}+ifoldl' = G.ifoldl'++-- | /O(n)/ Right fold (function applied to each element and its index)+ifoldr :: (Int -> a -> b -> b) -> b -> Vector a -> b+{-# INLINE ifoldr #-}+ifoldr = G.ifoldr++-- | /O(n)/ Right fold with strict accumulator (function applied to each+-- element and its index)+ifoldr' :: (Int -> a -> b -> b) -> b -> Vector a -> b+{-# INLINE ifoldr' #-}+ifoldr' = G.ifoldr'++-- | /O(n)/ Map each element of the structure to a monoid, and combine+-- the results. It uses same implementation as corresponding method of+-- 'Foldable' type cless. Note it's implemented in terms of 'foldr'+-- and won't fuse with functions that traverse vector from left to+-- right ('map', 'generate', etc.).+--+-- @since 0.12.2.0+foldMap :: (Monoid m) => (a -> m) -> Vector a -> m+{-# INLINE foldMap #-}+foldMap = G.foldMap++-- | /O(n)/ 'foldMap' which is strict in accumulator. It uses same+-- implementation as corresponding method of 'Foldable' type class.+-- Note it's implemented in terms of 'foldl'' so it fuses in most+-- contexts.+--+-- @since 0.12.2.0+foldMap' :: (Monoid m) => (a -> m) -> Vector a -> m+{-# INLINE foldMap' #-}+foldMap' = G.foldMap'+++-- Specialised folds+-- -----------------++-- | /O(n)/ Check if all elements satisfy the predicate.+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.all even $ V.fromList [2, 4, 12 :: Int]+-- True+-- >>> V.all even $ V.fromList [2, 4, 13 :: Int]+-- False+-- >>> V.all even (V.empty :: V.Vector Int)+-- True+all :: (a -> Bool) -> Vector a -> Bool+{-# INLINE all #-}+all = G.all++-- | /O(n)/ Check if any element satisfies the predicate.+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.any even $ V.fromList [1, 3, 7 :: Int]+-- False+-- >>> V.any even $ V.fromList [3, 2, 13 :: Int]+-- True+-- >>> V.any even (V.empty :: V.Vector Int)+-- False+any :: (a -> Bool) -> Vector a -> Bool+{-# INLINE any #-}+any = G.any++-- | /O(n)/ Check if all elements are 'True'+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.and $ V.fromList [True, False]+-- False+-- >>> V.and V.empty+-- True+and :: Vector Bool -> Bool+{-# INLINE and #-}+and = G.and++-- | /O(n)/ Check if any element is 'True'+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.or $ V.fromList [True, False]+-- True+-- >>> V.or V.empty+-- False+or :: Vector Bool -> Bool+{-# INLINE or #-}+or = G.or++-- | /O(n)/ Compute the sum of the elements+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.sum $ V.fromList [300,20,1 :: Int]+-- 321+-- >>> V.sum (V.empty :: V.Vector Int)+-- 0+sum :: Num a => Vector a -> a+{-# INLINE sum #-}+sum = G.sum++-- | /O(n)/ Compute the produce of the elements+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.product $ V.fromList [1,2,3,4 :: Int]+-- 24+-- >>> V.product (V.empty :: V.Vector Int)+-- 1+product :: Num a => Vector a -> a+{-# INLINE product #-}+product = G.product++-- | /O(n)/ Yield the maximum element of the vector. The vector may not be+-- empty.+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.maximum $ V.fromList [2.0, 1.0]+-- 2.0+maximum :: Ord a => Vector a -> a+{-# INLINE maximum #-}+maximum = G.maximum++-- | /O(n)/ Yield the maximum element of the vector according to the given+-- comparison function. The vector may not be empty.+maximumBy :: (a -> a -> Ordering) -> Vector a -> a+{-# INLINE maximumBy #-}+maximumBy = G.maximumBy++-- | /O(n)/ Yield the minimum element of the vector. The vector may not be+-- empty.+--+-- ==== __Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> V.minimum $ V.fromList [2.0, 1.0]+-- 1.0+minimum :: Ord a => Vector a -> a+{-# INLINE minimum #-}+minimum = G.minimum++-- | /O(n)/ Yield the minimum element of the vector according to the given+-- comparison function. The vector may not be empty.+minimumBy :: (a -> a -> Ordering) -> Vector a -> a+{-# INLINE minimumBy #-}+minimumBy = G.minimumBy++-- | /O(n)/ Yield the index of the maximum element of the vector. The vector+-- may not be empty.+maxIndex :: Ord a => Vector a -> Int+{-# INLINE maxIndex #-}+maxIndex = G.maxIndex++-- | /O(n)/ Yield the index of the maximum element of the vector according to+-- the given comparison function. The vector may not be empty.+maxIndexBy :: (a -> a -> Ordering) -> Vector a -> Int+{-# INLINE maxIndexBy #-}+maxIndexBy = G.maxIndexBy++-- | /O(n)/ Yield the index of the minimum element of the vector. The vector+-- may not be empty.+minIndex :: Ord a => Vector a -> Int+{-# INLINE minIndex #-}+minIndex = G.minIndex++-- | /O(n)/ Yield the index of the minimum element of the vector according to+-- the given comparison function. The vector may not be empty.+minIndexBy :: (a -> a -> Ordering) -> Vector a -> Int+{-# INLINE minIndexBy #-}+minIndexBy = G.minIndexBy++-- Monadic folds+-- -------------++-- | /O(n)/ Monadic fold+foldM :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a+{-# INLINE foldM #-}+foldM = G.foldM++-- | /O(n)/ Monadic fold (action applied to each element and its index)+ifoldM :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a+{-# INLINE ifoldM #-}+ifoldM = G.ifoldM++-- | /O(n)/ Monadic fold over non-empty vectors+fold1M :: Monad m => (a -> a -> m a) -> Vector a -> m a+{-# INLINE fold1M #-}+fold1M = G.fold1M++-- | /O(n)/ Monadic fold with strict accumulator+foldM' :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a+{-# INLINE foldM' #-}+foldM' = G.foldM'++-- | /O(n)/ Monadic fold with strict accumulator (action applied to each+-- element and its index)+ifoldM' :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a+{-# INLINE ifoldM' #-}+ifoldM' = G.ifoldM'++-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator+fold1M' :: Monad m => (a -> a -> m a) -> Vector a -> m a+{-# INLINE fold1M' #-}+fold1M' = G.fold1M'++-- | /O(n)/ Monadic fold that discards the result+foldM_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m ()+{-# INLINE foldM_ #-}+foldM_ = G.foldM_++-- | /O(n)/ Monadic fold that discards the result (action applied to each+-- element and its index)+ifoldM_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m ()+{-# INLINE ifoldM_ #-}+ifoldM_ = G.ifoldM_++-- | /O(n)/ Monadic fold over non-empty vectors that discards the result+fold1M_ :: Monad m => (a -> a -> m a) -> Vector a -> m ()+{-# INLINE fold1M_ #-}+fold1M_ = G.fold1M_++-- | /O(n)/ Monadic fold with strict accumulator that discards the result+foldM'_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m ()+{-# INLINE foldM'_ #-}+foldM'_ = G.foldM'_++-- | /O(n)/ Monadic fold with strict accumulator that discards the result+-- (action applied to each element and its index)+ifoldM'_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m ()+{-# INLINE ifoldM'_ #-}+ifoldM'_ = G.ifoldM'_++-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator+-- that discards the result+fold1M'_ :: Monad m => (a -> a -> m a) -> Vector a -> m ()+{-# INLINE fold1M'_ #-}+fold1M'_ = G.fold1M'_++-- Monadic sequencing+-- ------------------++-- | Evaluate each action and collect the results+sequence :: Monad m => Vector (m a) -> m (Vector a)+{-# INLINE sequence #-}+sequence = G.sequence++-- | Evaluate each action and discard the results+sequence_ :: Monad m => Vector (m a) -> m ()+{-# INLINE sequence_ #-}+sequence_ = G.sequence_++-- Prefix sums (scans)+-- -------------------++-- | /O(n)/ Prescan+--+-- @+-- prescanl f z = 'init' . 'scanl' f z+-- @+--+-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@+--+prescanl :: (a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE prescanl #-}+prescanl = G.prescanl++-- | /O(n)/ Prescan with strict accumulator+prescanl' :: (a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE prescanl' #-}+prescanl' = G.prescanl'++-- | /O(n)/ Scan+--+-- @+-- postscanl f z = 'tail' . 'scanl' f z+-- @+--+-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@+--+postscanl :: (a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE postscanl #-}+postscanl = G.postscanl++-- | /O(n)/ Scan with strict accumulator+postscanl' :: (a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE postscanl' #-}+postscanl' = G.postscanl'++-- | /O(n)/ Haskell-style scan+--+-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)>+-- >   where y1 = z+-- >         yi = f y(i-1) x(i-1)+--+-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@+--+scanl :: (a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE scanl #-}+scanl = G.scanl++-- | /O(n)/ Haskell-style scan with strict accumulator+scanl' :: (a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE scanl' #-}+scanl' = G.scanl'++-- | /O(n)/ Scan over a vector with its index+--+-- @since 0.12.0.0+iscanl :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE iscanl #-}+iscanl = G.iscanl++-- | /O(n)/ Scan over a vector (strictly) with its index+--+-- @since 0.12.0.0+iscanl' :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a+{-# INLINE iscanl' #-}+iscanl' = G.iscanl'++-- | /O(n)/ Scan over a non-empty vector+--+-- > scanl f <x1,...,xn> = <y1,...,yn>+-- >   where y1 = x1+-- >         yi = f y(i-1) xi+--+scanl1 :: (a -> a -> a) -> Vector a -> Vector a+{-# INLINE scanl1 #-}+scanl1 = G.scanl1++-- | /O(n)/ Scan over a non-empty vector with a strict accumulator+scanl1' :: (a -> a -> a) -> Vector a -> Vector a+{-# INLINE scanl1' #-}+scanl1' = G.scanl1'++-- | /O(n)/ Right-to-left prescan+--+-- @+-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse'+-- @+--+prescanr :: (a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE prescanr #-}+prescanr = G.prescanr++-- | /O(n)/ Right-to-left prescan with strict accumulator+prescanr' :: (a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE prescanr' #-}+prescanr' = G.prescanr'++-- | /O(n)/ Right-to-left scan+postscanr :: (a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE postscanr #-}+postscanr = G.postscanr++-- | /O(n)/ Right-to-left scan with strict accumulator+postscanr' :: (a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE postscanr' #-}+postscanr' = G.postscanr'++-- | /O(n)/ Right-to-left Haskell-style scan+scanr :: (a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE scanr #-}+scanr = G.scanr++-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator+scanr' :: (a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE scanr' #-}+scanr' = G.scanr'++-- | /O(n)/ Right-to-left scan over a vector with its index+--+-- @since 0.12.0.0+iscanr :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE iscanr #-}+iscanr = G.iscanr++-- | /O(n)/ Right-to-left scan over a vector (strictly) with its index+--+-- @since 0.12.0.0+iscanr' :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b+{-# INLINE iscanr' #-}+iscanr' = G.iscanr'++-- | /O(n)/ Right-to-left scan over a non-empty vector+scanr1 :: (a -> a -> a) -> Vector a -> Vector a+{-# INLINE scanr1 #-}+scanr1 = G.scanr1++-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict+-- accumulator+scanr1' :: (a -> a -> a) -> Vector a -> Vector a+{-# INLINE scanr1' #-}+scanr1' = G.scanr1'++-- Comparisons+-- ------------------------++-- | /O(n)/ Check if two vectors are equal using supplied equality+-- predicate.+--+-- @since 0.12.2.0+eqBy :: (a -> b -> Bool) -> Vector a -> Vector b -> Bool+{-# INLINE eqBy #-}+eqBy = G.eqBy++-- | /O(n)/ Compare two vectors using supplied comparison function for+-- vector elements. Comparison works same as for lists.+--+-- > cmpBy compare == compare+--+-- @since 0.12.2.0+cmpBy :: (a -> b -> Ordering) -> Vector a -> Vector b -> Ordering+cmpBy = G.cmpBy++-- Conversions - Lists+-- ------------------------++-- | /O(n)/ Convert a vector to a list+toList :: Vector a -> [a]+{-# INLINE toList #-}+toList = G.toList++-- | /O(n)/ Convert a list to a vector+fromList :: [a] -> Vector a+{-# INLINE fromList #-}+fromList = G.fromList++-- | /O(n)/ Convert the first @n@ elements of a list to a vector+--+-- @+-- fromListN n xs = 'fromList' ('take' n xs)+-- @+fromListN :: Int -> [a] -> Vector a+{-# INLINE fromListN #-}+fromListN = G.fromListN++-- Conversions - Arrays+-- -----------------------------++-- | /O(1)/ Convert an array to a vector.+--+-- @since 0.12.2.0+fromArray :: Array a -> Vector a+{-# INLINE fromArray #-}+fromArray x = Vector 0 (sizeofArray x) x++-- | /O(n)/ Convert a vector to an array.+--+-- @since 0.12.2.0+toArray :: Vector a -> Array a+{-# INLINE toArray #-}+toArray (Vector offset size arr)+  | offset == 0 && size == sizeofArray arr = arr+  | otherwise = cloneArray arr offset size++-- Conversions - Mutable vectors+-- -----------------------------++-- | /O(1)/ Unsafe convert a mutable vector to an immutable one without+-- copying. The mutable vector may not be used after this operation.+unsafeFreeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a)+{-# INLINE unsafeFreeze #-}+unsafeFreeze = G.unsafeFreeze++-- | /O(1)/ Unsafely convert an immutable vector to a mutable one without+-- copying. The immutable vector may not be used after this operation.+unsafeThaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a)+{-# INLINE unsafeThaw #-}+unsafeThaw = G.unsafeThaw++-- | /O(n)/ Yield a mutable copy of the immutable vector.+thaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a)+{-# INLINE thaw #-}+thaw = G.thaw++-- | /O(n)/ Yield an immutable copy of the mutable vector.+freeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a)+{-# INLINE freeze #-}+freeze = G.freeze++-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must+-- have the same length. This is not checked.+unsafeCopy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m ()+{-# INLINE unsafeCopy #-}+unsafeCopy = G.unsafeCopy++-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must+-- have the same length.+copy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m ()+{-# INLINE copy #-}+copy = G.copy
+ src/Data/Strict/Vector/Autogen/Mutable.hs view
@@ -0,0 +1,679 @@+{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeFamilies #-}++-- |+-- Module      : Data.Strict.Vector.Autogen.Mutable+-- Copyright   : (c) Roman Leshchinskiy 2008-2010+-- License     : BSD-style+--+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable+--+-- Mutable boxed vectors.+--++module Data.Strict.Vector.Autogen.Mutable (+  -- * Mutable boxed vectors+  MVector(..), IOVector, STVector,++  -- * Accessors++  -- ** Length information+  length, null,++  -- ** Extracting subvectors+  slice, init, tail, take, drop, splitAt,+  unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop,++  -- ** Overlapping+  overlaps,++  -- * Construction++  -- ** Initialisation+  new, unsafeNew, replicate, replicateM, generate, generateM, clone,++  -- ** Growing+  grow, unsafeGrow,++  -- ** Restricting memory usage+  clear,++  -- * Accessing individual elements+  read, write, modify, modifyM, swap, exchange,+  unsafeRead, unsafeWrite, unsafeModify, unsafeModifyM, unsafeSwap, unsafeExchange,++  -- * Folds+  mapM_, imapM_, forM_, iforM_,+  foldl, foldl', foldM, foldM',+  foldr, foldr', foldrM, foldrM',+  ifoldl, ifoldl', ifoldM, ifoldM',+  ifoldr, ifoldr', ifoldrM, ifoldrM',++  -- * Modifying vectors+  nextPermutation,++  -- ** Filling and copying++  set, copy, move, unsafeCopy, unsafeMove,++  -- ** Arrays+  fromMutableArray, toMutableArray+) where++import           Control.Monad (when, liftM)+import qualified Data.Vector.Generic.Mutable as G+import           Data.Primitive.Array+import           Control.Monad.Primitive++import Prelude hiding ( length, null, replicate, reverse, read,+                        take, drop, splitAt, init, tail, foldr, foldl, mapM_ )++import Data.Typeable ( Typeable )++#include "vector.h"++++-- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@).+data MVector s a = MVector {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !(MutableArray s a)+        deriving ( Typeable )++type IOVector = MVector RealWorld+type STVector s = MVector s++-- NOTE: This seems unsafe, see http://trac.haskell.org/vector/ticket/54+{-+instance NFData a => NFData (MVector s a) where+    rnf (MVector i n arr) = unsafeInlineST $ force i+        where+          force !ix | ix < n    = do x <- readArray arr ix+                                     rnf x `seq` force (ix+1)+                    | otherwise = return ()+-}++instance G.MVector MVector a where+  {-# INLINE basicLength #-}+  basicLength (MVector _ n _) = n++  {-# INLINE basicUnsafeSlice #-}+  basicUnsafeSlice j m (MVector i _ arr) = MVector (i+j) m arr++  {-# INLINE basicOverlaps #-}+  basicOverlaps (MVector i m arr1) (MVector j n arr2)+    = sameMutableArray arr1 arr2+      && (between i j (j+n) || between j i (i+m))+    where+      between x y z = x >= y && x < z++  {-# INLINE basicUnsafeNew #-}+  basicUnsafeNew n+    = do+        arr <- newArray n uninitialised+        return (MVector 0 n arr)++  {-# INLINE basicInitialize #-}+  -- initialization is unnecessary for boxed vectors+  basicInitialize _ = return ()++  {-# INLINE basicUnsafeReplicate #-}+  basicUnsafeReplicate n !x+    = do+        arr <- newArray n x+        return (MVector 0 n arr)++  {-# INLINE basicUnsafeRead #-}+  basicUnsafeRead (MVector i _ arr) j = readArray arr (i+j)++  {-# INLINE basicUnsafeWrite #-}+  basicUnsafeWrite (MVector i _ arr) j !x = writeArray arr (i+j) x++  {-# INLINE basicUnsafeCopy #-}+  basicUnsafeCopy (MVector i n dst) (MVector j _ src)+    = copyMutableArray dst i src j n++  basicUnsafeMove dst@(MVector iDst n arrDst) src@(MVector iSrc _ arrSrc)+    = case n of+        0 -> return ()+        1 -> readArray arrSrc iSrc >>= writeArray arrDst iDst+        2 -> do+               x <- readArray arrSrc iSrc+               y <- readArray arrSrc (iSrc + 1)+               writeArray arrDst iDst x+               writeArray arrDst (iDst + 1) y+        _+          | overlaps dst src+             -> case compare iDst iSrc of+                  LT -> moveBackwards arrDst iDst iSrc n+                  EQ -> return ()+                  GT | (iDst - iSrc) * 2 < n+                        -> moveForwardsLargeOverlap arrDst iDst iSrc n+                     | otherwise+                        -> moveForwardsSmallOverlap arrDst iDst iSrc n+          | otherwise -> G.basicUnsafeCopy dst src++  {-# INLINE basicClear #-}+  basicClear v = G.set v uninitialised++{-# INLINE moveBackwards #-}+moveBackwards :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()+moveBackwards !arr !dstOff !srcOff !len =+  INTERNAL_CHECK(check) "moveBackwards" "not a backwards move" (dstOff < srcOff)+  $ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i)++{-# INLINE moveForwardsSmallOverlap #-}+-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small.+moveForwardsSmallOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()+moveForwardsSmallOverlap !arr !dstOff !srcOff !len =+  INTERNAL_CHECK(check) "moveForwardsSmallOverlap" "not a forward move" (dstOff > srcOff)+  $ do+      tmp <- newArray overlap uninitialised+      loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i+      loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i)+      loopM overlap $ \ i -> readArray tmp i >>= writeArray arr (dstOff + nonOverlap + i)+  where nonOverlap = dstOff - srcOff; overlap = len - nonOverlap++-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large.+moveForwardsLargeOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m ()+moveForwardsLargeOverlap !arr !dstOff !srcOff !len =+  INTERNAL_CHECK(check) "moveForwardsLargeOverlap" "not a forward move" (dstOff > srcOff)+  $ do+      queue <- newArray nonOverlap uninitialised+      loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i+      let mov !i !qTop = when (i < dstOff + len) $ do+            x <- readArray arr i+            y <- readArray queue qTop+            writeArray arr i y+            writeArray queue qTop x+            mov (i+1) (if qTop + 1 >= nonOverlap then 0 else qTop + 1)+      mov dstOff 0+  where nonOverlap = dstOff - srcOff++{-# INLINE loopM #-}+loopM :: Monad m => Int -> (Int -> m a) -> m ()+loopM !n k = let+  go i = when (i < n) (k i >> go (i+1))+  in go 0++uninitialised :: a+uninitialised = error "Data.Strict.Vector.Autogen.Mutable: uninitialised element. If you are trying to compact a vector, use the 'Data.Strict.Vector.Autogen.force' function to remove uninitialised elements from the underlying array."++-- Length information+-- ------------------++-- | Length of the mutable vector.+length :: MVector s a -> Int+{-# INLINE length #-}+length = G.length++-- | Check whether the vector is empty+null :: MVector s a -> Bool+{-# INLINE null #-}+null = G.null++-- Extracting subvectors+-- ---------------------++-- | Yield a part of the mutable vector without copying it. The vector must+-- contain at least @i+n@ elements.+slice :: Int  -- ^ @i@ starting index+      -> Int  -- ^ @n@ length+      -> MVector s a+      -> MVector s a+{-# INLINE slice #-}+slice = G.slice++take :: Int -> MVector s a -> MVector s a+{-# INLINE take #-}+take = G.take++drop :: Int -> MVector s a -> MVector s a+{-# INLINE drop #-}+drop = G.drop++{-# INLINE splitAt #-}+splitAt :: Int -> MVector s a -> (MVector s a, MVector s a)+splitAt = G.splitAt++init :: MVector s a -> MVector s a+{-# INLINE init #-}+init = G.init++tail :: MVector s a -> MVector s a+{-# INLINE tail #-}+tail = G.tail++-- | Yield a part of the mutable vector without copying it. No bounds checks+-- are performed.+unsafeSlice :: Int  -- ^ starting index+            -> Int  -- ^ length of the slice+            -> MVector s a+            -> MVector s a+{-# INLINE unsafeSlice #-}+unsafeSlice = G.unsafeSlice++unsafeTake :: Int -> MVector s a -> MVector s a+{-# INLINE unsafeTake #-}+unsafeTake = G.unsafeTake++unsafeDrop :: Int -> MVector s a -> MVector s a+{-# INLINE unsafeDrop #-}+unsafeDrop = G.unsafeDrop++unsafeInit :: MVector s a -> MVector s a+{-# INLINE unsafeInit #-}+unsafeInit = G.unsafeInit++unsafeTail :: MVector s a -> MVector s a+{-# INLINE unsafeTail #-}+unsafeTail = G.unsafeTail++-- Overlapping+-- -----------++-- | Check whether two vectors overlap.+overlaps :: MVector s a -> MVector s a -> Bool+{-# INLINE overlaps #-}+overlaps = G.overlaps++-- Initialisation+-- --------------++-- | Create a mutable vector of the given length.+new :: PrimMonad m => Int -> m (MVector (PrimState m) a)+{-# INLINE new #-}+new = G.new++-- | Create a mutable vector of the given length. The vector elements+--   are set to bottom so accessing them will cause an exception.+--+-- @since 0.5+unsafeNew :: PrimMonad m => Int -> m (MVector (PrimState m) a)+{-# INLINE unsafeNew #-}+unsafeNew = G.unsafeNew++-- | Create a mutable vector of the given length (0 if the length is negative)+-- and fill it with an initial value.+replicate :: PrimMonad m => Int -> a -> m (MVector (PrimState m) a)+{-# INLINE replicate #-}+replicate = G.replicate++-- | Create a mutable vector of the given length (0 if the length is negative)+-- and fill it with values produced by repeatedly executing the monadic action.+replicateM :: PrimMonad m => Int -> m a -> m (MVector (PrimState m) a)+{-# INLINE replicateM #-}+replicateM = G.replicateM++-- | /O(n)/ Create a mutable vector of the given length (0 if the length is negative)+-- and fill it with the results of applying the function to each index.+--+-- @since 0.12.3.0+generate :: (PrimMonad m) => Int -> (Int -> a) -> m (MVector (PrimState m) a)+{-# INLINE generate #-}+generate = G.generate++-- | /O(n)/ Create a mutable vector of the given length (0 if the length is+-- negative) and fill it with the results of applying the monadic function to each+-- index. Iteration starts at index 0.+--+-- @since 0.12.3.0+generateM :: (PrimMonad m) => Int -> (Int -> m a) -> m (MVector (PrimState m) a)+{-# INLINE generateM #-}+generateM = G.generateM++-- | Create a copy of a mutable vector.+clone :: PrimMonad m => MVector (PrimState m) a -> m (MVector (PrimState m) a)+{-# INLINE clone #-}+clone = G.clone++-- Growing+-- -------++-- | Grow a boxed vector by the given number of elements. The number must be+-- non-negative. Same semantics as in `G.grow` for generic vector. It differs+-- from @grow@ functions for unpacked vectors, however, in that only pointers to+-- values are copied over, therefore values themselves will be shared between+-- two vectors. This is an important distinction to know about during memory+-- usage analysis and in case when values themselves are of a mutable type, eg.+-- `Data.IORef.IORef` or another mutable vector.+--+-- ====__Examples__+--+-- >>> import qualified Data.Strict.Vector.Autogen as V+-- >>> import qualified Data.Strict.Vector.Autogen.Mutable as MV+-- >>> mv <- V.thaw $ V.fromList ([10, 20, 30] :: [Integer])+-- >>> mv' <- MV.grow mv 2+--+-- The two extra elements at the end of the newly allocated vector will be+-- uninitialized and will result in an error if evaluated, so me must overwrite+-- them with new values first:+--+-- >>> MV.write mv' 3 999+-- >>> MV.write mv' 4 777+-- >>> V.unsafeFreeze mv'+-- [10,20,30,999,777]+--+-- It is important to note that the source mutable vector is not affected when+-- the newly allocated one is mutated.+--+-- >>> MV.write mv' 2 888+-- >>> V.unsafeFreeze mv'+-- [10,20,888,999,777]+-- >>> V.unsafeFreeze mv+-- [10,20,30]+--+-- @since 0.5+grow :: PrimMonad m+              => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a)+{-# INLINE grow #-}+grow = G.grow++-- | Grow a vector by the given number of elements. The number must be non-negative but+-- this is not checked. Same semantics as in `G.unsafeGrow` for generic vector.+--+-- @since 0.5+unsafeGrow :: PrimMonad m+               => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a)+{-# INLINE unsafeGrow #-}+unsafeGrow = G.unsafeGrow++-- Restricting memory usage+-- ------------------------++-- | Reset all elements of the vector to some undefined value, clearing all+-- references to external objects. This is usually a noop for unboxed vectors.+clear :: PrimMonad m => MVector (PrimState m) a -> m ()+{-# INLINE clear #-}+clear = G.clear++-- Accessing individual elements+-- -----------------------------++-- | Yield the element at the given position.+read :: PrimMonad m => MVector (PrimState m) a -> Int -> m a+{-# INLINE read #-}+read = G.read++-- | Replace the element at the given position.+write :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m ()+{-# INLINE write #-}+write = G.write++-- | Modify the element at the given position.+modify :: PrimMonad m => MVector (PrimState m) a -> (a -> a) -> Int -> m ()+{-# INLINE modify #-}+modify = G.modify++-- | Modify the element at the given position using a monadic function.+--+-- @since 0.12.3.0+modifyM :: (PrimMonad m) => MVector (PrimState m) a -> (a -> m a) -> Int -> m ()+{-# INLINE modifyM #-}+modifyM = G.modifyM++-- | Swap the elements at the given positions.+swap :: PrimMonad m => MVector (PrimState m) a -> Int -> Int -> m ()+{-# INLINE swap #-}+swap = G.swap++-- | Replace the element at the given position and return the old element.+exchange :: (PrimMonad m) => MVector (PrimState m) a -> Int -> a -> m a+{-# INLINE exchange #-}+exchange = G.exchange++-- | Yield the element at the given position. No bounds checks are performed.+unsafeRead :: PrimMonad m => MVector (PrimState m) a -> Int -> m a+{-# INLINE unsafeRead #-}+unsafeRead = G.unsafeRead++-- | Replace the element at the given position. No bounds checks are performed.+unsafeWrite :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m ()+{-# INLINE unsafeWrite #-}+unsafeWrite = G.unsafeWrite++-- | Modify the element at the given position. No bounds checks are performed.+unsafeModify :: PrimMonad m => MVector (PrimState m) a -> (a -> a) -> Int -> m ()+{-# INLINE unsafeModify #-}+unsafeModify = G.unsafeModify++-- | Modify the element at the given position using a monadic+-- function. No bounds checks are performed.+--+-- @since 0.12.3.0+unsafeModifyM :: (PrimMonad m) => MVector (PrimState m) a -> (a -> m a) -> Int -> m ()+{-# INLINE unsafeModifyM #-}+unsafeModifyM = G.unsafeModifyM++-- | Swap the elements at the given positions. No bounds checks are performed.+unsafeSwap :: PrimMonad m => MVector (PrimState m) a -> Int -> Int -> m ()+{-# INLINE unsafeSwap #-}+unsafeSwap = G.unsafeSwap++-- | Replace the element at the given position and return the old element. No+-- bounds checks are performed.+unsafeExchange :: (PrimMonad m) => MVector (PrimState m) a -> Int -> a -> m a+{-# INLINE unsafeExchange #-}+unsafeExchange = G.unsafeExchange++-- Filling and copying+-- -------------------++-- | Set all elements of the vector to the given value.+set :: PrimMonad m => MVector (PrimState m) a -> a -> m ()+{-# INLINE set #-}+set = G.set++-- | Copy a vector. The two vectors must have the same length and may not+-- overlap.+copy :: PrimMonad m => MVector (PrimState m) a   -- ^ target+                    -> MVector (PrimState m) a   -- ^ source+                    -> m ()+{-# INLINE copy #-}+copy = G.copy++-- | Copy a vector. The two vectors must have the same length and may not+-- overlap. This is not checked.+unsafeCopy :: PrimMonad m => MVector (PrimState m) a   -- ^ target+                          -> MVector (PrimState m) a   -- ^ source+                          -> m ()+{-# INLINE unsafeCopy #-}+unsafeCopy = G.unsafeCopy++-- | Move the contents of a vector. The two vectors must have the same+-- length.+--+-- If the vectors do not overlap, then this is equivalent to 'copy'.+-- Otherwise, the copying is performed as if the source vector were+-- copied to a temporary vector and then the temporary vector was copied+-- to the target vector.+move :: PrimMonad m => MVector (PrimState m) a   -- ^ target+                    -> MVector (PrimState m) a   -- ^ source+                    -> m ()+{-# INLINE move #-}+move = G.move++-- | Move the contents of a vector. The two vectors must have the same+-- length, but this is not checked.+--+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.+-- Otherwise, the copying is performed as if the source vector were+-- copied to a temporary vector and then the temporary vector was copied+-- to the target vector.+unsafeMove :: PrimMonad m => MVector (PrimState m) a   -- ^ target+                          -> MVector (PrimState m) a   -- ^ source+                          -> m ()+{-# INLINE unsafeMove #-}+unsafeMove = G.unsafeMove++-- | Compute the next (lexicographically) permutation of given vector in-place.+--   Returns False when input is the last permutation+nextPermutation :: (PrimMonad m,Ord e) => MVector (PrimState m) e -> m Bool+{-# INLINE nextPermutation #-}+nextPermutation = G.nextPermutation+++-- Folds+-- -----++-- | /O(n)/ Apply the monadic action to every element of the vector, discarding the results.+--+-- @since 0.12.3.0+mapM_ :: (PrimMonad m) => (a -> m b) -> MVector (PrimState m) a -> m ()+{-# INLINE mapM_ #-}+mapM_ = G.mapM_++-- | /O(n)/ Apply the monadic action to every element of the vector and its index, discarding the results.+--+-- @since 0.12.3.0+imapM_ :: (PrimMonad m) => (Int -> a -> m b) -> MVector (PrimState m) a -> m ()+{-# INLINE imapM_ #-}+imapM_ = G.imapM_++-- | /O(n)/ Apply the monadic action to every element of the vector,+-- discarding the results. It's same as the @flip mapM_@.+--+-- @since 0.12.3.0+forM_ :: (PrimMonad m) => MVector (PrimState m) a -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_ = G.forM_++-- | /O(n)/ Apply the monadic action to every element of the vector+-- and its index, discarding the results. It's same as the @flip imapM_@.+--+-- @since 0.12.3.0+iforM_ :: (PrimMonad m) => MVector (PrimState m) a -> (Int -> a -> m b) -> m ()+{-# INLINE iforM_ #-}+iforM_ = G.iforM_++-- | /O(n)/ Pure left fold.+--+-- @since 0.12.3.0+foldl :: (PrimMonad m) => (b -> a -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldl #-}+foldl = G.foldl++-- | /O(n)/ Pure left fold with strict accumulator.+--+-- @since 0.12.3.0+foldl' :: (PrimMonad m) => (b -> a -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldl' #-}+foldl' = G.foldl'++-- | /O(n)/ Pure left fold (function applied to each element and its index).+--+-- @since 0.12.3.0+ifoldl :: (PrimMonad m) => (b -> Int -> a -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldl #-}+ifoldl = G.ifoldl++-- | /O(n)/ Pure left fold with strict accumulator (function applied to each element and its index).+--+-- @since 0.12.3.0+ifoldl' :: (PrimMonad m) => (b -> Int -> a -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldl' #-}+ifoldl' = G.ifoldl'++-- | /O(n)/ Pure right fold.+--+-- @since 0.12.3.0+foldr :: (PrimMonad m) => (a -> b -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldr #-}+foldr = G.foldr++-- | /O(n)/ Pure right fold with strict accumulator.+--+-- @since 0.12.3.0+foldr' :: (PrimMonad m) => (a -> b -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldr' #-}+foldr' = G.foldr'++-- | /O(n)/ Pure right fold (function applied to each element and its index).+--+-- @since 0.12.3.0+ifoldr :: (PrimMonad m) => (Int -> a -> b -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldr #-}+ifoldr = G.ifoldr++-- | /O(n)/ Pure right fold with strict accumulator (function applied+-- to each element and its index).+--+-- @since 0.12.3.0+ifoldr' :: (PrimMonad m) => (Int -> a -> b -> b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldr' #-}+ifoldr' = G.ifoldr'++-- | /O(n)/ Monadic fold.+--+-- @since 0.12.3.0+foldM :: (PrimMonad m) => (b -> a -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldM #-}+foldM = G.foldM++-- | /O(n)/ Monadic fold with strict accumulator.+--+-- @since 0.12.3.0+foldM' :: (PrimMonad m) => (b -> a -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldM' #-}+foldM' = G.foldM'++-- | /O(n)/ Monadic fold (action applied to each element and its index).+--+-- @since 0.12.3.0+ifoldM :: (PrimMonad m) => (b -> Int -> a -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldM #-}+ifoldM = G.ifoldM++-- | /O(n)/ Monadic fold with strict accumulator (action applied to each element and its index).+--+-- @since 0.12.3.0+ifoldM' :: (PrimMonad m) => (b -> Int -> a -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldM' #-}+ifoldM' = G.ifoldM'++-- | /O(n)/ Monadic right fold.+--+-- @since 0.12.3.0+foldrM :: (PrimMonad m) => (a -> b -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldrM #-}+foldrM = G.foldrM++-- | /O(n)/ Monadic right fold with strict accumulator.+--+-- @since 0.12.3.0+foldrM' :: (PrimMonad m) => (a -> b -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE foldrM' #-}+foldrM' = G.foldrM'++-- | /O(n)/ Monadic right fold (action applied to each element and its index).+--+-- @since 0.12.3.0+ifoldrM :: (PrimMonad m) => (Int -> a -> b -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldrM #-}+ifoldrM = G.ifoldrM++-- | /O(n)/ Monadic right fold with strict accumulator (action applied+-- to each element and its index).+--+-- @since 0.12.3.0+ifoldrM' :: (PrimMonad m) => (Int -> a -> b -> m b) -> b -> MVector (PrimState m) a -> m b+{-# INLINE ifoldrM' #-}+ifoldrM' = G.ifoldrM'++-- Conversions - Arrays+-- -----------------------------++-- | /O(n)/ Make a copy of a mutable array to a new mutable vector.+--+-- @since 0.12.2.0+fromMutableArray :: PrimMonad m => MutableArray (PrimState m) a -> m (MVector (PrimState m) a)+{-# INLINE fromMutableArray #-}+fromMutableArray marr =+  let size = sizeofMutableArray marr+   in MVector 0 size `liftM` cloneMutableArray marr 0 size++-- | /O(n)/ Make a copy of a mutable vector into a new mutable array.+--+-- @since 0.12.2.0+toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a)+{-# INLINE toMutableArray #-}+toMutableArray (MVector offset size marr) = cloneMutableArray marr offset size
+ src/Data/Strict/Vector/Internal.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Strict.Vector.Internal where++import Data.Vector                as L+import Data.Strict.Vector.Autogen as S++import Data.Binary+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex+import Data.Semigroup (Semigroup (..)) -- helps with compatibility+import Data.Strict.Classes+import Data.Vector.Binary++instance Strict (L.Vector k) (S.Vector k) where+  toStrict = S.fromList . L.toList+  toLazy = L.fromList . S.toList+  {-# INLINE toStrict #-}+  {-# INLINE toLazy #-}++-- code copied from indexed-traversable-instances++instance FunctorWithIndex Int S.Vector where+  imap = S.imap+  {-# INLINE imap #-}++instance FoldableWithIndex Int S.Vector where+  ifoldr = S.ifoldr+  {-# INLINE ifoldr #-}+  ifoldl = S.ifoldl . flip+  {-# INLINE ifoldl #-}+  ifoldr' = S.ifoldr'+  {-# INLINE ifoldr' #-}+  ifoldl' = S.ifoldl' . flip+  {-# INLINE ifoldl' #-}++instance TraversableWithIndex Int S.Vector where+  itraverse f v =+    let !n = S.length v in S.fromListN n <$> itraverse f (S.toList v)+  {-# INLINE itraverse #-}++-- code copied from vector-binary-instances++instance Binary a => Binary (S.Vector a) where+    put = genericPutVector+    get = genericGetVector+    {-# INLINE get #-}
+ strict-containers.cabal view
@@ -0,0 +1,333 @@+Name:           strict-containers+Version:        0.1+Synopsis:       Strict containers.+Category:       Data, Data Structures+Description:+  This package provides strict versions of some standard Haskell containers -+  including 'HashMap', 'IntMap', 'Map', 'Sequence', and 'Vector'.+  .+  The reasoning is the same as that for our @strict@ package - though some+  containers already define strict /operations/ that force their inputs, the+  underlying data type is shared between the lazy and strict variants, i.e. by+  default lazy. In particular, instances are defined lazily on the common type,+  meaning that external utilities such as @lens@, @optics@, and deserialisation+  instances e.g. for @binary@ and @serialise@, all work lazily and there is not+  even the option to go strict.+  .+  This package defines separate data types, to avoid these problems. Instances+  can then be defined on these fully-strict data types.+  .+  To be clear, the "strict" vs "lazy" discussion refers to the values of a map+  or the elements of a sequence. The standard variants of these data structures+  that can be lazy-or-strict are already always-strict in their keys (for maps)+  and lengths (for sequences) respectively. This is also why we don't define+  strict variants of sets here, since the standard variants are already strict+  in their elements.+  .+  Note: generally, instances for strict containers violate their respective+  laws in the presence of bottom (undefined, error, infinite-loop). In the+  absence of bottom, laws are preserved.+  .+  This library mirrors the API of the standard lazy-or-strict variants in+  @containers@ and @unordered-containers@, including methods and fundamental+  instances. It also contains instances for @binary@ and @indexed-traversable@.+  More instances are defined in other packages, e.g. @strict-containers-lens@+  and @strict-containers-serialise@.+  .+  The current version of this library has been autogenerated from:+  .+-- generated list for versions+-- DO NOT EDIT below, AUTOGEN versions+  * containers v0.6.4.1+  * unordered-containers v0.2.13.0+  * vector v0.12.3.0+-- DO NOT EDIT above, AUTOGEN versions+License:        BSD3+License-File:   LICENSE+Maintainer:     Ximin Luo <infinity0@pwned.gg>+Copyright:      (c) 2021 by Ximin Luo+Homepage:       https://github.com/haskellari/strict-containers+Cabal-Version: >= 1.10+Build-type:     Simple+extra-source-files:+    CHANGELOG.md+    -- generated list for includes+    -- DO NOT EDIT below, AUTOGEN includes+    include/containers.h+    -- DO NOT EDIT above, AUTOGEN includes+tested-with:+  GHC ==8.2.2+   || ==8.4.4+   || ==8.6.5+   || ==8.8.3+   || ==8.10.4+   || ==9.0.1++library+  default-language: Haskell2010+  hs-source-dirs:   src+  ghc-options:      -Wall++  build-depends:+      base                  >= 4.5.0.0  && < 5+    , array                 >= 0.4.0.0+    , binary                >= 0.8.4.1  && < 0.9+    , containers            >= 0.5.9.2  && < 0.7+    , deepseq               >= 1.2      && < 1.5+    , indexed-traversable   >= 0.1.1    && < 0.2+    , hashable              >= 1.2.7.0  && < 1.4+    , primitive             >= 0.6.4.0  && < 0.8+    , unordered-containers  >= 0.2      && < 0.3+    , strict                >= 0.4      && < 0.5+    , vector                >= 0.12     && < 0.13+    , vector-binary-instances >= 0.2    && < 0.3++  exposed-modules:+    Data.Strict.HashMap+    Data.Strict.HashMap.Internal+    -- generated list for HashMap+    -- DO NOT EDIT below, AUTOGEN HashMap+    Data.Strict.HashMap.Autogen.Strict+    Data.Strict.HashMap.Autogen.Internal+    Data.Strict.HashMap.Autogen.Internal.Array+    Data.Strict.HashMap.Autogen.Internal.Strict+    Data.Strict.HashMap.Autogen.Internal.List+    Data.Strict.HashMap.Autogen.Internal.Unsafe+    -- DO NOT EDIT above, AUTOGEN HashMap+    Data.Strict.HashSet+    Data.Strict.IntMap+    Data.Strict.IntMap.Internal+    -- generated list for IntMap+    -- DO NOT EDIT below, AUTOGEN IntMap+    Data.Strict.IntMap.Autogen.Strict+    Data.Strict.IntMap.Autogen.Internal+    Data.Strict.IntMap.Autogen.Merge.Strict+    Data.Strict.IntMap.Autogen.Strict.Internal+    Data.Strict.IntMap.Autogen.Internal.Debug+    Data.Strict.IntMap.Autogen.Internal.DeprecatedDebug+    -- DO NOT EDIT above, AUTOGEN IntMap+    Data.Strict.IntSet+    Data.Strict.Map+    Data.Strict.Map.Internal+    -- generated list for Map+    -- DO NOT EDIT below, AUTOGEN Map+    Data.Strict.Map.Autogen.Strict+    Data.Strict.Map.Autogen.Internal+    Data.Strict.Map.Autogen.Merge.Strict+    Data.Strict.Map.Autogen.Strict.Internal+    Data.Strict.Map.Autogen.Internal.Debug+    Data.Strict.Map.Autogen.Internal.DeprecatedShowTree+    -- DO NOT EDIT above, AUTOGEN Map+    Data.Strict.Sequence+    Data.Strict.Sequence.Internal+    -- generated list for Sequence+    -- DO NOT EDIT below, AUTOGEN Sequence+    Data.Strict.Sequence.Autogen+    Data.Strict.Sequence.Autogen.Internal+    Data.Strict.Sequence.Autogen.Internal.Sorting+    -- DO NOT EDIT above, AUTOGEN Sequence+    Data.Strict.Set+    -- generated list for ContainersUtils+    -- DO NOT EDIT below, AUTOGEN ContainersUtils+    Data.Strict.ContainersUtils.Autogen.Coercions+    Data.Strict.ContainersUtils.Autogen.BitUtil+    Data.Strict.ContainersUtils.Autogen.StrictPair+    Data.Strict.ContainersUtils.Autogen.StrictMaybe+    Data.Strict.ContainersUtils.Autogen.PtrEquality+    Data.Strict.ContainersUtils.Autogen.State+    Data.Strict.ContainersUtils.Autogen.BitQueue+    Data.Strict.ContainersUtils.Autogen.TypeError+    -- DO NOT EDIT above, AUTOGEN ContainersUtils+    Data.Strict.Vector+    Data.Strict.Vector.Internal+    -- generated list for Vector+    -- DO NOT EDIT below, AUTOGEN Vector+    Data.Strict.Vector.Autogen+    Data.Strict.Vector.Autogen.Mutable+    -- DO NOT EDIT above, AUTOGEN Vector++  include-dirs: include++-- generated list for tests+-- DO NOT EDIT below, AUTOGEN tests+test-suite map-strict-properties+  default-language: Haskell2010+  hs-source-dirs:   tests+  main-is:          map-properties.hs+  type:             exitcode-stdio-1.0+  build-depends:    containers, strict-containers+  build-depends:+      array    >=0.4.0.0+    , base     >=4.6     && <5+    , deepseq  >=1.2     && <1.5++  cpp-options:      -DSTRICT+  ghc-options:      -O2+  other-extensions:+    BangPatterns+    CPP++  build-depends:+      HUnit+    , QuickCheck                  >=2.7.1+    , test-framework+    , test-framework-hunit+    , test-framework-quickcheck2+    , transformers++test-suite map-strictness-properties+  default-language: Haskell2010+  hs-source-dirs:   tests+  main-is:          map-strictness.hs+  type:             exitcode-stdio-1.0+  build-depends:    containers, strict-containers+  build-depends:+      array                       >=0.4.0.0+    , base                        >=4.6     && <5+    , ChasingBottoms+    , deepseq                     >=1.2     && <1.5+    , HUnit+    , QuickCheck                  >=2.7.1+    , test-framework              >=0.3.3+    , test-framework-quickcheck2  >=0.2.9+    , test-framework-hunit++  ghc-options:      -Wall+  other-extensions:+    BangPatterns+    CPP++  other-modules:+    Utils.IsUnit++test-suite intmap-strict-properties+  default-language: Haskell2010+  hs-source-dirs:   tests+  main-is:          intmap-properties.hs+  type:             exitcode-stdio-1.0+  cpp-options:      -DSTRICT+  other-modules:    IntMapValidity+  build-depends:    strict-containers+  build-depends:+      array    >=0.4.0.0+    , base     >=4.6     && <5+    , deepseq  >=1.2     && <1.5++  ghc-options:      -O2+  other-extensions:+    BangPatterns+    CPP++  build-depends:    containers, strict-containers+  build-depends:+      HUnit+    , QuickCheck                  >=2.7.1+    , test-framework+    , test-framework-hunit+    , test-framework-quickcheck2++test-suite intmap-strictness-properties+  default-language: Haskell2010+  hs-source-dirs:   tests+  main-is:          intmap-strictness.hs+  type:             exitcode-stdio-1.0+  other-extensions:+    BangPatterns+    CPP++  build-depends:    containers, strict-containers+  build-depends:+      array                       >=0.4.0.0+    , base                        >=4.6     && <5+    , ChasingBottoms+    , deepseq                     >=1.2     && <1.5+    , HUnit+    , QuickCheck                  >=2.7.1+    , test-framework              >=0.3.3+    , test-framework-quickcheck2  >=0.2.9+    , test-framework-hunit++  ghc-options:      -Wall++  other-modules:+    Utils.IsUnit++test-suite seq-properties+  default-language: Haskell2010+  hs-source-dirs:   tests+  main-is:          seq-properties.hs+  type:             exitcode-stdio-1.0+  build-depends:    strict-containers+  build-depends:+      array    >=0.4.0.0+    , base     >=4.6     && <5+    , deepseq  >=1.2     && <1.5++  ghc-options:      -O2+  other-extensions:+    BangPatterns+    CPP++  build-depends:+      QuickCheck                  >=2.7.1+    , test-framework+    , test-framework-quickcheck2+    , transformers++test-suite hashmap-strict-properties+  hs-source-dirs: tests+  main-is: HashMapProperties.hs+  type: exitcode-stdio-1.0++  build-depends:+    base,+    containers >= 0.5.8,+    hashable >= 1.0.1.1,+    QuickCheck >= 2.4.0.1,+    test-framework >= 0.3.3,+    test-framework-quickcheck2 >= 0.2.9,+    strict-containers,+    unordered-containers++  default-language: Haskell2010+  ghc-options: -Wall+  cpp-options: -DASSERTS -DSTRICT++test-suite vector-tests-O0+  Default-Language: Haskell2010+  type: exitcode-stdio-1.0+  Main-Is:  VectorMain.hs++  other-modules: Boilerplater+                 Tests.Bundle+                 Tests.Move+                 Tests.Vector+                 Tests.Vector.Property+                 Tests.Vector.Boxed+                 Tests.Vector.UnitTests+                 Utilities++  hs-source-dirs: tests+  Build-Depends: base >= 4.5 && < 5, template-haskell, base-orphans >= 0.6, vector, strict-containers,+                 primitive, random,+                 QuickCheck >= 2.9 && < 2.15, HUnit, tasty,+                 tasty-hunit, tasty-quickcheck,+                 transformers >= 0.2.0.0+  if !impl(ghc > 8.0)+    Build-Depends: semigroups++  default-extensions: CPP,+              ScopedTypeVariables,+              PatternGuards,+              MultiParamTypeClasses,+              FlexibleContexts,+              Rank2Types,+              TypeSynonymInstances,+              TypeFamilies,+              TemplateHaskell++  Ghc-Options: -O0 -threaded+  Ghc-Options: -Wall+++-- DO NOT EDIT above, AUTOGEN tests
+ tests/Boilerplater.hs view
@@ -0,0 +1,27 @@+module Boilerplater where++import Test.Tasty.QuickCheck++import Language.Haskell.TH+++testProperties :: [Name] -> Q Exp+testProperties nms = fmap ListE $ sequence [[| testProperty $(stringE prop_name) $(varE nm) |]+                                           | nm <- nms+                                           , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]]++-- This nice clean solution doesn't quite work since I need to use lexically-scoped type+-- variables, which aren't supported by Template Haskell. Argh!+-- testProperties :: Q [Dec] -> Q Exp+-- testProperties mdecs = do+--     decs <- mdecs+--     property_exprs <- sequence [[| testProperty "$prop_name" $(return $ VarE nm) |]+--                                | FunD nm _clauses <- decs+--                                , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]]+--     return $ LetE decs (ListE property_exprs)++stripPrefix_maybe :: String -> String -> Maybe String+stripPrefix_maybe prefix what+  | what_start == prefix = Just what_end+  | otherwise            = Nothing+  where (what_start, what_end) = splitAt (length prefix) what
+ tests/HashMapProperties.hs view
@@ -0,0 +1,591 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)++-- | Tests for the 'Data.Strict.HashMap.Autogen.Lazy' module.  We test functions by+-- comparing them to a simpler model, an association list.++module Main (main) where++import Control.Monad ( guard )+import qualified Data.Foldable as Foldable+#if MIN_VERSION_base(4,10,0)+import Data.Bifoldable+#endif+import Data.Function (on)+import Data.Hashable (Hashable(hashWithSalt))+import qualified Data.List as L+import Data.Ord (comparing)+#if defined(STRICT)+import Data.Strict.HashMap.Autogen.Strict (HashMap)+import qualified Data.Strict.HashMap.Autogen.Strict as HM+import qualified Data.Map.Strict as M+#else+import Data.Strict.HashMap.Autogen.Lazy (HashMap)+import qualified Data.Strict.HashMap.Autogen.Lazy as HM+import qualified Data.Map.Lazy as M+#endif+import Test.QuickCheck (Arbitrary(..), Property, (==>), (===), forAll, elements)+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity (..))+#endif+import Control.Applicative (Const (..))+import Test.QuickCheck.Function (Fun, apply)+import Test.QuickCheck.Poly (A, B)++-- Key type that generates more hash collisions.+newtype Key = K { unK :: Int }+            deriving (Arbitrary, Eq, Ord, Read, Show)++instance Hashable Key where+    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20++instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+  arbitrary = fmap (HM.fromList) arbitrary++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Instances++pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==)++pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=)++-- We cannot compare to `Data.Map` as ordering is different.+pOrd1 :: [(Key, Int)] -> Bool+pOrd1 xs = compare x x == EQ+  where+    x = HM.fromList xs++pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool+pOrd2 xs ys zs = case (compare x y, compare y z) of+    (EQ, o)  -> compare x z == o+    (o,  EQ) -> compare x z == o+    (LT, LT) -> compare x z == LT+    (GT, GT) -> compare x z == GT+    (LT, GT) -> True -- ys greater than xs and zs.+    (GT, LT) -> True+  where+    x = HM.fromList xs+    y = HM.fromList ys+    z = HM.fromList zs++pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool+pOrd3 xs ys = case (compare x y, compare y x) of+    (EQ, EQ) -> True+    (LT, GT) -> True+    (GT, LT) -> True+    _        -> False+  where+    x = HM.fromList xs+    y = HM.fromList ys++pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pOrdEq xs ys = case (compare x y, x == y) of+    (EQ, True)  -> True+    (LT, False) -> True+    (GT, False) -> True+    _           -> False+  where+    x = HM.fromList xs+    y = HM.fromList ys++pReadShow :: [(Key, Int)] -> Bool+pReadShow xs = M.fromList xs == read (show (M.fromList xs))++pFunctor :: [(Key, Int)] -> Bool+pFunctor = fmap (+ 1) `eq_` fmap (+ 1)++pFoldable :: [(Int, Int)] -> Bool+pFoldable = (L.sort . Foldable.foldr (:) []) `eq`+            (L.sort . Foldable.foldr (:) [])++pHashable :: [(Key, Int)] -> [Int] -> Int -> Property+pHashable xs is salt =+    x == y ==> hashWithSalt salt x === hashWithSalt salt y+  where+    xs' = L.nubBy (\(k,_) (k',_) -> k == k') xs+    ys = shuffle is xs'+    x = HM.fromList xs'+    y = HM.fromList ys+    -- Shuffle the list using indexes in the second+    shuffle :: [Int] -> [a] -> [a]+    shuffle idxs = L.map snd+                 . L.sortBy (comparing fst)+                 . L.zip (idxs ++ [L.maximum (0:is) + 1 ..])++------------------------------------------------------------------------+-- ** Basic interface++pSize :: [(Key, Int)] -> Bool+pSize = M.size `eq` HM.size++pMember :: Key -> [(Key, Int)] -> Bool+pMember k = M.member k `eq` HM.member k++pLookup :: Key -> [(Key, Int)] -> Bool+pLookup k = M.lookup k `eq` HM.lookup k++pLookupOperator :: Key -> [(Key, Int)] -> Bool+pLookupOperator k = M.lookup k `eq` (HM.!? k)++pInsert :: Key -> Int -> [(Key, Int)] -> Bool+pInsert k v = M.insert k v `eq_` HM.insert k v++pDelete :: Key -> [(Key, Int)] -> Bool+pDelete k = M.delete k `eq_` HM.delete k++newtype AlwaysCollide = AC Int+    deriving (Arbitrary, Eq, Ord, Show)++instance Hashable AlwaysCollide where+    hashWithSalt _ _ = 1++-- White-box test that tests the case of deleting one of two keys from+-- a map, where the keys' hash values collide.+pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int+                 -> Property+pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==>+                                HM.member toKeep $ HM.delete toDelete $+                                HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)]+  where+    which = idx `mod` 3+    toDelete+        | which == 0 = k1+        | which == 1 = k2+        | which == 2 = k3+        | otherwise = error "Impossible"+    toKeep+        | which == 0 = k2+        | which == 1 = k3+        | which == 2 = k1+        | otherwise = error "Impossible"++pInsertWith :: Key -> [(Key, Int)] -> Bool+pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1++pAdjust :: Key -> [(Key, Int)] -> Bool+pAdjust k = M.adjust succ k `eq_` HM.adjust succ k++pUpdateAdjust :: Key -> [(Key, Int)] -> Bool+pUpdateAdjust k = M.update (Just . succ) k `eq_` HM.update (Just . succ) k++pUpdateDelete :: Key -> [(Key, Int)] -> Bool+pUpdateDelete k = M.update (const Nothing) k `eq_` HM.update (const Nothing) k++pAlterAdjust :: Key -> [(Key, Int)] -> Bool+pAlterAdjust k = M.alter (fmap succ) k `eq_` HM.alter (fmap succ) k++pAlterInsert :: Key -> [(Key, Int)] -> Bool+pAlterInsert k = M.alter (const $ Just 3) k `eq_` HM.alter (const $ Just 3) k++pAlterDelete :: Key -> [(Key, Int)] -> Bool+pAlterDelete k = M.alter (const Nothing) k `eq_` HM.alter (const Nothing) k+++-- We choose the list functor here because we don't fuss with+-- it in alterF rules and because it has a sufficiently interesting+-- structure to have a good chance of breaking if something is wrong.+pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property+pAlterF k f xs =+  fmap M.toAscList (M.alterF (apply f) k (M.fromList xs))+  ===+  fmap toAscList (HM.alterF (apply f) k (HM.fromList xs))++#if !MIN_VERSION_base(4,8,0)+newtype Identity a = Identity {runIdentity :: a}+instance Functor Identity where+  fmap f (Identity x) = Identity (f x)+#endif++pAlterFAdjust :: Key -> [(Key, Int)] -> Bool+pAlterFAdjust k =+  runIdentity . M.alterF (Identity . fmap succ) k `eq_`+  runIdentity . HM.alterF (Identity . fmap succ) k++pAlterFInsert :: Key -> [(Key, Int)] -> Bool+pAlterFInsert k =+  runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_`+  runIdentity . HM.alterF (const . Identity . Just $ 3) k++pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool+pAlterFInsertWith k f =+  runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_`+  runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k++pAlterFDelete :: Key -> [(Key, Int)] -> Bool+pAlterFDelete k =+  runIdentity . M.alterF (const (Identity Nothing)) k `eq_`+  runIdentity . HM.alterF (const (Identity Nothing)) k++pAlterFLookup :: Key+              -> Fun (Maybe A) B+              -> [(Key, A)] -> Bool+pAlterFLookup k f =+  getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k+  `eq`+  getConst . HM.alterF (Const . apply f) k++pSubmap :: [(Key, Int)] -> [(Key, Int)] -> Bool+pSubmap xs ys = M.isSubmapOf (M.fromList xs) (M.fromList ys) ==+                HM.isSubmapOf (HM.fromList xs) (HM.fromList ys)++pSubmapReflexive :: HashMap Key Int -> Bool+pSubmapReflexive m = HM.isSubmapOf m m++pSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Bool+pSubmapUnion m1 m2 = HM.isSubmapOf m1 (HM.union m1 m2)++pNotSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Property+pNotSubmapUnion m1 m2 = not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2)++pSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Bool+pSubmapDifference m1 m2 = HM.isSubmapOf (HM.difference m1 m2) m1++pNotSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Property+pNotSubmapDifference m1 m2 =+  not (HM.null (HM.intersection m1 m2)) ==>+  not (HM.isSubmapOf m1 (HM.difference m1 m2))++pSubmapDelete :: HashMap Key Int -> Property+pSubmapDelete m = not (HM.null m) ==>+  forAll (elements (HM.keys m)) $ \k ->+  HM.isSubmapOf (HM.delete k m) m++pNotSubmapDelete :: HashMap Key Int -> Property+pNotSubmapDelete m =+  not (HM.null m) ==>+  forAll (elements (HM.keys m)) $ \k ->+  not (HM.isSubmapOf m (HM.delete k m))++pSubmapInsert :: Key -> Int -> HashMap Key Int -> Property+pSubmapInsert k v m = not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m)++pNotSubmapInsert :: Key -> Int -> HashMap Key Int -> Property+pNotSubmapInsert k v m = not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m)++------------------------------------------------------------------------+-- ** Combine++pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool+pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys++pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool+pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_`+                   HM.unionWith (-) (HM.fromList xs) $ ys++pUnionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool+pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_`+                             HM.unionWithKey go (HM.fromList xs) $ ys+  where+    go :: Key -> Int -> Int -> Int+    go (K k) i1 i2 = k - i1 + i2++pUnions :: [[(Key, Int)]] -> Bool+pUnions xss = M.toAscList (M.unions (map M.fromList xss)) ==+              toAscList (HM.unions (map HM.fromList xss))++------------------------------------------------------------------------+-- ** Transformations++pMap :: [(Key, Int)] -> Bool+pMap = M.map (+ 1) `eq_` HM.map (+ 1)++pTraverse :: [(Key, Int)] -> Bool+pTraverse xs =+  L.sort (fmap (L.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs))))+     == L.sort (fmap (L.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs))))++------------------------------------------------------------------------+-- ** Difference and intersection++pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool+pDifference xs ys = M.difference (M.fromList xs) `eq_`+                    HM.difference (HM.fromList xs) $ ys++pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool+pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_`+                        HM.differenceWith f (HM.fromList xs) $ ys+  where+    f x y = if x == 0 then Nothing else Just (x - y)++pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool+pIntersection xs ys = M.intersection (M.fromList xs) `eq_`+                      HM.intersection (HM.fromList xs) $ ys++pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool+pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_`+                          HM.intersectionWith (-) (HM.fromList xs) $ ys++pIntersectionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool+pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_`+                             HM.intersectionWithKey go (HM.fromList xs) $ ys+  where+    go :: Key -> Int -> Int -> Int+    go (K k) i1 i2 = k - i1 - i2++------------------------------------------------------------------------+-- ** Folds++pFoldr :: [(Int, Int)] -> Bool+pFoldr = (L.sort . M.foldr (:) []) `eq` (L.sort . HM.foldr (:) [])++pFoldl :: [(Int, Int)] -> Bool+pFoldl = (L.sort . M.foldl (flip (:)) []) `eq` (L.sort . HM.foldl (flip (:)) [])++#if MIN_VERSION_base(4,10,0)+pBifoldMap :: [(Int, Int)] -> Bool+pBifoldMap xs = concatMap f (HM.toList m) == bifoldMap (:[]) (:[]) m+  where f (k, v) = [k, v]+        m = HM.fromList xs++pBifoldr :: [(Int, Int)] -> Bool+pBifoldr xs = concatMap f (HM.toList m) == bifoldr (:) (:) [] m+  where f (k, v) = [k, v]+        m = HM.fromList xs++pBifoldl :: [(Int, Int)] -> Bool+pBifoldl xs = reverse (concatMap f $ HM.toList m) == bifoldl (flip (:)) (flip (:)) [] m+  where f (k, v) = [k, v]+        m = HM.fromList xs+#endif++pFoldrWithKey :: [(Int, Int)] -> Bool+pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq`+                (sortByKey . HM.foldrWithKey f [])+  where f k v z = (k, v) : z++pFoldMapWithKey :: [(Int, Int)] -> Bool+pFoldMapWithKey = (sortByKey . M.foldMapWithKey f) `eq`+                  (sortByKey . HM.foldMapWithKey f)+  where f k v = [(k, v)]++pFoldrWithKey' :: [(Int, Int)] -> Bool+pFoldrWithKey' = (sortByKey . M.foldrWithKey' f []) `eq`+                 (sortByKey . HM.foldrWithKey' f [])+  where f k v z = (k, v) : z++pFoldlWithKey :: [(Int, Int)] -> Bool+pFoldlWithKey = (sortByKey . M.foldlWithKey f []) `eq`+                (sortByKey . HM.foldlWithKey f [])+  where f z k v = (k, v) : z++pFoldlWithKey' :: [(Int, Int)] -> Bool+pFoldlWithKey' = (sortByKey . M.foldlWithKey' f []) `eq`+                 (sortByKey . HM.foldlWithKey' f [])+  where f z k v = (k, v) : z++pFoldl' :: [(Int, Int)] -> Bool+pFoldl' = (L.sort . M.foldl' (flip (:)) []) `eq` (L.sort . HM.foldl' (flip (:)) [])++pFoldr' :: [(Int, Int)] -> Bool+pFoldr' = (L.sort . M.foldr' (:) []) `eq` (L.sort . HM.foldr' (:) [])++------------------------------------------------------------------------+-- ** Filter++pMapMaybeWithKey :: [(Key, Int)] -> Bool+pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f+  where f k v = guard (odd (unK k + v)) >> Just (v + 1)++pMapMaybe :: [(Key, Int)] -> Bool+pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f+  where f v = guard (odd v) >> Just (v + 1)++pFilter :: [(Key, Int)] -> Bool+pFilter = M.filter odd `eq_` HM.filter odd++pFilterWithKey :: [(Key, Int)] -> Bool+pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p+  where p k v = odd (unK k + v)++------------------------------------------------------------------------+-- ** Conversions++-- The free magma is used to test that operations are applied in the+-- same order.+data Magma a+  = Leaf a+  | Op (Magma a) (Magma a)+  deriving (Show, Eq, Ord)++instance Hashable a => Hashable (Magma a) where+  hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a)+  hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n)++-- 'eq_' already calls fromList.+pFromList :: [(Key, Int)] -> Bool+pFromList = id `eq_` id++pFromListWith :: [(Key, Int)] -> Bool+pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) ==+                    (toAscList $ HM.fromListWith Op kvsM)+  where kvsM = fmap (fmap Leaf) kvs++pFromListWithKey :: [(Key, Int)] -> Bool+pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) ==+                       (toAscList $ HM.fromListWithKey combine kvsM)+  where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs+        combine k v1 v2 = Op k (Op v1 v2)++pToList :: [(Key, Int)] -> Bool+pToList = M.toAscList `eq` toAscList++pElems :: [(Key, Int)] -> Bool+pElems = (L.sort . M.elems) `eq` (L.sort . HM.elems)++pKeys :: [(Key, Int)] -> Bool+pKeys = (L.sort . M.keys) `eq` (L.sort . HM.keys)++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+    [+    -- Instances+      testGroup "instances"+      [ testProperty "==" pEq+      , testProperty "/=" pNeq+      , testProperty "compare reflexive" pOrd1+      , testProperty "compare transitive" pOrd2+      , testProperty "compare antisymmetric" pOrd3+      , testProperty "Ord => Eq" pOrdEq+      , testProperty "Read/Show" pReadShow+      , testProperty "Functor" pFunctor+      , testProperty "Foldable" pFoldable+      , testProperty "Hashable" pHashable+      ]+    -- Basic interface+    , testGroup "basic interface"+      [ testProperty "size" pSize+      , testProperty "member" pMember+      , testProperty "lookup" pLookup+      , testProperty "!?" pLookupOperator+      , testProperty "insert" pInsert+      , testProperty "delete" pDelete+      , testProperty "deleteCollision" pDeleteCollision+      , testProperty "insertWith" pInsertWith+      , testProperty "adjust" pAdjust+      , testProperty "updateAdjust" pUpdateAdjust+      , testProperty "updateDelete" pUpdateDelete+      , testProperty "alterAdjust" pAlterAdjust+      , testProperty "alterInsert" pAlterInsert+      , testProperty "alterDelete" pAlterDelete+      , testProperty "alterF" pAlterF+      , testProperty "alterFAdjust" pAlterFAdjust+      , testProperty "alterFInsert" pAlterFInsert+      , testProperty "alterFInsertWith" pAlterFInsertWith+      , testProperty "alterFDelete" pAlterFDelete+      , testProperty "alterFLookup" pAlterFLookup+      , testGroup "isSubmapOf"+        [ testProperty "container compatibility" pSubmap+        , testProperty "m ⊆ m" pSubmapReflexive+        , testProperty "m1 ⊆ m1 ∪ m2" pSubmapUnion+        , testProperty "m1 ⊈ m2  ⇒  m1 ∪ m2 ⊈ m1" pNotSubmapUnion+        , testProperty "m1\\m2 ⊆ m1" pSubmapDifference+        , testProperty "m1 ∩ m2 ≠ ∅  ⇒  m1 ⊈ m1\\m2 " pNotSubmapDifference+        , testProperty "delete k m ⊆ m" pSubmapDelete+        , testProperty "m ⊈ delete k m " pNotSubmapDelete+        , testProperty "k ∉ m  ⇒  m ⊆ insert k v m" pSubmapInsert+        , testProperty "k ∉ m  ⇒  insert k v m ⊈ m" pNotSubmapInsert+        ]+      ]+    -- Combine+    , testProperty "union" pUnion+    , testProperty "unionWith" pUnionWith+    , testProperty "unionWithKey" pUnionWithKey+    , testProperty "unions" pUnions+    -- Transformations+    , testProperty "map" pMap+    , testProperty "traverse" pTraverse+    -- Folds+    , testGroup "folds"+      [ testProperty "foldr" pFoldr+      , testProperty "foldl" pFoldl+#if MIN_VERSION_base(4,10,0)+      , testProperty "bifoldMap" pBifoldMap+      , testProperty "bifoldr" pBifoldr+      , testProperty "bifoldl" pBifoldl+#endif+      , testProperty "foldrWithKey" pFoldrWithKey+      , testProperty "foldlWithKey" pFoldlWithKey+      , testProperty "foldrWithKey'" pFoldrWithKey'+      , testProperty "foldlWithKey'" pFoldlWithKey'+      , testProperty "foldl'" pFoldl'+      , testProperty "foldr'" pFoldr'+      , testProperty "foldMapWithKey" pFoldMapWithKey+      ]+    , testGroup "difference and intersection"+      [ testProperty "difference" pDifference+      , testProperty "differenceWith" pDifferenceWith+      , testProperty "intersection" pIntersection+      , testProperty "intersectionWith" pIntersectionWith+      , testProperty "intersectionWithKey" pIntersectionWithKey+      ]+    -- Filter+    , testGroup "filter"+      [ testProperty "filter" pFilter+      , testProperty "filterWithKey" pFilterWithKey+      , testProperty "mapMaybe" pMapMaybe+      , testProperty "mapMaybeWithKey" pMapMaybeWithKey+      ]+    -- Conversions+    , testGroup "conversions"+      [ testProperty "elems" pElems+      , testProperty "keys" pKeys+      , testProperty "fromList" pFromList+      , testProperty "fromListWith" pFromListWith+      , testProperty "fromListWithKey" pFromListWithKey+      , testProperty "toList" pToList+      ]+    ]++------------------------------------------------------------------------+-- * Model++type Model k v = M.Map k v++-- | Check that a function operating on a 'HashMap' is equivalent to+-- one operating on a 'Model'.+eq :: (Eq a, Eq k, Hashable k, Ord k)+   => (Model k v -> a)       -- ^ Function that modifies a 'Model'+   -> (HM.HashMap k v -> a)  -- ^ Function that modified a 'HashMap' in the same+                             -- way+   -> [(k, v)]               -- ^ Initial content of the 'HashMap' and 'Model'+   -> Bool                   -- ^ True if the functions are equivalent+eq f g xs = g (HM.fromList xs) == f (M.fromList xs)++infix 4 `eq`++eq_ :: (Eq k, Eq v, Hashable k, Ord k)+    => (Model k v -> Model k v)            -- ^ Function that modifies a 'Model'+    -> (HM.HashMap k v -> HM.HashMap k v)  -- ^ Function that modified a+                                           -- 'HashMap' in the same way+    -> [(k, v)]                            -- ^ Initial content of the 'HashMap'+                                           -- and 'Model'+    -> Bool                                -- ^ True if the functions are+                                           -- equivalent+eq_ f g = (M.toAscList . f) `eq` (toAscList . g)++infix 4 `eq_`++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Helpers++sortByKey :: Ord k => [(k, v)] -> [(k, v)]+sortByKey = L.sortBy (compare `on` fst)++toAscList :: Ord k => HM.HashMap k v -> [(k, v)]+toAscList = L.sortBy (compare `on` fst) . HM.toList
+ tests/IntMapValidity.hs view
@@ -0,0 +1,65 @@+module IntMapValidity (valid) where++import Data.Bits (xor, (.&.))+import Data.Strict.IntMap.Autogen.Internal+import Test.QuickCheck (Property, counterexample, property, (.&&.))+import Data.Strict.ContainersUtils.Autogen.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
+ tests/Tests/Bundle.hs view
@@ -0,0 +1,165 @@+module Tests.Bundle ( tests ) where++import Boilerplater+import Utilities hiding (limitUnfolds)++import qualified Data.Vector.Fusion.Bundle as S++import Test.QuickCheck++import Test.Tasty+import Test.Tasty.QuickCheck hiding (testProperties)++import Text.Show.Functions ()+import Data.List           (foldl', foldl1', unfoldr, find, findIndex)++-- migration from testframework to tasty+type Test = TestTree++#define COMMON_CONTEXT(a) \+ VANILLA_CONTEXT(a)++#define VANILLA_CONTEXT(a) \+  Eq a,     Show a,     Arbitrary a,     CoArbitrary a,     TestData a,     Model a ~ a,        EqTest a ~ Property++testSanity :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test]+testSanity _ = [+        testProperty "fromList.toList == id" prop_fromList_toList,+        testProperty "toList.fromList == id" prop_toList_fromList+    ]+  where+    prop_fromList_toList :: P (S.Bundle v a -> S.Bundle v a)+        = (S.fromList . S.toList) `eq` id+    prop_toList_fromList :: P ([a] -> [a])+        = (S.toList . (S.fromList :: [a] -> S.Bundle v a)) `eq` id++testPolymorphicFunctions :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test]+testPolymorphicFunctions _ = $(testProperties [+        'prop_eq,++        'prop_length, 'prop_null,++        'prop_empty, 'prop_singleton, 'prop_replicate,+        'prop_cons, 'prop_snoc, 'prop_append,++        'prop_head, 'prop_last, 'prop_index,++        'prop_extract, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop,++        'prop_map, 'prop_zipWith, 'prop_zipWith3,+        'prop_filter, 'prop_takeWhile, 'prop_dropWhile,++        'prop_elem, 'prop_notElem,+        'prop_find, 'prop_findIndex,++        'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1',+        'prop_foldr, 'prop_foldr1,++        'prop_prescanl, 'prop_prescanl',+        'prop_postscanl, 'prop_postscanl',+        'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1',++        'prop_concatMap,+        'prop_unfoldr+    ])+  where+    -- Prelude+    prop_eq :: P (S.Bundle v a -> S.Bundle v a -> Bool) = (==) `eq` (==)++    prop_length :: P (S.Bundle v a -> Int)     = S.length `eq` length+    prop_null   :: P (S.Bundle v a -> Bool)    = S.null `eq` null+    prop_empty  :: P (S.Bundle v a)            = S.empty `eq` []+    prop_singleton :: P (a -> S.Bundle v a)    = S.singleton `eq` singleton+    prop_replicate :: P (Int -> a -> S.Bundle v a)+              = (\n _ -> n < 1000) ===> S.replicate `eq` replicate+    prop_cons      :: P (a -> S.Bundle v a -> S.Bundle v a) = S.cons `eq` (:)+    prop_snoc      :: P (S.Bundle v a -> a -> S.Bundle v a) = S.snoc `eq` snoc+    prop_append    :: P (S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = (S.++) `eq` (++)++    prop_head      :: P (S.Bundle v a -> a) = not . S.null ===> S.head `eq` head+    prop_last      :: P (S.Bundle v a -> a) = not . S.null ===> S.last `eq` last+    prop_index        = \xs ->+                        not (S.null xs) ==>+                        forAll (choose (0, S.length xs-1)) $ \i ->+                        unP prop xs i+      where+        prop :: P (S.Bundle v a -> Int -> a) = (S.!!) `eq` (!!)++    prop_extract      = \xs ->+                        forAll (choose (0, S.length xs))     $ \i ->+                        forAll (choose (0, S.length xs - i)) $ \n ->+                        unP prop i n xs+      where+        prop :: P (Int -> Int -> S.Bundle v a -> S.Bundle v a) = S.slice `eq` slice++    prop_tail :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.tail `eq` tail+    prop_init :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.init `eq` init+    prop_take :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.take `eq` take+    prop_drop :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.drop `eq` drop++    prop_map :: P ((a -> a) -> S.Bundle v a -> S.Bundle v a) = S.map `eq` map+    prop_zipWith :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = S.zipWith `eq` zipWith+    prop_zipWith3 :: P ((a -> a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a)+             = S.zipWith3 `eq` zipWith3++    prop_filter :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.filter `eq` filter+    prop_takeWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.takeWhile `eq` takeWhile+    prop_dropWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.dropWhile `eq` dropWhile++    prop_elem    :: P (a -> S.Bundle v a -> Bool) = S.elem `eq` elem+    prop_notElem :: P (a -> S.Bundle v a -> Bool) = S.notElem `eq` notElem+    prop_find    :: P ((a -> Bool) -> S.Bundle v a -> Maybe a) = S.find `eq` find+    prop_findIndex :: P ((a -> Bool) -> S.Bundle v a -> Maybe Int)+      = S.findIndex `eq` findIndex++    prop_foldl :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl `eq` foldl+    prop_foldl1 :: P ((a -> a -> a) -> S.Bundle v a -> a)     = notNullS2 ===>+                        S.foldl1 `eq` foldl1+    prop_foldl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl' `eq` foldl'+    prop_foldl1' :: P ((a -> a -> a) -> S.Bundle v a -> a)     = notNullS2 ===>+                        S.foldl1' `eq` foldl1'+    prop_foldr :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldr `eq` foldr+    prop_foldr1 :: P ((a -> a -> a) -> S.Bundle v a -> a)     = notNullS2 ===>+                        S.foldr1 `eq` foldr1++    prop_prescanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a)+                = S.prescanl `eq` prescanl+    prop_prescanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a)+                = S.prescanl' `eq` prescanl+    prop_postscanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a)+                = S.postscanl `eq` postscanl+    prop_postscanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a)+                = S.postscanl' `eq` postscanl+    prop_scanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a)+                = S.scanl `eq` scanl+    prop_scanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a)+               = S.scanl' `eq` scanl+    prop_scanl1 :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===>+                 S.scanl1 `eq` scanl1+    prop_scanl1' :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===>+                 S.scanl1' `eq` scanl1++    prop_concatMap    = forAll arbitrary $ \xs ->+                        forAll (sized (\n -> resize (n `div` S.length xs) arbitrary)) $ \f -> unP prop f xs+      where+        prop :: P ((a -> S.Bundle v a) -> S.Bundle v a -> S.Bundle v a) = S.concatMap `eq` concatMap++    limitUnfolds f (theirs, ours) | ours >= 0+                                  , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1))+                                  | otherwise                       = Nothing+    prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> S.Bundle v a)+         = (\n f a -> S.unfoldr (limitUnfolds f) (a, n))+           `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n))++testBoolFunctions :: forall v. S.Bundle v Bool -> [Test]+testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or ])+  where+    prop_and :: P (S.Bundle v Bool -> Bool) = S.and `eq` and+    prop_or  :: P (S.Bundle v Bool -> Bool) = S.or `eq` or++testBundleFunctions = testSanity (undefined :: S.Bundle v Int)+                      ++ testPolymorphicFunctions (undefined :: S.Bundle v Int)+                      ++ testBoolFunctions (undefined :: S.Bundle v Bool)++tests = [ testGroup "Data.Vector.Fusion.Bundle" testBundleFunctions ]+
+ tests/Tests/Move.hs view
@@ -0,0 +1,44 @@+module Tests.Move (tests) where++import Test.QuickCheck+import Test.Tasty.QuickCheck+import Test.QuickCheck.Property (Property(..))++import Utilities ()++import Control.Monad (replicateM)+import Control.Monad.ST (runST)+import Data.List (sort,permutations)++import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as M++import qualified Data.Strict.Vector as V+import qualified Data.Vector.Unboxed as U++basicMove :: G.Vector v a => v a -> Int -> Int -> Int -> v a+basicMove v dstOff srcOff len+  | len > 0 = G.modify (\ mv -> G.copy (M.slice dstOff len mv) (G.slice srcOff len v)) v+  | otherwise = v++testMove :: (G.Vector v a, Show (v a), Eq (v a)) => v a -> Property+testMove v = G.length v > 0 ==> (MkProperty $ do+  dstOff <- choose (0, G.length v - 1)+  srcOff <- choose (0, G.length v - 1)+  len <- choose (1, G.length v - max dstOff srcOff)+  expected <- return $ basicMove v dstOff srcOff len+  actual <- return $  G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v+  unProperty $ counterexample ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual))++checkPermutations :: Int -> Bool+checkPermutations n = runST $ do+    vec <- U.thaw (U.fromList [1..n])+    res <- replicateM (product [1..n]) $ M.nextPermutation vec >> U.freeze vec >>= return . U.toList+    return $! ([1..n] : res) == sort (permutations [1..n]) ++ [[n,n-1..1]]++testPermutations :: Bool+testPermutations = all checkPermutations [1..7]++tests =+    [testProperty "Data.Vector.Mutable (Move)" (testMove :: V.Vector Int -> Property),+     testProperty "Data.Vector.Generic.Mutable (nextPermutation)" testPermutations]
+ tests/Tests/Vector.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE ConstraintKinds #-}+module Tests.Vector (tests) where++import Test.Tasty (testGroup)+import qualified Tests.Vector.Boxed++tests =+  [ testGroup "Tests.Vector.Boxed" Tests.Vector.Boxed.tests+  ]
+ tests/Tests/Vector/Boxed.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ConstraintKinds #-}+module Tests.Vector.Boxed (tests) where++import Test.Tasty+import qualified Data.Strict.Vector+import Tests.Vector.Property++import GHC.Exts (inline)+++testGeneralBoxedVector :: forall a. (CommonContext a Data.Strict.Vector.Vector, Ord a, Data a) => Data.Strict.Vector.Vector a -> [Test]+testGeneralBoxedVector dummy = concatMap ($ dummy)+  [+    testSanity+  , inline testPolymorphicFunctions+  , testOrdFunctions+  , testTuplyFunctions+  , testNestedVectorFunctions+  , testMonoidFunctions+  , testFunctorFunctions+  , testMonadFunctions+  , testApplicativeFunctions+  , testAlternativeFunctions+  , testSequenceFunctions+  , testDataFunctions+  ]++testBoolBoxedVector dummy = concatMap ($ dummy)+  [+    testGeneralBoxedVector+  , testBoolFunctions+  ]++testNumericBoxedVector :: forall a. (CommonContext a Data.Strict.Vector.Vector, Ord a, Num a, Enum a, Random a, Data a) => Data.Strict.Vector.Vector a -> [Test]+testNumericBoxedVector dummy = concatMap ($ dummy)+  [+    testGeneralBoxedVector+  , testNumFunctions+  , testEnumFunctions+  ]++tests =+  [ testGroup "Bool" $+    testBoolBoxedVector (undefined :: Data.Strict.Vector.Vector Bool)+  , testGroup "Int" $+    testNumericBoxedVector (undefined :: Data.Strict.Vector.Vector Int)+  ]
+ tests/Tests/Vector/Property.hs view
@@ -0,0 +1,804 @@+{-# LANGUAGE ConstraintKinds #-}+module Tests.Vector.Property+  ( CommonContext+  , VanillaContext+  , VectorContext+  , testSanity+  , testPolymorphicFunctions+  , testTuplyFunctions+  , testOrdFunctions+  , testEnumFunctions+  , testMonoidFunctions+  , testFunctorFunctions+  , testMonadFunctions+  , testApplicativeFunctions+  , testAlternativeFunctions+  , testSequenceFunctions+  , testBoolFunctions+  , testNumFunctions+  , testNestedVectorFunctions+  , testDataFunctions+  -- re-exports+  , Data+  , Random+  , Test+  ) where++import Boilerplater+import Utilities as Util hiding (limitUnfolds)++import Control.Monad+import Control.Monad.ST+import qualified Data.Traversable as T (Traversable(..))+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Identity+import Data.Orphans ()+import Data.Foldable (foldrM)+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as MV+import qualified Data.Vector.Fusion.Bundle as S++import Test.QuickCheck++import Test.Tasty+import Test.Tasty.QuickCheck hiding (testProperties)++import Text.Show.Functions ()+import Data.List++import Data.Monoid++import qualified Control.Applicative as Applicative+import System.Random       (Random)++import Data.Functor.Identity+import Control.Monad.Trans.Writer++import Control.Monad.Zip++import Data.Data++import qualified Data.List.NonEmpty as DLE+import Data.Semigroup (Semigroup(..))++type CommonContext  a v = (VanillaContext a, VectorContext a v)+type VanillaContext a   = ( Eq a , Show a, Arbitrary a, CoArbitrary a+                          , TestData a, Model a ~ a, EqTest a ~ Property)+type VectorContext  a v = ( Eq (v a), Show (v a), Arbitrary (v a), CoArbitrary (v a)+                          , TestData (v a), Model (v a) ~ [a],  EqTest (v a) ~ Property, V.Vector v a)++-- | migration hack for moving from TestFramework to Tasty+type Test = TestTree+-- TODO: implement Vector equivalents of list functions for some of the commented out properties++-- TODO: add tests for the other extra functions+-- IVector exports still needing tests:+--  copy,+--  new,+--  unsafeSlice, unsafeIndex,++testSanity :: forall a v. (CommonContext a v) => v a -> [Test]+{-# INLINE testSanity #-}+testSanity _ = [+        testProperty "fromList.toList == id" prop_fromList_toList,+        testProperty "toList.fromList == id" prop_toList_fromList,+        testProperty "unstream.stream == id" prop_unstream_stream,+        testProperty "stream.unstream == id" prop_stream_unstream+    ]+  where+    prop_fromList_toList (v :: v a)        = (V.fromList . V.toList)                        v == v+    prop_toList_fromList (l :: [a])        = ((V.toList :: v a -> [a]) . V.fromList)        l == l+    prop_unstream_stream (v :: v a)        = (V.unstream . V.stream)                        v == v+    prop_stream_unstream (s :: S.Bundle v a) = ((V.stream :: v a -> S.Bundle v a) . V.unstream) s == s++testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [Test]+-- FIXME: inlining of unboxed properties blows up the memory during compilation. See #272+--{-# INLINE testPolymorphicFunctions #-}+testPolymorphicFunctions _ = $(testProperties [+        'prop_eq,++        -- Length information+        'prop_length, 'prop_null,++        -- Indexing+        'prop_index, 'prop_safeIndex, 'prop_head, 'prop_last,+        'prop_unsafeIndex, 'prop_unsafeHead, 'prop_unsafeLast,++        -- Monadic indexing (FIXME)+        {- 'prop_indexM, 'prop_headM, 'prop_lastM,+        'prop_unsafeIndexM, 'prop_unsafeHeadM, 'prop_unsafeLastM, -}++        -- Subvectors (FIXME)+        'prop_slice, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop,+        'prop_splitAt,+        {- 'prop_unsafeSlice, 'prop_unsafeInit, 'prop_unsafeTail,+        'prop_unsafeTake, 'prop_unsafeDrop, -}++        -- Initialisation (FIXME)+        'prop_empty, 'prop_singleton, 'prop_replicate,+        'prop_generate, 'prop_iterateN, 'prop_iterateNM,+        'prop_generateM, 'prop_replicateM,++        -- Monadic initialisation (FIXME)+        'prop_create, 'prop_createT,++        -- Unfolding+        'prop_unfoldr, 'prop_unfoldrN, 'prop_unfoldrExactN,+        'prop_unfoldrM, 'prop_unfoldrNM, 'prop_unfoldrExactNM,+        'prop_constructN, 'prop_constructrN,++        -- Concatenation (FIXME)+        'prop_cons, 'prop_snoc, 'prop_append,+        'prop_concat,++        -- Restricting memory usage+        'prop_force,+++        -- Bulk updates (FIXME)+        'prop_upd,+        {- 'prop_update_,+        'prop_unsafeUpd, 'prop_unsafeUpdate, 'prop_unsafeUpdate_, -}++        -- Accumulations (FIXME)+        'prop_accum,+        {- 'prop_accumulate, 'prop_accumulate_,+        'prop_unsafeAccum, 'prop_unsafeAccumulate, 'prop_unsafeAccumulate_, -}++        -- Permutations+        'prop_reverse, 'prop_backpermute,+        {- 'prop_unsafeBackpermute, -}++        -- Mapping+        'prop_map, 'prop_imap, 'prop_concatMap,++        -- Monadic mapping+        'prop_mapM, 'prop_mapM_, 'prop_forM, 'prop_forM_,+        'prop_imapM, 'prop_imapM_,++        -- Zipping+        'prop_zipWith, 'prop_zipWith3,+        'prop_izipWith, 'prop_izipWith3,+        'prop_izipWithM, 'prop_izipWithM_,++        -- Monadic zipping+        'prop_zipWithM, 'prop_zipWithM_,++        -- Filtering+        'prop_filter, 'prop_ifilter, 'prop_filterM,+        'prop_uniq,+        'prop_mapMaybe, 'prop_imapMaybe,+        'prop_takeWhile, 'prop_dropWhile,++        -- Paritioning+        'prop_partition, {- 'prop_unstablePartition, -}+        'prop_partitionWith,+        'prop_span, 'prop_break,++        -- Searching+        'prop_elem, 'prop_notElem,+        'prop_find, 'prop_findIndex, 'prop_findIndexR, 'prop_findIndices,+        'prop_elemIndex, 'prop_elemIndices,++        -- Folding+        'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1',+        'prop_foldr, 'prop_foldr1, 'prop_foldr', 'prop_foldr1',+        'prop_ifoldl, 'prop_ifoldl', 'prop_ifoldr, 'prop_ifoldr',+        'prop_ifoldM, 'prop_ifoldM', 'prop_ifoldM_, 'prop_ifoldM'_,++        -- Specialised folds+        'prop_all, 'prop_any,++        -- Scans+        'prop_prescanl, 'prop_prescanl',+        'prop_postscanl, 'prop_postscanl',+        'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1',+        'prop_iscanl, 'prop_iscanl',++        'prop_prescanr, 'prop_prescanr',+        'prop_postscanr, 'prop_postscanr',+        'prop_scanr, 'prop_scanr', 'prop_scanr1, 'prop_scanr1',+        'prop_iscanr, 'prop_iscanr',++        -- Mutable API+        'prop_mut_read, 'prop_mut_write, 'prop_mut_modify,++        'prop_mut_generate, 'prop_mut_generateM,+        'prop_mut_mapM_, 'prop_mut_imapM_, 'prop_mut_forM_, 'prop_mut_iforM_,+        'prop_mut_foldr, 'prop_mut_foldr', 'prop_mut_foldl, 'prop_mut_foldl',+        'prop_mut_ifoldr, 'prop_mut_ifoldr', 'prop_mut_ifoldl, 'prop_mut_ifoldl',+        'prop_mut_foldM, 'prop_mut_foldM', 'prop_mut_foldrM, 'prop_mut_foldrM',+        'prop_mut_ifoldM, 'prop_mut_ifoldM', 'prop_mut_ifoldrM, 'prop_mut_ifoldrM'+    ])+  where+    -- Prelude+    prop_eq :: P (v a -> v a -> Bool) = (==) `eq` (==)++    prop_length :: P (v a -> Int)     = V.length `eq` length+    prop_null   :: P (v a -> Bool)    = V.null `eq` null++    prop_empty  :: P (v a)            = V.empty `eq` []+    prop_singleton :: P (a -> v a)    = V.singleton `eq` Util.singleton+    prop_replicate :: P (Int -> a -> v a)+              = (\n _ -> n < 1000) ===> V.replicate `eq` replicate+    prop_replicateM :: P (Int -> Writer [a] a -> Writer [a] (v a))+              = (\n _ -> n < 1000) ===> V.replicateM `eq` replicateM+    prop_cons      :: P (a -> v a -> v a) = V.cons `eq` (:)+    prop_snoc      :: P (v a -> a -> v a) = V.snoc `eq` snoc+    prop_append    :: P (v a -> v a -> v a) = (V.++) `eq` (++)+    prop_concat    :: P ([v a] -> v a) = V.concat `eq` concat+    prop_force     :: P (v a -> v a)        = V.force `eq` id+    prop_generate  :: P (Int -> (Int -> a) -> v a)+              = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate+    prop_generateM  :: P (Int -> (Int -> Writer [a] a) -> Writer [a] (v a))+              = (\n _ -> n < 1000) ===> V.generateM `eq` Util.generateM+    prop_iterateN  :: P (Int -> (a -> a) -> a -> v a)+              = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f)+    prop_iterateNM :: P (Int -> (a -> Writer [Int] a) -> a -> Writer [Int] (v a))+              = (\n _ _ -> n < 1000) ===> V.iterateNM `eq` Util.iterateNM+    prop_create :: P (v a -> v a)+    prop_create = (\v -> V.create (V.thaw v)) `eq` id+    prop_createT :: P ((a, v a) -> (a, v a))+    prop_createT = (\v -> V.createT (T.mapM V.thaw v)) `eq` id++    prop_head      :: P (v a -> a) = not . V.null ===> V.head `eq` head+    prop_last      :: P (v a -> a) = not . V.null ===> V.last `eq` last+    prop_index        = \xs ->+                        not (V.null xs) ==>+                        forAll (choose (0, V.length xs-1)) $ \i ->+                        unP prop xs i+      where+        prop :: P (v a -> Int -> a) = (V.!) `eq` (!!)+    prop_safeIndex :: P (v a -> Int -> Maybe a) = (V.!?) `eq` fn+      where+        fn xs i = case drop i xs of+                    x:_ | i >= 0 -> Just x+                    _            -> Nothing+    prop_unsafeHead  :: P (v a -> a) = not . V.null ===> V.unsafeHead `eq` head+    prop_unsafeLast  :: P (v a -> a) = not . V.null ===> V.unsafeLast `eq` last+    prop_unsafeIndex  = \xs ->+                        not (V.null xs) ==>+                        forAll (choose (0, V.length xs-1)) $ \i ->+                        unP prop xs i+      where+        prop :: P (v a -> Int -> a) = V.unsafeIndex `eq` (!!)++    prop_slice        = \xs ->+                        forAll (choose (0, V.length xs))     $ \i ->+                        forAll (choose (0, V.length xs - i)) $ \n ->+                        unP prop i n xs+      where+        prop :: P (Int -> Int -> v a -> v a) = V.slice `eq` slice++    prop_tail :: P (v a -> v a) = not . V.null ===> V.tail `eq` tail+    prop_init :: P (v a -> v a) = not . V.null ===> V.init `eq` init+    prop_take :: P (Int -> v a -> v a) = V.take `eq` take+    prop_drop :: P (Int -> v a -> v a) = V.drop `eq` drop+    prop_splitAt :: P (Int -> v a -> (v a, v a)) = V.splitAt `eq` splitAt++    prop_accum = \f xs ->+                 forAll (index_value_pairs (V.length xs)) $ \ps ->+                 unP prop f xs ps+      where+        prop :: P ((a -> a -> a) -> v a -> [(Int,a)] -> v a)+          = V.accum `eq` accum++    prop_upd        = \xs ->+                        forAll (index_value_pairs (V.length xs)) $ \ps ->+                        unP prop xs ps+      where+        prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//)++    prop_backpermute  = \xs ->+                        forAll (indices (V.length xs)) $ \is ->+                        unP prop xs (V.fromList is)+      where+        prop :: P (v a -> v Int -> v a) = V.backpermute `eq` backpermute++    prop_reverse :: P (v a -> v a) = V.reverse `eq` reverse++    prop_map :: P ((a -> a) -> v a -> v a) = V.map `eq` map+    prop_mapM :: P ((a -> Identity a) -> v a -> Identity (v a))+            = V.mapM `eq` mapM+    prop_mapM_ :: P ((a -> Writer [a] ()) -> v a -> Writer [a] ())+            = V.mapM_ `eq` mapM_+    prop_forM :: P (v a -> (a -> Identity a) -> Identity (v a))+            = V.forM `eq` forM+    prop_forM_ :: P (v a -> (a -> Writer [a] ()) -> Writer [a] ())+            = V.forM_ `eq` forM_+    prop_zipWith :: P ((a -> a -> a) -> v a -> v a -> v a) = V.zipWith `eq` zipWith+    prop_zipWith3 :: P ((a -> a -> a -> a) -> v a -> v a -> v a -> v a)+             = V.zipWith3 `eq` zipWith3+    prop_imap :: P ((Int -> a -> a) -> v a -> v a) = V.imap `eq` imap+    prop_imapM :: P ((Int -> a -> Identity a) -> v a -> Identity (v a))+            = V.imapM `eq` imapM+    prop_imapM_ :: P ((Int -> a -> Writer [a] ()) -> v a -> Writer [a] ())+            = V.imapM_ `eq` imapM_+    prop_izipWith :: P ((Int -> a -> a -> a) -> v a -> v a -> v a) = V.izipWith `eq` izipWith+    prop_zipWithM :: P ((a -> a -> Identity a) -> v a -> v a -> Identity (v a))+            = V.zipWithM `eq` zipWithM+    prop_zipWithM_ :: P ((a -> a -> Writer [a] ()) -> v a -> v a -> Writer [a] ())+            = V.zipWithM_ `eq` zipWithM_+    prop_izipWithM :: P ((Int -> a -> a -> Identity a) -> v a -> v a -> Identity (v a))+            = V.izipWithM `eq` izipWithM+    prop_izipWithM_ :: P ((Int -> a -> a -> Writer [a] ()) -> v a -> v a -> Writer [a] ())+            = V.izipWithM_ `eq` izipWithM_+    prop_izipWith3 :: P ((Int -> a -> a -> a -> a) -> v a -> v a -> v a -> v a)+             = V.izipWith3 `eq` izipWith3++    prop_filter :: P ((a -> Bool) -> v a -> v a) = V.filter `eq` filter+    prop_ifilter :: P ((Int -> a -> Bool) -> v a -> v a) = V.ifilter `eq` ifilter+    prop_filterM :: P ((a -> Writer [a] Bool) -> v a -> Writer [a] (v a)) = V.filterM `eq` filterM+    prop_mapMaybe :: P ((a -> Maybe a) -> v a -> v a) = V.mapMaybe `eq` mapMaybe+    prop_imapMaybe :: P ((Int -> a -> Maybe a) -> v a -> v a) = V.imapMaybe `eq` imapMaybe+    prop_takeWhile :: P ((a -> Bool) -> v a -> v a) = V.takeWhile `eq` takeWhile+    prop_dropWhile :: P ((a -> Bool) -> v a -> v a) = V.dropWhile `eq` dropWhile+    prop_partition :: P ((a -> Bool) -> v a -> (v a, v a))+      = V.partition `eq` partition+    prop_partitionWith :: P ((a -> Either a a) -> v a -> (v a, v a))+      = V.partitionWith `eq` partitionWith+    prop_span :: P ((a -> Bool) -> v a -> (v a, v a)) = V.span `eq` span+    prop_break :: P ((a -> Bool) -> v a -> (v a, v a)) = V.break `eq` break++    prop_elem    :: P (a -> v a -> Bool) = V.elem `eq` elem+    prop_notElem :: P (a -> v a -> Bool) = V.notElem `eq` notElem+    prop_find    :: P ((a -> Bool) -> v a -> Maybe a) = V.find `eq` find+    prop_findIndex :: P ((a -> Bool) -> v a -> Maybe Int)+      = V.findIndex `eq` findIndex+    prop_findIndexR :: P ((a -> Bool) -> v a -> Maybe Int)+      = V.findIndexR `eq` \p l -> case filter (p . snd) . reverse $ zip [0..] l of+                                     (i,_):_ -> Just i+                                     []      -> Nothing+    prop_findIndices :: P ((a -> Bool) -> v a -> v Int)+        = V.findIndices `eq` findIndices+    prop_elemIndex :: P (a -> v a -> Maybe Int) = V.elemIndex `eq` elemIndex+    prop_elemIndices :: P (a -> v a -> v Int) = V.elemIndices `eq` elemIndices++    prop_foldl :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl `eq` foldl+    prop_foldl1 :: P ((a -> a -> a) -> v a -> a)     = notNull2 ===>+                        V.foldl1 `eq` foldl1+    prop_foldl' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl' `eq` foldl'+    prop_foldl1' :: P ((a -> a -> a) -> v a -> a)     = notNull2 ===>+                        V.foldl1' `eq` foldl1'+    prop_foldr :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr `eq` foldr+    prop_foldr1 :: P ((a -> a -> a) -> v a -> a)     = notNull2 ===>+                        V.foldr1 `eq` foldr1+    prop_foldr' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr' `eq` foldr+    prop_foldr1' :: P ((a -> a -> a) -> v a -> a)     = notNull2 ===>+                        V.foldr1' `eq` foldr1+    prop_ifoldl :: P ((a -> Int -> a -> a) -> a -> v a -> a)+        = V.ifoldl `eq` ifoldl+    prop_ifoldl' :: P ((a -> Int -> a -> a) -> a -> v a -> a)+        = V.ifoldl' `eq` ifoldl+    prop_ifoldr :: P ((Int -> a -> a -> a) -> a -> v a -> a)+        = V.ifoldr `eq` ifoldr+    prop_ifoldr' :: P ((Int -> a -> a -> a) -> a -> v a -> a)+        = V.ifoldr' `eq` ifoldr+    prop_ifoldM :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a)+        = V.ifoldM `eq` ifoldM+    prop_ifoldM' :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a)+        = V.ifoldM' `eq` ifoldM+    prop_ifoldM_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ())+        = V.ifoldM_ `eq` ifoldM_+    prop_ifoldM'_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ())+        = V.ifoldM'_ `eq` ifoldM_++    prop_all :: P ((a -> Bool) -> v a -> Bool) = V.all `eq` all+    prop_any :: P ((a -> Bool) -> v a -> Bool) = V.any `eq` any++    prop_prescanl :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.prescanl `eq` prescanl+    prop_prescanl' :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.prescanl' `eq` prescanl+    prop_postscanl :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.postscanl `eq` postscanl+    prop_postscanl' :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.postscanl' `eq` postscanl+    prop_scanl :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.scanl `eq` scanl+    prop_scanl' :: P ((a -> a -> a) -> a -> v a -> v a)+               = V.scanl' `eq` scanl+    prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===>+                 V.scanl1 `eq` scanl1+    prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===>+                 V.scanl1' `eq` scanl1+    prop_iscanl :: P ((Int -> a -> a -> a) -> a -> v a -> v a)+                = V.iscanl `eq` iscanl+    prop_iscanl' :: P ((Int -> a -> a -> a) -> a -> v a -> v a)+               = V.iscanl' `eq` iscanl++    prop_prescanr :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.prescanr `eq` prescanr+    prop_prescanr' :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.prescanr' `eq` prescanr+    prop_postscanr :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.postscanr `eq` postscanr+    prop_postscanr' :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.postscanr' `eq` postscanr+    prop_scanr :: P ((a -> a -> a) -> a -> v a -> v a)+                = V.scanr `eq` scanr+    prop_scanr' :: P ((a -> a -> a) -> a -> v a -> v a)+               = V.scanr' `eq` scanr+    prop_iscanr :: P ((Int -> a -> a -> a) -> a -> v a -> v a)+                = V.iscanr `eq` iscanr+    prop_iscanr' :: P ((Int -> a -> a -> a) -> a -> v a -> v a)+               = V.iscanr' `eq` iscanr+    prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===>+                 V.scanr1 `eq` scanr1+    prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===>+                 V.scanr1' `eq` scanr1++    prop_concatMap    = forAll arbitrary $ \xs ->+                        forAll (sized (\n -> resize (n `div` V.length xs) arbitrary)) $ \f -> unP prop f xs+      where+        prop :: P ((a -> v a) -> v a -> v a) = V.concatMap `eq` concatMap++    prop_uniq :: P (v a -> v a)+      = V.uniq `eq` (map head . group)++    -- Data.List+    --prop_mapAccumL  = eq3+    --    (V.mapAccumL :: (X -> W -> (X,W)) -> X -> B   -> (X, B))+    --    (  mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))+    --+    --prop_mapAccumR  = eq3+    --    (V.mapAccumR :: (X -> W -> (X,W)) -> X -> B   -> (X, B))+    --    (  mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))++    -- Because the vectors are strict, we need to be totally sure that the unfold eventually terminates. This+    -- is achieved by injecting our own bit of state into the unfold - the maximum number of unfolds allowed.+    limitUnfolds f (theirs, ours)+        | ours > 0+        , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1))+        | otherwise                       = Nothing+    limitUnfoldsM f (theirs, ours)+        | ours >  0 = do r <- f theirs+                         return $ (\(a,b) -> (a,(b,ours - 1))) `fmap` r+        | otherwise = return Nothing+++    prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a)+         = (\n f a -> V.unfoldr (limitUnfolds f) (a, n))+           `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n))+    prop_unfoldrN :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a)+         = V.unfoldrN `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n))+    prop_unfoldrExactN :: P (Int -> (Int -> (a,Int)) -> Int -> v a)+         = V.unfoldrExactN `eq` (\n f a -> unfoldr (limitUnfolds (Just . f)) (a, n))+    prop_unfoldrM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a))+         = (\n f a -> V.unfoldrM (limitUnfoldsM f) (a,n))+           `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n))+    prop_unfoldrNM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a))+         = V.unfoldrNM `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n))+    prop_unfoldrExactNM :: P (Int -> (Int -> Writer [Int] (a,Int)) -> Int -> Writer [Int] (v a))+         = V.unfoldrExactNM `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM (liftM Just . f)) (a, n))++    prop_constructN  = \f -> forAll (choose (0,20)) $ \n -> unP prop n f+      where+        prop :: P (Int -> (v a -> a) -> v a) = V.constructN `eq` constructN []++        constructN xs 0 _ = xs+        constructN xs n f = constructN (xs ++ [f xs]) (n-1) f++    prop_constructrN  = \f -> forAll (choose (0,20)) $ \n -> unP prop n f+      where+        prop :: P (Int -> (v a -> a) -> v a) = V.constructrN `eq` constructrN []++        constructrN xs 0 _ = xs+        constructrN xs n f = constructrN (f xs : xs) (n-1) f++    prop_mut_foldr :: P ((a -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.foldr f z =<< V.thaw v) `eq` foldr+    prop_mut_foldr' :: P ((a -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.foldr' f z =<< V.thaw v) `eq` foldr+    prop_mut_foldl :: P ((a -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.foldl f z =<< V.thaw v) `eq` foldl+    prop_mut_foldl' :: P ((a -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.foldl' f z =<< V.thaw v) `eq` foldl'+    prop_mut_ifoldr :: P ((Int -> a -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.ifoldr f z =<< V.thaw v) `eq` ifoldr+    prop_mut_ifoldr' :: P ((Int -> a -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.ifoldr' f z =<< V.thaw v) `eq` ifoldr+    prop_mut_ifoldl :: P ((a -> Int -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.ifoldl f z =<< V.thaw v) `eq` ifoldl+    prop_mut_ifoldl' :: P ((a -> Int -> a -> a) -> a -> v a -> a) =+      (\f z v -> runST $ MV.ifoldl' f z =<< V.thaw v) `eq` ifoldl++    prop_mut_foldM :: P ((a -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.foldM (\b -> pure . runIdentity . f b) z =<< V.thaw v)+      `eq` foldM+    prop_mut_foldM' :: P ((a -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.foldM' (\b -> pure . runIdentity . f b) z =<< V.thaw v)+      `eq` foldM+    prop_mut_foldrM :: P ((a -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.foldrM (\a -> pure . runIdentity . f a) z =<< V.thaw v)+      `eq`+      foldrM+    prop_mut_foldrM' :: P ((a -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.foldrM' (\a b -> pure $ runIdentity $ f a b) z =<< V.thaw v)+      `eq`+      foldrM++    prop_mut_read = \xs ->+      not (V.null xs) ==>+      forAll (choose (0, V.length xs-1)) $ \i ->+      unP prop xs i+      where+        prop :: P (v a -> Int -> a) = (\v i -> runST $ do mv <- V.thaw v+                                                          MV.read mv i+                                      ) `eq` (!!)+    prop_mut_write = \xs ->+      not (V.null xs) ==>+      forAll (choose (0, V.length xs-1)) $ \i ->+      unP prop xs i+      where+        prop :: P (v a -> Int -> a -> v a) = (\v i a -> runST $ do mv <- V.thaw v+                                                                   MV.write mv i a+                                                                   V.freeze mv+                                             ) `eq` writeList+    prop_mut_modify = \xs f ->+      not (V.null xs) ==>+      forAll (choose (0, V.length xs-1)) $ \i ->+      unP prop xs f i+      where+        prop :: P (v a -> (a -> a) -> Int -> v a)+          = (\v f i -> runST $ do mv <- V.thaw v+                                  MV.modify mv f i+                                  V.freeze mv+            ) `eq` modifyList++++    prop_mut_generate :: P (Int -> (Int -> a) -> v a)+      = (\n _ -> n < 1000) ===> (\n f -> runST $ V.freeze =<< MV.generate n f)+      `eq` Util.generate+    prop_mut_generateM :: P (Int -> (Int -> Writer [a] a) -> Writer [a] (v a))+      = (\n _ -> n < 1000) ===> (\n f -> liftRunST $ V.freeze =<< MV.generateM n (hoistST . f))+      `eq` Util.generateM++    prop_mut_ifoldM :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.ifoldM (\b i -> pure . runIdentity . f b i) z =<< V.thaw v)+      `eq` ifoldM+    prop_mut_ifoldM' :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.ifoldM' (\b i -> pure . runIdentity . f b i) z =<< V.thaw v)+      `eq` ifoldM+    prop_mut_ifoldrM :: P ((Int -> a -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.ifoldrM (\i b -> pure . runIdentity . f i b) z =<< V.thaw v)+      `eq`+      ifoldrM+    prop_mut_ifoldrM' :: P ((Int -> a -> a -> Identity a) -> a -> v a -> Identity a)+      = (\f z v -> Identity $ runST $ MV.ifoldrM' (\i b -> pure . runIdentity . f i b) z =<< V.thaw v)+      `eq`+      ifoldrM++    prop_mut_forM_ :: P (v a -> (a -> Writer [a] ()) -> Writer [a] ())+      = (\v f -> liftRunST $ do mv <- V.thaw v+                                MV.forM_ mv (hoistST . f))+      `eq` flip mapM_+    prop_mut_iforM_ :: P (v a -> (Int -> a -> Writer [a] ()) -> Writer [a] ())+      = (\v f -> liftRunST $ do mv <- V.thaw v+                                MV.iforM_ mv (\i x -> hoistST $ f i x))+      `eq` flip imapM_+    prop_mut_mapM_ :: P ((a -> Writer [a] ()) -> v a -> Writer [a] ())+      = (\f v -> liftRunST $ MV.mapM_ (hoistST . f) =<< V.thaw v) `eq` mapM_+    prop_mut_imapM_ :: P ((Int -> a -> Writer [a] ()) -> v a -> Writer [a] ())+      = (\f v -> liftRunST $ MV.imapM_ (\i x -> hoistST $ f i x) =<< V.thaw v) `eq` imapM_+++liftRunST :: (forall s. WriterT w (ST s) a) -> Writer w a+liftRunST m = WriterT $ Identity $ runST $ runWriterT m++hoistST :: Writer w a -> WriterT w (ST s) a+hoistST = WriterT . pure . runWriter++-- copied from GHC source code+partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])+partitionWith _ [] = ([],[])+partitionWith f (x:xs) = case f x of+                         Left  b -> (b:bs, cs)+                         Right c -> (bs, c:cs)+    where (bs,cs) = partitionWith f xs++testTuplyFunctions+  :: forall a v. ( CommonContext a v+                 , VectorContext (a, a)    v+                 , VectorContext (a, a, a) v+                 , VectorContext (Int, a)  v+                 )+  => v a -> [Test]+{-# INLINE testTuplyFunctions #-}+testTuplyFunctions _ = $(testProperties [ 'prop_zip, 'prop_zip3+                                        , 'prop_unzip, 'prop_unzip3+                                        , 'prop_indexed+                                        , 'prop_update+                                        ])+  where+    prop_zip     :: P (v a -> v a -> v (a, a))           = V.zip `eq` zip+    prop_zip3    :: P (v a -> v a -> v a -> v (a, a, a)) = V.zip3 `eq` zip3+    prop_unzip   :: P (v (a, a) -> (v a, v a))           = V.unzip `eq` unzip+    prop_unzip3  :: P (v (a, a, a) -> (v a, v a, v a))   = V.unzip3 `eq` unzip3+    prop_indexed :: P (v a -> v (Int, a))                = V.indexed `eq` (\xs -> [0..] `zip` xs)+    prop_update = \xs ->+      forAll (index_value_pairs (V.length xs)) $ \ps ->+      unP prop xs ps+      where+        prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//)++testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [Test]+{-# INLINE testOrdFunctions #-}+testOrdFunctions _ = $(testProperties+  ['prop_compare,+   'prop_maximum, 'prop_minimum,+   'prop_minIndex, 'prop_maxIndex,+   'prop_maximumBy, 'prop_minimumBy,+   'prop_maxIndexBy, 'prop_minIndexBy,+   'prop_ListLastMaxIndexWins, 'prop_FalseListFirstMaxIndexWins ])+  where+    prop_compare :: P (v a -> v a -> Ordering) = compare `eq` compare+    prop_maximum :: P (v a -> a) = not . V.null ===> V.maximum `eq` maximum+    prop_minimum :: P (v a -> a) = not . V.null ===> V.minimum `eq` minimum+    prop_minIndex :: P (v a -> Int) = not . V.null ===> V.minIndex `eq` minIndex+    prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` listMaxIndexFMW+    prop_maximumBy :: P (v a -> a) =+      not . V.null ===> V.maximumBy compare `eq` maximum+    prop_minimumBy :: P (v a -> a) =+      not . V.null ===> V.minimumBy compare `eq` minimum+    prop_maxIndexBy :: P (v a -> Int) =+      not . V.null ===> V.maxIndexBy compare `eq`  listMaxIndexFMW+                                          ---   (maxIndex)+    prop_ListLastMaxIndexWins ::  P (v a -> Int) =+        not . V.null ===> ( maxIndex . V.toList) `eq` listMaxIndexLMW+    prop_FalseListFirstMaxIndexWinsDesc ::  P (v a -> Int) =+        (\x -> not $ V.null x && (V.uniq x /= x ) )===> ( maxIndex . V.toList) `eq` listMaxIndexFMW+    prop_FalseListFirstMaxIndexWins :: Property+    prop_FalseListFirstMaxIndexWins = expectFailure prop_FalseListFirstMaxIndexWinsDesc+    prop_minIndexBy :: P (v a -> Int) =+      not . V.null ===> V.minIndexBy compare `eq` minIndex++listMaxIndexFMW :: Ord a => [a] -> Int+listMaxIndexFMW  = ( fst  . extractFMW .  sconcat . DLE.fromList . fmap FMW . zip [0 :: Int ..])++listMaxIndexLMW :: Ord a => [a] -> Int+listMaxIndexLMW = ( fst  . extractLMW .  sconcat . DLE.fromList . fmap LMW . zip [0 :: Int ..])++newtype LastMaxWith a i = LMW {extractLMW:: (i,a)}+    deriving(Eq,Show,Read)+instance (Ord a) => Semigroup  (LastMaxWith a i)   where+    (<>) x y | snd (extractLMW x) > snd (extractLMW y) = x+             | snd (extractLMW x) < snd (extractLMW y) = y+             | otherwise = y+newtype FirstMaxWith a i = FMW {extractFMW:: (i,a)}+    deriving(Eq,Show,Read)+instance (Ord a) => Semigroup  (FirstMaxWith a i)   where+    (<>) x y | snd (extractFMW x) > snd (extractFMW y) = x+             | snd (extractFMW x) < snd (extractFMW y) = y+             | otherwise = x+++testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [Test]+{-# INLINE testEnumFunctions #-}+testEnumFunctions _ = $(testProperties+  [ 'prop_enumFromN, 'prop_enumFromThenN,+    'prop_enumFromTo, 'prop_enumFromThenTo])+  where+    prop_enumFromN :: P (a -> Int -> v a)+      = (\_ n -> n < 1000)+        ===> V.enumFromN `eq` (\x n -> take n $ scanl (+) x $ repeat 1)++    prop_enumFromThenN :: P (a -> a -> Int -> v a)+      = (\_ _ n -> n < 1000)+        ===> V.enumFromStepN `eq` (\x y n -> take n $ scanl (+) x $ repeat y)++    prop_enumFromTo = \m ->+                      forAll (choose (-2,100)) $ \n ->+                      unP prop m (m+n)+      where+        prop  :: P (a -> a -> v a) = V.enumFromTo `eq` enumFromTo++    prop_enumFromThenTo = \i j ->+                          j /= i ==>+                          forAll (choose (ks i j)) $ \k ->+                          unP prop i j k+      where+        prop :: P (a -> a -> a -> v a) = V.enumFromThenTo `eq` enumFromThenTo++        ks i j | j < i     = (i-d*100, i+d*2)+               | otherwise = (i-d*2, i+d*100)+          where+            d = abs (j-i)++testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [Test]+{-# INLINE testMonoidFunctions #-}+testMonoidFunctions _ = $(testProperties+  [ 'prop_mempty, 'prop_mappend, 'prop_mconcat ])+  where+    prop_mempty  :: P (v a)               = mempty `eq` mempty+    prop_mappend :: P (v a -> v a -> v a) = mappend `eq` mappend+    prop_mconcat :: P ([v a] -> v a)      = mconcat `eq` mconcat++testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [Test]+{-# INLINE testFunctorFunctions #-}+testFunctorFunctions _ = $(testProperties+  [ 'prop_fmap ])+  where+    prop_fmap :: P ((a -> a) -> v a -> v a) = fmap `eq` fmap++testMonadFunctions :: forall a v. (CommonContext a v, VectorContext (a, a) v, MonadZip v) => v a -> [Test]+{-# INLINE testMonadFunctions #-}+testMonadFunctions _ = $(testProperties [ 'prop_return, 'prop_bind+                                        , 'prop_mzip, 'prop_munzip+                                        ])+  where+    prop_return :: P (a -> v a) = return `eq` return+    prop_bind   :: P (v a -> (a -> v a) -> v a) = (>>=) `eq` (>>=)+    prop_mzip   :: P (v a -> v a -> v (a, a)) = mzip `eq` zip+    prop_munzip :: P (v (a, a) -> (v a, v a)) = munzip `eq` unzip++testSequenceFunctions+  :: forall a v. ( CommonContext a v+                 , Model (v (Writer [a] a)) ~ [Writer [a] a]+                 , V.Vector v (Writer [a] a)+                 , Arbitrary (v (Writer [a] a))+                 , Show      (v (Writer [a] a))+                 , TestData  (v (Writer [a] a))+                 )+  => v a -> [Test]+testSequenceFunctions _ = $(testProperties [ 'prop_sequence, 'prop_sequence_+                                           ])+  where+    prop_sequence :: P (v (Writer [a] a) -> Writer [a] (v a))+      = V.sequence `eq` sequence+    prop_sequence_ :: P (v (Writer [a] a) -> Writer [a] ())+      = V.sequence_ `eq` sequence_++testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [Test]+{-# INLINE testApplicativeFunctions #-}+testApplicativeFunctions _ = $(testProperties+  [ 'prop_applicative_pure, 'prop_applicative_appl ])+  where+    prop_applicative_pure :: P (a -> v a)+      = Applicative.pure `eq` Applicative.pure+    prop_applicative_appl :: [a -> a] -> P (v a -> v a)+      = \fs -> (Applicative.<*>) (V.fromList fs) `eq` (Applicative.<*>) fs++testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [Test]+{-# INLINE testAlternativeFunctions #-}+testAlternativeFunctions _ = $(testProperties+  [ 'prop_alternative_empty, 'prop_alternative_or ])+  where+    prop_alternative_empty :: P (v a) = Applicative.empty `eq` Applicative.empty+    prop_alternative_or :: P (v a -> v a -> v a)+      = (Applicative.<|>) `eq` (Applicative.<|>)++testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [Test]+{-# INLINE testBoolFunctions #-}+testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or])+  where+    prop_and :: P (v Bool -> Bool) = V.and `eq` and+    prop_or  :: P (v Bool -> Bool) = V.or `eq` or++testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [Test]+{-# INLINE testNumFunctions #-}+testNumFunctions _ = $(testProperties ['prop_sum, 'prop_product])+  where+    prop_sum     :: P (v a -> a) = V.sum `eq` sum+    prop_product :: P (v a -> a) = V.product `eq` product++testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [Test]+{-# INLINE testNestedVectorFunctions #-}+testNestedVectorFunctions _ = $(testProperties+  [ 'prop_concat+  ])+  where+    prop_concat :: P ([v a] -> v a) = V.concat `eq` concat++testDataFunctions :: forall a v. (CommonContext a v, Data a, Data (v a)) => v a -> [Test]+{-# INLINE testDataFunctions #-}+testDataFunctions _ = $(testProperties ['prop_glength])+  where+    prop_glength :: P (v a -> Int) = glength `eq` glength+      where+        glength :: Data b => b -> Int+        glength xs = gmapQl (+) 0 toA xs++        toA :: Data b => b -> Int+        toA x = maybe (glength x) (const 1) (cast x :: Maybe a)
+ tests/Tests/Vector/UnitTests.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Tests.Vector.UnitTests (tests) where++import Control.Applicative as Applicative+import Control.Exception+import Control.Monad.Primitive+import Control.Monad.Fix (mfix)+import Data.Int+import Data.Word+import Data.Typeable+import qualified Data.List as List+import qualified Data.Vector.Generic  as Generic+import qualified Data.Strict.Vector as Boxed+import qualified Data.Strict.Vector.Autogen.Mutable as MBoxed+import qualified Data.Vector.Primitive as Primitive+import qualified Data.Vector.Storable as Storable+import qualified Data.Vector.Unboxed as Unboxed+import Foreign.Ptr+import Foreign.Storable+import Text.Printf++import Test.Tasty+import Test.Tasty.HUnit (testCase, Assertion, assertBool, assertEqual, (@=?), assertFailure)+++newtype Aligned a = Aligned { getAligned :: a }++instance (Storable a) => Storable (Aligned a) where+  sizeOf _    = sizeOf (undefined :: a)+  alignment _ = 128+  peek ptr    = Aligned Applicative.<$> peek (castPtr ptr)+  poke ptr    = poke (castPtr ptr) . getAligned++checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion+checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do+  let ptr'  = ptrToWordPtr ptr+      msg   = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr')+      align :: WordPtr+      align = fromIntegral $ alignment dummy+  assertBool msg $ (ptr' `mod` align) == 0+  where+    dummy :: a+    dummy = undefined++tests :: [TestTree]+tests =+  [ testGroup "Data.Vector.Storable.Vector Alignment"+      [ testCase "Aligned Double" $+          checkAddressAlignment alignedDoubleVec+      , testCase "Aligned Int" $+          checkAddressAlignment alignedIntVec+      ]+  , testGroup "Regression tests"+    [ testGroup "enumFromTo crash #188"+      [ regression188 ([] :: [Word8])+      , regression188 ([] :: [Word16])+      , regression188 ([] :: [Word32])+      , regression188 ([] :: [Word64])+      , regression188 ([] :: [Word])+      , regression188 ([] :: [Int8])+      , regression188 ([] :: [Int16])+      , regression188 ([] :: [Int32])+      , regression188 ([] :: [Int64])+      , regression188 ([] :: [Int])+      , regression188 ([] :: [Char])+      ]+    ]+  , testGroup "Negative tests"+    [ testGroup "slice out of bounds #257"+      [ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice+      , testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice+      , testGroup "Storable" $ testsSliceOutOfBounds Storable.slice+      , testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice+      ]+    , testGroup "take #282"+      [ testCase "Boxed" $ testTakeOutOfMemory Boxed.take+      , testCase "Primitive" $ testTakeOutOfMemory Primitive.take+      , testCase "Storable" $ testTakeOutOfMemory Storable.take+      , testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take+      ]+    ]+  , testGroup "Data.Vector"+    [ testCase "MonadFix" checkMonadFix+    , testCase "toFromArray" toFromArray+    , testCase "toFromMutableArray" toFromMutableArray+    ]+  ]++testsSliceOutOfBounds ::+     (Show (v Int), Generic.Vector v Int) => (Int -> Int -> v Int -> v Int) -> [TestTree]+testsSliceOutOfBounds sliceWith =+  [ testCase "Negative ix" $ sliceTest sliceWith (-2) 2 xs+  , testCase "Negative size" $ sliceTest sliceWith 2 (-2) xs+  , testCase "Negative ix and size" $ sliceTest sliceWith (-2) (-1) xs+  , testCase "Too large ix" $ sliceTest sliceWith 6 2 xs+  , testCase "Too large size" $ sliceTest sliceWith 2 6 xs+  , testCase "Too large ix and size" $ sliceTest sliceWith 6 6 xs+  , testCase "Overflow" $ sliceTest sliceWith 1 maxBound xs+  , testCase "OutOfMemory" $ sliceTest sliceWith 1 (maxBound `div` intSize) xs+  ]+  where+    intSize = sizeOf (undefined :: Int)+    xs = [1, 2, 3, 4, 5] :: [Int]+{-# INLINE testsSliceOutOfBounds #-}++sliceTest ::+     (Show (v Int), Generic.Vector v Int)+  => (Int -> Int -> v Int -> v Int)+  -> Int+  -> Int+  -> [Int]+  -> Assertion+sliceTest sliceWith i m xs = do+  let vec = Generic.fromList xs+  eRes <- try (pure $! sliceWith i m vec)+  case eRes of+    Right v ->+      assertFailure $+      "Data.Vector.Internal.Check.checkSlice failed to check: " ++ show v+    Left (ErrorCall err) ->+      let assertMsg =+            List.concat+              [ "Expected slice function to produce an 'error' ending with: \""+              , errSuffix+              , "\" instead got: \""+              , err+              ]+       in assertBool assertMsg (errSuffix `List.isSuffixOf` err)+  where+    errSuffix =+      "(slice): invalid slice (" +++      show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")"+{-# INLINE sliceTest #-}++testTakeOutOfMemory ::+     (Show (v Int), Eq (v Int), Generic.Vector v Int) => (Int -> v Int -> v Int) -> Assertion+testTakeOutOfMemory takeWith =+  takeWith (maxBound `div` intSize) (Generic.fromList xs) @=? Generic.fromList xs+  where+    intSize = sizeOf (undefined :: Int)+    xs = [1, 2, 3, 4, 5] :: [Int]+{-# INLINE testTakeOutOfMemory #-}++regression188+  :: forall proxy a. (Typeable a, Enum a, Bounded a, Eq a, Show a)+  => proxy a -> TestTree+regression188 _ = testCase (show (typeOf (undefined :: a)))+  $ Boxed.fromList [maxBound::a] @=? Boxed.enumFromTo maxBound maxBound+{-# INLINE regression188 #-}++alignedDoubleVec :: Storable.Vector (Aligned Double)+alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]++alignedIntVec :: Storable.Vector (Aligned Int)+alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]++#if __GLASGOW_HASKELL__ >= 800+-- Ensure that Mutable is really an injective type family by typechecking a+-- function which relies on injectivity.+_f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f)+   => Generic.Mutable v (PrimState f) a -> f (w a)+_f v = Generic.convert `fmap` Generic.unsafeFreeze v+#endif++checkMonadFix :: Assertion+checkMonadFix = assertBool "checkMonadFix" $+    Boxed.toList fewV == fewL &&+    Boxed.toList none == []+  where+    facty _ 0 = 1; facty f n = n * f (n - 1)+    fewV :: Boxed.Vector Int+    fewV = fmap ($ 12) $ mfix (\i -> Boxed.fromList [facty i, facty (+1), facty (+2)])+    fewL :: [Int]+    fewL = fmap ($ 12) $ mfix (\i -> [facty i, facty (+1), facty (+2)])+    none :: Boxed.Vector Int+    none = mfix (const Boxed.empty)++mkArrayRoundtrip :: (String -> Boxed.Vector Integer -> Assertion) -> Assertion+mkArrayRoundtrip mkAssertion =+  sequence_+    [ mkAssertion name v+    | (name, v) <-+        [ ("full", vec)+        , ("slicedTail", Boxed.slice 0 (n - 3) vec)+        , ("slicedHead", Boxed.slice 2 (n - 2) vec)+        , ("slicedBoth", Boxed.slice 2 (n - 4) vec)+        ]+    ]+  where+    vec = Boxed.fromList [0 .. 10]+    n = Boxed.length vec++toFromArray :: Assertion+toFromArray =+  mkArrayRoundtrip $ \name v ->+    assertEqual name v $ Boxed.fromArray (Boxed.toArray v)++toFromMutableArray :: Assertion+toFromMutableArray = mkArrayRoundtrip assetRoundtrip+  where+    assetRoundtrip assertionName vec = do+      mvec <- Boxed.unsafeThaw vec+      mvec' <- MBoxed.fromMutableArray =<< MBoxed.toMutableArray mvec+      vec' <- Boxed.unsafeFreeze mvec'+      assertEqual assertionName vec vec'
+ tests/Utilities.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE FlexibleInstances, GADTs #-}+module Utilities where++import Test.QuickCheck++import Data.Foldable+import qualified Data.Strict.Vector as DV+import qualified Data.Vector.Generic as DVG+import qualified Data.Vector.Primitive as DVP+import qualified Data.Vector.Storable as DVS+import qualified Data.Vector.Unboxed as DVU+import qualified Data.Vector.Fusion.Bundle as S++import Control.Monad (foldM, foldM_, zipWithM, zipWithM_)+import Control.Monad.Trans.Writer+import Data.Function (on)+import Data.Functor.Identity+import Data.List ( sortBy )+import Data.Monoid+import Data.Maybe (catMaybes)++instance Show a => Show (S.Bundle v a) where+    show s = "Data.Vector.Fusion.Bundle.fromList " ++ show (S.toList s)+++instance Arbitrary a => Arbitrary (DV.Vector a) where+    arbitrary = fmap DV.fromList arbitrary++instance CoArbitrary a => CoArbitrary (DV.Vector a) where+    coarbitrary = coarbitrary . DV.toList++instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where+    arbitrary = fmap DVP.fromList arbitrary++instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where+    coarbitrary = coarbitrary . DVP.toList++instance (Arbitrary a, DVS.Storable a) => Arbitrary (DVS.Vector a) where+    arbitrary = fmap DVS.fromList arbitrary++instance (CoArbitrary a, DVS.Storable a) => CoArbitrary (DVS.Vector a) where+    coarbitrary = coarbitrary . DVS.toList++instance (Arbitrary a, DVU.Unbox a) => Arbitrary (DVU.Vector a) where+    arbitrary = fmap DVU.fromList arbitrary++instance (CoArbitrary a, DVU.Unbox a) => CoArbitrary (DVU.Vector a) where+    coarbitrary = coarbitrary . DVU.toList++instance Arbitrary a => Arbitrary (S.Bundle v a) where+    arbitrary = fmap S.fromList arbitrary++instance CoArbitrary a => CoArbitrary (S.Bundle v a) where+    coarbitrary = coarbitrary . S.toList++instance (Arbitrary a, Arbitrary b) => Arbitrary (Writer a b) where+    arbitrary = do b <- arbitrary+                   a <- arbitrary+                   return $ writer (b,a)++instance CoArbitrary a => CoArbitrary (Writer a ()) where+    coarbitrary = coarbitrary . runWriter++class (Testable (EqTest a), Conclusion (EqTest a)) => TestData a where+  type Model a+  model :: a -> Model a+  unmodel :: Model a -> a++  type EqTest a+  equal :: a -> a -> EqTest a++instance (Eq a, TestData a) => TestData (S.Bundle v a) where+  type Model (S.Bundle v a) = [Model a]+  model   = map model  . S.toList+  unmodel = S.fromList . map unmodel++  type EqTest (S.Bundle v a) = Property+  equal x y = property (x == y)++instance (Eq a, TestData a) => TestData (DV.Vector a) where+  type Model (DV.Vector a) = [Model a]+  model   = map model    . DV.toList+  unmodel = DV.fromList . map unmodel++  type EqTest (DV.Vector a) = Property+  equal x y = property (x == y)++instance (Eq a, DVP.Prim a, TestData a) => TestData (DVP.Vector a) where+  type Model (DVP.Vector a) = [Model a]+  model   = map model    . DVP.toList+  unmodel = DVP.fromList . map unmodel++  type EqTest (DVP.Vector a) = Property+  equal x y = property (x == y)++instance (Eq a, DVS.Storable a, TestData a) => TestData (DVS.Vector a) where+  type Model (DVS.Vector a) = [Model a]+  model   = map model    . DVS.toList+  unmodel = DVS.fromList . map unmodel++  type EqTest (DVS.Vector a) = Property+  equal x y = property (x == y)++instance (Eq a, DVU.Unbox a, TestData a) => TestData (DVU.Vector a) where+  type Model (DVU.Vector a) = [Model a]+  model   = map model    . DVU.toList+  unmodel = DVU.fromList . map unmodel++  type EqTest (DVU.Vector a) = Property+  equal x y = property (x == y)++#define id_TestData(ty) \+instance TestData ty where { \+  type Model ty = ty;        \+  model = id;                \+  unmodel = id;              \+                             \+  type EqTest ty = Property; \+  equal x y = property (x == y) }++id_TestData(())+id_TestData(Bool)+id_TestData(Int)+id_TestData(Float)+id_TestData(Double)+id_TestData(Ordering)++bimapEither :: (a -> b) -> (c -> d) -> Either a c -> Either b d+bimapEither f _ (Left a) = Left (f a)+bimapEither _ g (Right c) = Right (g c)++-- Functorish models+-- All of these need UndecidableInstances although they are actually well founded. Oh well.+instance (Eq a, TestData a) => TestData (Maybe a) where+  type Model (Maybe a) = Maybe (Model a)+  model = fmap model+  unmodel = fmap unmodel++  type EqTest (Maybe a) = Property+  equal x y = property (x == y)++instance (Eq a, TestData a, Eq b, TestData b) => TestData (Either a b) where+  type Model (Either a b) = Either (Model a) (Model b)+  model = bimapEither model model+  unmodel = bimapEither unmodel unmodel++  type EqTest (Either a b) = Property+  equal x y = property (x == y)++instance (Eq a, TestData a) => TestData [a] where+  type Model [a] = [Model a]+  model = fmap model+  unmodel = fmap unmodel++  type EqTest [a] = Property+  equal x y = property (x == y)++instance (Eq a, TestData a) => TestData (Identity a) where+  type Model (Identity a) = Identity (Model a)+  model = fmap model+  unmodel = fmap unmodel++  type EqTest (Identity a) = Property+  equal = (property .) . on (==) runIdentity++instance (Eq a, TestData a, Eq b, TestData b, Monoid a) => TestData (Writer a b) where+  type Model (Writer a b) = Writer (Model a) (Model b)+  model = mapWriter model+  unmodel = mapWriter unmodel++  type EqTest (Writer a b) = Property+  equal = (property .) . on (==) runWriter++instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where+  type Model (a,b) = (Model a, Model b)+  model (a,b) = (model a, model b)+  unmodel (a,b) = (unmodel a, unmodel b)++  type EqTest (a,b) = Property+  equal x y = property (x == y)++instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where+  type Model (a,b,c) = (Model a, Model b, Model c)+  model (a,b,c) = (model a, model b, model c)+  unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c)++  type EqTest (a,b,c) = Property+  equal x y = property (x == y)++instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where+  type Model (a -> b) = Model a -> Model b+  model f = model . f . unmodel+  unmodel f = unmodel . f . model++  type EqTest (a -> b) = a -> EqTest b+  equal f g x = equal (f x) (g x)++newtype P a = P { unP :: EqTest a }++instance TestData a => Testable (P a) where+  property (P a) = property a++infix 4 `eq`+eq :: TestData a => a -> Model a -> P a+eq x y = P (equal x (unmodel y))++class Conclusion p where+  type Predicate p++  predicate :: Predicate p -> p -> p++instance Conclusion Property where+  type Predicate Property = Bool++  predicate = (==>)++instance Conclusion p => Conclusion (a -> p) where+  type Predicate (a -> p) = a -> Predicate p++  predicate f p = \x -> predicate (f x) (p x)++infixr 0 ===>+(===>) :: TestData a => Predicate (EqTest a) -> P a -> P a+p ===> P a = P (predicate p a)++notNull2 _ xs = not $ DVG.null xs+notNullS2 _ s = not $ S.null s++-- Generators+index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)]+index_value_pairs 0 = return []+index_value_pairs m = sized $ \n ->+  do+    len <- choose (0,n)+    is <- sequence [choose (0,m-1) | _i <- [1..len]]+    xs <- vector len+    return $ zip is xs++indices :: Int -> Gen [Int]+indices 0 = return []+indices m = sized $ \n ->+  do+    len <- choose (0,n)+    sequence [choose (0,m-1) | _i <- [1..len]]+++-- Additional list functions+singleton x = [x]+snoc xs x = xs ++ [x]+generate n f = [f i | i <- [0 .. n-1]]+generateM n f = sequence [f i | i <- [0 .. n-1]]+slice i n xs = take n (drop i xs)+backpermute xs is = map (xs!!) is+prescanl f z = init . scanl f z+postscanl f z = tail . scanl f z+prescanr f z = tail . scanr f z+postscanr f z = init . scanr f z++accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a]+accum f xs ps = go xs ps' 0+  where+    ps' = sortBy (\p q -> compare (fst p) (fst q)) ps++    go (x:xxs) ((i,y) : pps) j+      | i == j     = go (f x y : xxs) pps j+    go (x:xxs) pps j = x : go xxs pps (j+1)+    go [] _ _      = []++(//) :: [a] -> [(Int, a)] -> [a]+xs // ps = go xs ps' 0+  where+    ps' = sortBy (\p q -> compare (fst p) (fst q)) ps++    go (_x:xxs) ((i,y) : pps) j+      | i == j     = go (y:xxs) pps j+    go (x:xxs) pps j = x : go xxs pps (j+1)+    go [] _ _      = []+++withIndexFirst m f = m (uncurry f) . zip [0..]++modifyList :: [a] -> (a -> a) -> Int -> [a]+modifyList xs f i = zipWith merge xs (replicate i Nothing ++ [Just f] ++ repeat Nothing)+  where+    merge x Nothing  = x+    merge x (Just g) = g x++writeList :: [a] -> Int -> a -> [a]+writeList xs i a = modifyList xs (const a) i++imap :: (Int -> a -> a) -> [a] -> [a]+imap = withIndexFirst map++imapM :: Monad m => (Int -> a -> m a) -> [a] -> m [a]+imapM = withIndexFirst mapM++imapM_ :: Monad m => (Int -> a -> m b) -> [a] -> m ()+imapM_ = withIndexFirst mapM_++izipWith :: (Int -> a -> a -> a) -> [a] -> [a] -> [a]+izipWith = withIndexFirst zipWith++izipWithM :: Monad m => (Int -> a -> a -> m a) -> [a] -> [a] -> m [a]+izipWithM = withIndexFirst zipWithM++izipWithM_ :: Monad m => (Int -> a -> a -> m b) -> [a] -> [a] -> m ()+izipWithM_ = withIndexFirst zipWithM_++izipWith3 :: (Int -> a -> a -> a -> a) -> [a] -> [a] -> [a] -> [a]+izipWith3 = withIndexFirst zipWith3++ifilter :: (Int -> a -> Bool) -> [a] -> [a]+ifilter f = map snd . withIndexFirst filter f++mapMaybe :: (a -> Maybe b) -> [a] -> [b]+mapMaybe f = catMaybes . map f++imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b]+imapMaybe f = catMaybes . withIndexFirst map f++indexedLeftFold fld f z = fld (uncurry . f) z . zip [0..]++ifoldl :: (a -> Int -> a -> a) -> a -> [a] -> a+ifoldl = indexedLeftFold foldl++iscanl :: (Int -> a -> b -> a) -> a -> [b] -> [a]+iscanl f z = scanl (\a (i, b) -> f i a b) z . zip [0..]++iscanr :: (Int -> a -> b -> b) -> b -> [a] -> [b]+iscanr f z = scanr (uncurry f) z . zip [0..]++ifoldr :: (Int -> a -> b -> b) -> b -> [a] -> b+ifoldr f z = foldr (uncurry f) z . zip [0..]++ifoldM :: Monad m => (b -> Int -> a -> m b) -> b -> [a] -> m b+ifoldM = indexedLeftFold foldM++ifoldrM :: Monad m => (Int -> a -> b -> m b) -> b -> [a] -> m b+ifoldrM f z xs = foldrM (\(i,a) b -> f i a b) z ([0..] `zip` xs)++ifoldM_ :: Monad m => (b -> Int -> a -> m b) -> b -> [a] -> m ()+ifoldM_ = indexedLeftFold foldM_++minIndex :: Ord a => [a] -> Int+minIndex = fst . foldr1 imin . zip [0..]+  where+    imin (i,x) (j,y) | x <= y    = (i,x)+                     | otherwise = (j,y)++maxIndex :: Ord a => [a] -> Int+maxIndex = fst . foldr1 imax . zip [0..]+  where+    imax (i,x) (j,y) | x >  y    = (i,x)+                     | otherwise = (j,y)++iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a]+iterateNM n f x+    | n <= 0    = return []+    | n == 1    = return [x]+    | otherwise =  do x' <- f x+                      xs <- iterateNM (n-1) f x'+                      return (x : xs)++unfoldrM :: Monad m => (b -> m (Maybe (a,b))) -> b -> m [a]+unfoldrM step b0 = do+    r <- step b0+    case r of+      Nothing    -> return []+      Just (a,b) -> do as <- unfoldrM step b+                       return (a : as)+++limitUnfolds f (theirs, ours)+    | ours >= 0+    , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1))+    | otherwise                       = Nothing
+ tests/Utils/IsUnit.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif++module Utils.IsUnit (isUnit, isUnitSupported) where++#ifdef __GLASGOW_HASKELL__+import GHC.Exts+#endif++-- | Check whether the argument is a fully evaluated unit `()`.+--+-- Always returns `False` is `isUnitSupported` returns `False`.+--+-- Uses `reallyUnsafePtrEquality#`.+isUnit :: () -> Bool++-- | Checks whether `isUnit` is supported by the Haskell implementation.+--+-- Currently returns `True` for ghc and `False` for all other implementations.+isUnitSupported :: Bool++#ifdef __GLASGOW_HASKELL__++-- simplified from  Utils.Containers.Internal.PtrEquality+ptrEq :: a -> a -> Bool+ptrEq x y = case reallyUnsafePtrEquality# x y of+    0# -> False+    _  -> True++isUnit = ptrEq ()++isUnitSupported = True++#else /* !__GLASGOW_HASKELL__ */++isUnit = False++isUnitSupported = False++#endif
+ tests/VectorMain.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import qualified Tests.Vector+import qualified Tests.Vector.UnitTests+import qualified Tests.Bundle+import qualified Tests.Move++import Test.Tasty (defaultMain,testGroup)++main :: IO ()+main = defaultMain $ testGroup "toplevel" $ Tests.Bundle.tests+                  ++ Tests.Vector.tests+                  ++ Tests.Vector.UnitTests.tests+                  ++ Tests.Move.tests+
+ tests/intmap-properties.hs view
@@ -0,0 +1,1622 @@+{-# LANGUAGE CPP #-}++#ifdef STRICT+import Data.Strict.IntMap.Autogen.Strict as Data.Strict.IntMap.Autogen hiding (showTree)+import Data.Strict.IntMap.Autogen.Strict.Internal (traverseMaybeWithKey)+import Data.Strict.IntMap.Autogen.Merge.Strict+#else+import Data.Strict.IntMap.Autogen.Lazy as Data.Strict.IntMap.Autogen hiding (showTree)+import Data.Strict.IntMap.Autogen.Internal (traverseMaybeWithKey)+import Data.Strict.IntMap.Autogen.Merge.Lazy+#endif+import Data.Strict.IntMap.Autogen.Internal.Debug (showTree)+import IntMapValidity (valid)++import Control.Applicative (Applicative(..))+import Control.Monad ((<=<))+import Data.Monoid+import Data.Maybe hiding (mapMaybe)+import qualified Data.Maybe as Maybe (mapMaybe)+import Data.Ord+import Data.Foldable (foldMap)+import Data.Function+import Data.Traversable (Traversable(traverse), foldMapDefault)+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)+import Test.QuickCheck.Poly (A, B, C)++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+#if MIN_VERSION_base(4,8,0)+             , testCase "minimum" test_minimum+             , testCase "maximum" test_maximum+#endif+             , 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 "merge valid"          prop_merge_valid+             , testProperty "mergeA effects"       prop_mergeA_effects+             , 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 "disjoint"             prop_disjoint+             , testProperty "compose"              prop_compose+             , 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 "foldr==foldMap"       prop_foldrEqFoldMap+             , testProperty+                 "foldrWithKey==foldMapWithKey"+                 prop_foldrWithKeyEqFoldMapWithKey+             , testProperty+                 "prop_FoldableTraversableCompat"+                 prop_FoldableTraversableCompat+             , testProperty "keysSet"              prop_keysSet+             , testProperty "fromSet"              prop_fromSet+             , testProperty "restrictKeys"         prop_restrictKeys+             , testProperty "withoutKeys"          prop_withoutKeys+             , testProperty "traverseWithKey identity"              prop_traverseWithKey_identity+             , testProperty "traverseWithKey->mapWithKey"           prop_traverseWithKey_degrade_to_mapWithKey+             , testProperty "traverseMaybeWithKey identity"         prop_traverseMaybeWithKey_identity+             , testProperty "traverseMaybeWithKey->mapMaybeWithKey" prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey+             , testProperty "traverseMaybeWithKey->traverseWithKey" prop_traverseMaybeWithKey_degrade_to_traverseWithKey+             ]++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 = fmap fromList arbitrary++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 = do+    fromList [(5,'a'), (3,'b')] ! 5 @?= 'a'++    fromList [(5,'a'), (-3,'b')] ! (-3) @?= 'b'++test_index_lookup :: Assertion+test_index_lookup = do+    fromList [(5,'a'), (3,'b')] !? 1 @?= Nothing+    fromList [(5,'a'), (3,'b')] !? 5 @?= Just 'a'++    fromList [(5,'a'), (-3,'b')] !? 1 @?= Nothing+    fromList [(5,'a'), (-3,'b')] !? 5 @?= Just 'a'+    fromList [(5,'a'), (-3,'b')] !? (-3) @?= Just 'b'++----------------------------------------------------------------+-- Query++test_size :: Assertion+test_size = do+    null (empty)           @?= True+    null (singleton 1 'a') @?= False++    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++    size (fromList [(-2, '?'),(5,'a'), (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++    member 5    (fromList [(5,'a'), (-3,'b')]) @?= True+    member 1    (fromList [(5,'a'), (-3,'b')]) @?= False+    member (-3) (fromList [(5,'a'), (-3,'b')]) @?= True++test_notMember :: Assertion+test_notMember = do+    notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False+    notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True++    notMember 5    (fromList [(5,'a'), (-3,'b')]) @?= False+    notMember 1    (fromList [(5,'a'), (-3,'b')]) @?= True+    notMember (-3) (fromList [(5,'a'), (-3,'b')]) @?= False++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'++    findWithDefault 'x' 1    (fromList [(5,'a'), (-3,'b')]) @?= 'x'+    findWithDefault 'x' 5    (fromList [(5,'a'), (-3,'b')]) @?= 'a'+    findWithDefault 'x' (-3) (fromList [(5,'a'), (-3,'b')]) @?= 'b'++++test_lookupLT :: Assertion+test_lookupLT = do+    lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing+    lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')++    lookupLT (-3) (fromList [(5,'a'), (-3,'b')]) @?= Nothing+    lookupLT (-2) (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupLT 4    (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupLT 6    (fromList [(5,'a'), (-3,'b')]) @?= Just (5, '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++    lookupGT (-4) (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupGT (-3) (fromList [(5,'a'), (-3,'b')]) @?= Just (5, 'a')+    lookupGT 4    (fromList [(5,'a'), (-3,'b')]) @?= Just (5, 'a')+    lookupGT 5    (fromList [(5,'a'), (-3,'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')++    lookupLE (-4) (fromList [(5,'a'), (-3,'b')]) @?= Nothing+    lookupLE (-3) (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupLE 4    (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupLE 5    (fromList [(5,'a'), (-3,'b')]) @?= Just (5, 'a')+    lookupLE 6    (fromList [(5,'a'), (-3,'b')]) @?= Just (5, 'a')++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++    lookupGE (-4) (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupGE (-3) (fromList [(5,'a'), (-3,'b')]) @?= Just (-3, 'b')+    lookupGE (-2) (fromList [(5,'a'), (-3,'b')]) @?= Just (5, 'a')+    lookupGE 5    (fromList [(5,'a'), (-3,'b')]) @?= Just (5, 'a')+    lookupGE 6    (fromList [(5,'a'), (-3,'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++    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'++    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 (-3) 'x' empty                          @?= singleton (-3) 'x'+    insert (-3) 'x' (fromList [(5,'a'), (-3,'b')]) @?= fromList [(-3, 'x'), (5, 'a')]+    insert (-7) 'x' (fromList [(5,'a'), (-3,'b')]) @?= fromList [(-3, 'b'), (5, 'a'), (-7, '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"++    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 (++) (-3) "xxx" empty                          @?= singleton (-3) "xxx"+    insertWith (++) (-3) "xxx" (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "xxxb"), (5, "a")]+    insertWith (++) (-7) "xxx" (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a"), (-7, "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"++    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 (-3) "xxx" empty                          @?= singleton (-3) "xxx"+    insertWithKey f (-3) "xxx" (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "-3:xxx|b"), (5, "a")]+    insertWithKey f (-7) "xxx" (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a"), (-7, "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")++    insertLookupWithKey f 5 "xxx"    (fromList [(5,"a"), (-3,"b")]) @?= (Just "a", fromList [(-3, "b"), (5, "5:xxx|a")])+    insertLookupWithKey f 7 "xxx"    (fromList [(5,"a"), (-3,"b")]) @?= (Nothing,  fromList [(-3, "b"), (5, "a"), (7, "xxx")])+    insertLookupWithKey f (-3) "xxx" empty                          @?= (Nothing,  singleton (-3) "xxx")+    insertLookupWithKey f (-3) "xxx" (fromList [(5,"a"), (-3,"b")]) @?= (Just "b", fromList [(-3, "-3:xxx|b"), (5, "a")])+    insertLookupWithKey f (-7) "xxx" (fromList [(5,"a"), (-3,"b")]) @?= (Nothing,  fromList [(-3, "b"), (5, "a"), (-7, "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)++    delete 5    (fromList [(5,"a"), (-3,"b")]) @?= singleton (-3) "b"+    delete 7    (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a")]+    delete (-3) empty                          @?= (empty :: IMap)+    delete (-3) (fromList [(5,"a"), (-3,"b")]) @?= singleton 5 "a"+    delete (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a")]++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++    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 " ++) (-3) empty                          @?= empty+    adjust ("new " ++) (-3) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "new b"), (5, "a")]+    adjust ("new " ++) (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a")]++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++    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 (-3) empty                          @?= empty+    adjustWithKey f (-3) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "-3:new b"), (5, "a")]+    adjustWithKey f (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a")]+  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"++    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"+    update f (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (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"++    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"+    updateWithKey f (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (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")++    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")+    updateLookupWithKey f (-7) (fromList [(5,"a"), (-3,"b")]) @?= (Nothing,  fromList [(-3, "b"), (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")]++    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 f (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a")]+    alter f (-3) (fromList [(5,"a"), (-3,"b")]) @?= singleton (5) "a"+    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")]+    alter g (-7) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "b"), (5, "a"), (-7, "c")]+    alter g (-3) (fromList [(5,"a"), (-3,"b")]) @?= fromList [(-3, "c"), (5, "a")]+  where+    f _ = Nothing+    g _ = Just "c"++----------------------------------------------------------------+-- Combine++test_union :: Assertion+test_union = do+    union (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]+    union (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "a"), (7, "C")]++test_mappend :: Assertion+test_mappend = do+    mappend (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]+    mappend (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "a"), (7, "C")]++test_unionWith :: Assertion+test_unionWith = do+    unionWith (++) (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")]+    unionWith (++) (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "aA"), (7, "C")]++test_unionWithKey :: Assertion+test_unionWithKey = do+    unionWithKey f (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+    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")]++    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")]++    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 = do+    unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+        @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]+    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 = do+    difference (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b"+    difference (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton (-3) "b"++test_differenceWith :: Assertion+test_differenceWith = do+    differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+        @?= singleton 3 "b:B"+    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 = do+    differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+        @?= singleton 3 "3:b|B"+    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 = do+    intersection (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a"+    intersection (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a"+++test_intersectionWith :: Assertion+test_intersectionWith = do+    intersectionWith (++) (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA"+    intersectionWith (++) (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA"++test_intersectionWithKey :: Assertion+test_intersectionWithKey = do+    intersectionWithKey f (fromList [(5, "a"), (3, "b")])  (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A"+    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 = do+    map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")]+    map (++ "x") (fromList [(5,"a"), (3,"b"), (-1,"c")])+            @?= fromList [(3, "bx"), (5, "ax"), (-1,"cx")]++test_mapWithKey :: Assertion+test_mapWithKey = do+    mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")]+    mapWithKey f (fromList [(5,"a"), (3,"b"), (-1,"c")])+            @?= fromList [(3, "3:b"), (5, "5:a"), (-1,"-1:c")]+  where+    f key x = (show key) ++ ":" ++ x++test_mapAccum :: Assertion+test_mapAccum = do+    mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")])+    mapAccum f "Everything: " (fromList [(5,"a"), (3,"b"), (-1,"c")])+        @?= ("Everything: cba", fromList [(3, "bX"), (5, "aX"), (-1, "cX")])+  where+    f a b = (a ++ b, b ++ "X")++test_mapAccumWithKey :: Assertion+test_mapAccumWithKey = do+    mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])+    mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b"), (-1,"c")])+        @?= ("Everything: -1-c 3-b 5-a", fromList [(3, "bX"), (5, "aX"), (-1,"cX")])+  where+    f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")++test_mapAccumRWithKey :: Assertion+test_mapAccumRWithKey = do+    mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")])+    mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b"), (-1,"c")])+        @?= ("Everything: 5-a 3-b -1-c", fromList [(3, "bX"), (5, "aX"), (-1,"cX")])+  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"++    mapKeys (+ 1) (fromList [(5,"a"), (3,"b"), (-2,"c")])+            @?= fromList [(4, "b"), (6, "a"), (-1,"c")]+    mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (-4,"c")])+            @?= singleton 1 "d"+    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"++    mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (-4,"c")]) @?= singleton 1 "dabc"+    mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (-2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "cdba"++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")]++    mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b"), (-2,"c")])+        @?= fromList [(4, "b"), (6, "a"), (-1, "c")]+    mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b"), (-2,"c")])+        @?= fromList [(6, "b"), (10, "a"), (-4, "c")]++----------------------------------------------------------------+-- Conversion++test_elems :: Assertion+test_elems = do+    elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"]+    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 (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 (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 (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 (\k -> replicate k 'a') (IntSet.fromList [-3, 2, 5]) @?= fromList [(5,"aaaaa"), (-3,""), (2,"aa")]+   fromSet undefined IntSet.empty @?= (empty :: IMap)++----------------------------------------------------------------+-- Lists++test_toList :: Assertion+test_toList = do+    toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]+    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")]++    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 (++) [(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 [(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 = do+    toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]+    toAscList (fromList [(5,"a"), (-3,"b")]) @?= [(-3,"b"), (5,"a")]++test_toDescList :: Assertion+test_toDescList = do+    toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")]+    toDescList (fromList [(5,"a"), (-3,"b")]) @?= [(5,"a"), (-3,"b")]++test_showTree :: Assertion+test_showTree = do+    showTree posTree @?= expectedPosTree+    showTree negTree @?= expectedNegTree+  where mkAscTree ls = fromDistinctAscList [(x,()) | x <- ls]+        posTree = mkAscTree [1..5]+        negTree = mkAscTree [(-2)..2]+        expectedPosTree = unlines+            [ "*"+            , "+--*"+            , "|  +-- 1:=()"+            , "|  +--*"+            , "|     +-- 2:=()"+            , "|     +-- 3:=()"+            , "+--*"+            , "   +-- 4:=()"+            , "   +-- 5:=()"+            ]+        expectedNegTree = unlines+            [ "*"+            , "+--*"+            , "|  +--*"+            , "|  |  +-- 0:=()"+            , "|  |  +-- 1:=()"+            , "|  +-- 2:=()"+            , "+--*"+            , "   +-- -2:=()"+            , "   +-- -1:=()"+            ]++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")]++    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")]+    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")]+    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")]+    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++    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 = do+    filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")])  @?= singleton 5 "a"+    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")])++    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")])++    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 = do+    mapMaybe f (fromList [(5,"a"), (3,"b")])  @?= singleton 5 "new a"+    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 = do+    mapMaybeWithKey f (fromList [(5,"a"), (3,"b")])  @?= singleton 3 "key : 3"+    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")])++    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")])++    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)++    split (-4) (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)++    splitLookup (-4) (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++    isSubmapOfBy (==) (fromList [(-1,1)]) (fromList [(-1,1),(2,2)]) @?= True+    isSubmapOfBy (<=) (fromList [(-1,1)]) (fromList [(-1,1),(2,2)]) @?= True+    isSubmapOfBy (==) (fromList [(-1,1),(2,2)]) (fromList [(-1,1),(2,2)]) @?= True+    isSubmapOfBy (==) (fromList [(-1,2)]) (fromList [(-1,1),(2,2)]) @?= False+    isSubmapOfBy (>)  (fromList [(-1,2)]) (fromList [(-1,1),(2,2)]) @?= True+    isSubmapOfBy (<)  (fromList [(-1,1)]) (fromList [(-1,1),(2,2)]) @?= False+    isSubmapOfBy (==) (fromList [(-1,1),(2,2)]) (fromList [(-1,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++    isSubmapOf (fromList [(-1,1)]) (fromList [(-1,1),(2,2)]) @?= True+    isSubmapOf (fromList [(-1,1),(2,2)]) (fromList [(-1,1),(2,2)]) @?= True+    isSubmapOf (fromList [(-1,2)]) (fromList [(-1,1),(2,2)]) @?= False+    isSubmapOf (fromList [(-1,1),(2,2)]) (fromList [(-1,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++    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++    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 (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 (fromList [(5,"a"), (-3,"b")]) @?= Just (5,"a")+  lookupMax (empty :: SMap) @?= Nothing++test_findMin :: Assertion+test_findMin = do+    findMin (fromList [(5,"a"), (3,"b")]) @?= (3,"b")+    findMin (fromList [(5,"a"), (-3,"b")]) @?= (-3,"b")++test_findMax :: Assertion+test_findMax = do+    findMax (fromList [(5,"a"), (3,"b")]) @?= (5,"a")+    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 (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 (fromList [(5,"a"), (-3,"b"), (7,"c")]) @?= fromList [(-3,"b"), (5,"a")]+    deleteMax (empty :: SMap) @?= empty++test_deleteFindMin :: Assertion+test_deleteFindMin = do+    deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((3,"b"), fromList[(5,"a"), (10,"c")])+    deleteFindMin (fromList [(5,"a"), (-3,"b"), (10,"c")]) @?= ((-3,"b"), fromList[(5,"a"), (10,"c")])++test_deleteFindMax :: Assertion+test_deleteFindMax = do+    deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((10,"c"), fromList [(3,"b"), (5,"a")])+    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"++    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"++    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"++    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"++    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 (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 (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 (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 (fromList [(5,"a"), (-3,"b")]) @?= Just ((5,"a"), singleton (-3) "b")+    maxViewWithKey (empty :: SMap) @?= Nothing+++#if MIN_VERSION_base(4,8,0)+test_minimum :: Assertion+test_minimum = do+    getOW (minimum testOrdMap) @?= "min"+    minimum (elems testOrdMap) @?= minimum testOrdMap+  where getOW (OrdWith s _) = s++test_maximum :: Assertion+test_maximum = do+    getOW (maximum testOrdMap) @?= "max"+    maximum (elems testOrdMap) @?= maximum testOrdMap+  where getOW (OrdWith s _) = s++testOrdMap :: IntMap (OrdWith Int)+testOrdMap = fromList [(1,OrdWith "max" 1),(-1,OrdWith "min" 1)]++data OrdWith a = OrdWith String a+    deriving (Eq, Show)++instance Ord a => Ord (OrdWith a) where+    OrdWith _ a1 <= OrdWith _ a2 = a1 <= a2+#endif+++----------------------------------------------------------------+-- 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++prop_disjoint :: UMap -> UMap -> Property+prop_disjoint m1 m2 = disjoint m1 m2 === null (intersection m1 m2)++prop_compose :: IMap -> IMap -> Int -> Property+prop_compose bc ab k = (compose bc ab !? k) === ((bc !?) <=< (ab !?)) k++-- 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_merge_valid+    :: Fun (Key, A) (Maybe C)+    -> Fun (Key, B) (Maybe C)+    -> Fun (Key, A, B) (Maybe C)+    -> IntMap A+    -> IntMap B+    -> Property+prop_merge_valid whenMissingA whenMissingB whenMatched xs ys+  = valid m+  where+    m =+      merge+        (mapMaybeMissing (applyFun2 whenMissingA))+        (mapMaybeMissing (applyFun2 whenMissingB))+        (zipWithMaybeMatched (applyFun3 whenMatched))+        xs+        ys++-- This uses the instance+--     Monoid a => Applicative ((,) a)+-- to test that effects are sequenced in ascending key order.+prop_mergeA_effects :: UMap -> UMap -> Property+prop_mergeA_effects xs ys+  = effects === sort effects+  where+    (effects, _m) = mergeA whenMissing whenMissing whenMatched xs ys+    whenMissing = traverseMissing (\k _ -> ([k], ()))+    whenMatched = zipWithAMatched (\k _ _ -> ([k], ()))++----------------------------------------------------------------++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_foldrEqFoldMap :: IntMap Int -> Property+prop_foldrEqFoldMap m =+  foldr (:) [] m === Data.Foldable.foldMap (:[]) m++prop_foldrWithKeyEqFoldMapWithKey :: IntMap Int -> Property+prop_foldrWithKeyEqFoldMapWithKey m =+  foldrWithKey (\k v -> ((k,v):)) [] m === foldMapWithKey (\k v -> ([(k,v)])) m++prop_FoldableTraversableCompat :: Fun A [B] -> IntMap A -> Property+prop_FoldableTraversableCompat fun m = foldMap f m === foldMapDefault f m+  where f = apply fun++prop_keysSet :: [(Int, Int)] -> Bool+prop_keysSet xs =+  keysSet (fromList xs) == IntSet.fromList (List.map fst xs)++prop_fromSet :: [(Int, Int)] -> Bool+prop_fromSet ys =+  let xs = List.nubBy ((==) `on` fst) ys+  in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs++newtype Identity a = Identity a+    deriving (Eq, Show)++instance Functor Identity where+  fmap f (Identity a) = Identity (f a)++instance Applicative Identity where+  pure a = Identity a+  Identity f <*> Identity a = Identity (f a)++prop_traverseWithKey_identity :: IntMap A -> Property+prop_traverseWithKey_identity mp = mp === newMap+  where Identity newMap = traverseWithKey (\_ -> Identity) mp++prop_traverseWithKey_degrade_to_mapWithKey :: Fun (Int, A) B -> IntMap A -> Property+prop_traverseWithKey_degrade_to_mapWithKey fun mp =+    mapWithKey f mp === newMap+  where f = applyFun2 fun+        g k v = Identity $ f k v+        Identity newMap = traverseWithKey g mp++prop_traverseMaybeWithKey_identity :: IntMap A -> Property+prop_traverseMaybeWithKey_identity mp = mp === newMap+  where Identity newMap = traverseMaybeWithKey (\_ -> Identity . Just) mp++prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey :: Fun (Int, A) (Maybe B) -> IntMap A -> Property+prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey fun mp =+    mapMaybeWithKey f mp === newMap+  where f = applyFun2 fun+        g k v = Identity $ f k v+        Identity newMap = traverseMaybeWithKey g mp++prop_traverseMaybeWithKey_degrade_to_traverseWithKey :: Fun (Int, A) B -> IntMap A -> Property+prop_traverseMaybeWithKey_degrade_to_traverseWithKey fun mp =+    traverseWithKey f mp === traverseMaybeWithKey g mp+        -- used (,) since its Applicative is monoidal in the left argument,+        -- so this also checks the order of traversing is the same.+  where f k v = (show k, applyFun2 fun k v)+        g k v = fmap Just $ f k v
+ tests/intmap-strictness.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Test.ChasingBottoms.IsBottom+import Test.Framework (Test, TestName, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck.Function (Fun(..), apply)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import Data.Strict.IntMap.Autogen.Strict (IntMap)+import qualified Data.Strict.IntMap.Autogen.Strict as M+import qualified Data.IntMap.Lazy as L+import qualified Data.IntSet as IntSet++import Utils.IsUnit++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 a corner case of fromAscList+--+-- If the list contains duplicate keys, then (only) the first of the+-- given values is not evaluated. This may change in the future, see+-- also https://github.com/haskell/containers/issues/473++pFromAscListLazy :: [Int] -> Bool+pFromAscListLazy ks = not . isBottom $ L.fromAscList elems+  where+    elems = [(k, v) | k <- nubInt ks, v <- [undefined, ()]]++pFromAscListStrict :: [Int] -> Bool+pFromAscListStrict ks+    | null ks   = not . isBottom $ M.fromAscList elems+    | otherwise = isBottom $ M.fromAscList elems+  where+    elems = [(k, v) | k <- nubInt ks, v <- [undefined, undefined, ()]]++-- copy over definitions from Data.Containers.Utils so we can support older GHC+-- that have older versions of containers without this module+nubInt :: [Int] -> [Int]+nubInt = nubIntOn id+{-# INLINE nubInt #-}++nubIntOn :: (a -> Int) -> [a] -> [a]+nubIntOn f = \xs -> nubIntOnExcluding f IntSet.empty xs+{-# INLINE nubIntOn #-}++nubIntOnExcluding :: (a -> Int) -> IntSet.IntSet -> [a] -> [a]+nubIntOnExcluding f = go+  where+    go _ [] = []+    go s (x:xs)+      | fx `IntSet.member` s = go s xs+      | otherwise = x : go (IntSet.insert fx s) xs+      where !fx = f x++------------------------------------------------------------------------+-- check for extra thunks+--+-- These tests distinguish between `()`, a fully evaluated value, and+-- things like `id ()` which are extra thunks that should be avoided+-- in most cases. An exception is `L.fromListWith const`, which cannot+-- evaluate the `const` calls.++tExtraThunksM :: Test+tExtraThunksM = testGroup "IntMap.Strict - extra thunks" $+    if not isUnitSupported then [] else+    -- for strict maps, all the values should be evaluated to ()+    [ check "singleton"           $ m0+    , check "insert"              $ M.insert 42 () m0+    , check "insertWith"          $ M.insertWith const 42 () m0+    , check "fromList"            $ M.fromList [(42,()),(42,())]+    , check "fromListWith"        $ M.fromListWith const [(42,()),(42,())]+    , check "fromAscList"         $ M.fromAscList [(42,()),(42,())]+    , check "fromAscListWith"     $ M.fromAscListWith const [(42,()),(42,())]+    , check "fromDistinctAscList" $ M.fromAscList [(42,())]+    ]+  where+    m0 = M.singleton 42 ()+    check :: TestName -> IntMap () -> Test+    check n m = testCase n $ case M.lookup 42 m of+        Just v -> assertBool msg (isUnit v)+        _      -> assertString "key not found"+      where+        msg = "too lazy -- expected fully evaluated ()"++tExtraThunksL :: Test+tExtraThunksL = testGroup "IntMap.Strict - extra thunks" $+    if not isUnitSupported then [] else+    -- for lazy maps, the *With functions should leave `const () ()` thunks,+    -- but the other functions should produce fully evaluated ().+    [ check "singleton"       True  $ m0+    , check "insert"          True  $ L.insert 42 () m0+    , check "insertWith"      False $ L.insertWith const 42 () m0+    , check "fromList"        True  $ L.fromList [(42,()),(42,())]+    , check "fromListWith"    False $ L.fromListWith const [(42,()),(42,())]+#if MIN_VERSION_containers(0,6,3)+    -- see https://github.com/haskell/containers/issues/473+    , check "fromAscList"     True  $ L.fromAscList [(42,()),(42,())]+#endif+    , check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]+    , check "fromDistinctAscList" True $ L.fromAscList [(42,())]+    ]+  where+    m0 = L.singleton 42 ()+    check :: TestName -> Bool -> L.IntMap () -> Test+    check n e m = testCase n $ case L.lookup 42 m of+        Just v -> assertBool msg (e == isUnit v)+        _      -> assertString "key not found"+      where+        msg | e         = "too lazy -- expected fully evaluated ()"+            | otherwise = "too strict -- expected a thunk"++------------------------------------------------------------------------+-- * 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+      , testProperty "fromAscList is somewhat value-lazy" pFromAscListLazy+      , testProperty "fromAscList is somewhat value-strict" pFromAscListStrict+      ]+      , tExtraThunksM+      , tExtraThunksL+    ]++------------------------------------------------------------------------+-- * 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
+ tests/map-properties.hs view
@@ -0,0 +1,1564 @@+{-# LANGUAGE CPP #-}++#ifdef STRICT+import Data.Strict.Map.Autogen.Strict as Data.Strict.Map.Autogen hiding (showTree, showTreeWith)+import Data.Strict.Map.Autogen.Merge.Strict+#else+import Data.Strict.Map.Autogen.Lazy as Data.Strict.Map.Autogen hiding (showTree, showTreeWith)+import Data.Strict.Map.Autogen.Merge.Lazy+#endif+import Data.Strict.Map.Autogen.Internal (Map (..), link2, link, bin)+import Data.Strict.Map.Autogen.Internal.Debug (showTree, showTreeWith, balanced)++import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>))+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Class+import Control.Monad (liftM4, (<=<))+import Data.Functor.Identity (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 qualified Data.Foldable as Foldable+#if MIN_VERSION_base(4,10,0)+import qualified Data.Bifoldable as Bifoldable+#endif+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 "disjoint"             prop_disjoint+         , testProperty "compose"              prop_compose+         , testProperty "differenceMerge"   prop_differenceMerge+         , testProperty "unionWithKeyMerge"   prop_unionWithKeyMerge+         , testProperty "mergeWithKey model"   prop_mergeWithKeyModel+         , testProperty "mergeA effects"       prop_mergeA_effects+         , 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 "fold"                 prop_fold+         , testProperty "foldMap"              prop_foldMap+         , testProperty "foldMapWithKey"       prop_foldMapWithKey+         , testProperty "foldr"                prop_foldr+         , testProperty "foldrWithKey"         prop_foldrWithKey+         , testProperty "foldr'"               prop_foldr'+         , testProperty "foldrWithKey'"        prop_foldrWithKey'+         , testProperty "foldl"                prop_foldl+         , testProperty "foldlWithKey"         prop_foldlWithKey+         , testProperty "foldl'"               prop_foldl'+         , testProperty "foldlWithKey'"        prop_foldlWithKey'+#if MIN_VERSION_base(4,10,0)+         , testProperty "bifold"               prop_bifold+         , testProperty "bifoldMap"            prop_bifoldMap+         , testProperty "bifoldr"              prop_bifoldr+         , testProperty "bifoldr'"             prop_bifoldr'+         , testProperty "bifoldl"              prop_bifoldl+         , testProperty "bifoldl'"             prop_bifoldl'+#endif+         , 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, 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 key of an arbitrary map should vary+positionFactor :: Int+positionFactor = 1++-- How much the gap between consecutive keys in an arbitrary+-- map should vary+gapRange :: Int+gapRange = 5++instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) 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 keys and+-- a size, produce a map of arbitrary shape with exactly that size.+mkArb :: (MonadGen m, Arbitrary v) => m k -> Int -> m (Map k v)+mkArb step n+  | n <= 0 = return Tip+  | n == 1 = do+     k <- step+     v <- liftGen arbitrary+     return (singleton k v)+  | n == 2 = do+     dir <- liftGen arbitrary+     p <- step+     q <- step+     vOuter <- liftGen arbitrary+     vInner <- liftGen arbitrary+     if dir+       then return (Bin 2 q vOuter (singleton p vInner) Tip)+       else return (Bin 2 p vOuter Tip (singleton q vInner))+  | 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+      liftM4 (\lt x v rt -> Bin n x v lt rt) (mkArb step ln) step (liftGen arbitrary) (mkArb step rn)++-- 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_disjoint :: UMap -> UMap -> Property+prop_disjoint m1 m2 = disjoint m1 m2 === null (intersection m1 m2)++prop_compose :: IMap -> IMap -> Int -> Property+prop_compose bc ab k = (compose bc ab !? k) === ((bc !?) <=< (ab !?)) k++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 #-}++-- This uses the instance+--     Monoid a => Applicative ((,) a)+-- to test that effects are sequenced in ascending key order.+prop_mergeA_effects :: UMap -> UMap -> Property+prop_mergeA_effects xs ys+  = effects === sort effects+  where+    (effects, _m) = mergeA whenMissing whenMissing whenMatched xs ys+    whenMissing = traverseMissing (\k _ -> ([k], ()))+    whenMatched = zipWithAMatched (\k _ _ -> ([k], ()))++----------------------------------------------------------------++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_fold :: Map Int A -> Property+prop_fold = \m -> Foldable.fold (f <$> m) === Foldable.fold (f <$> elems m)+  where+    f v = [v]++prop_foldMap :: Map Int A -> Property+prop_foldMap = \m -> Foldable.foldMap f m === Foldable.foldMap f (elems m)+  where+    f v = [v]++prop_foldMapWithKey :: Map Int A -> Property+prop_foldMapWithKey = \m -> foldMapWithKey (curry f) m === Foldable.foldMap f (toList m)+  where+    f kv = [kv]++-- elems is implemented in terms of foldr, so we don't want to rely on it+-- when we're trying to test foldr.+prop_foldr :: Fun (A, B) B -> B -> [(Int, A)] -> Property+prop_foldr c n ys = foldr c' n m === Foldable.foldr c' n (snd <$> xs)+  where+    c' = curry (apply c)+    xs = List.sortBy (comparing fst) (List.nubBy ((==) `on` fst) ys)+    m  = fromList xs+++-- toList is implemented in terms of foldrWithKey, so we don't want to rely on it+-- when we're trying to test foldrWithKey.+prop_foldrWithKey :: Fun (Int, A, B) B -> B -> [(Int, A)] -> Property+prop_foldrWithKey c n ys = foldrWithKey c' n m === Foldable.foldr (uncurry c') n xs+  where+    c' k v acc = apply c (k, v, acc)+    xs = List.sortBy (comparing fst) (List.nubBy ((==) `on` fst) ys)+    m  = fromList xs++prop_foldr' :: Fun (A, B) B -> B -> Map Int A -> Property+prop_foldr' c n m = foldr' c' n m === Foldable.foldr' c' n (elems m)+  where+    c' = curry (apply c)++prop_foldrWithKey' :: Fun (Int, A, B) B -> B -> Map Int A -> Property+prop_foldrWithKey' c n m = foldrWithKey' c' n m === Foldable.foldr' (uncurry c') n (toList m)+  where+    c' k v acc = apply c (k, v, acc)++prop_foldl :: Fun (B, A) B -> B -> Map Int A -> Property+prop_foldl c n m = foldl c' n m === Foldable.foldl c' n (elems m)+  where+    c' = curry (apply c)++prop_foldlWithKey :: Fun (B, Int, A) B -> B -> Map Int A -> Property+prop_foldlWithKey c n m = foldlWithKey c' n m === Foldable.foldl (uncurry . c') n (toList m)+  where+    c' acc k v = apply c (acc, k, v)++prop_foldl' :: Fun (B, A) B -> B -> Map Int A -> Property+prop_foldl' c n m = foldl' c' n m === Foldable.foldl' c' n (elems m)+  where+    c' = curry (apply c)++prop_foldlWithKey' :: Fun (B, Int, A) B -> B -> Map Int A -> Property+prop_foldlWithKey' c n m = foldlWithKey' c' n m === Foldable.foldl' (uncurry . c') n (toList m)+  where+    c' acc k v = apply c (acc, k, v)++#if MIN_VERSION_base(4,10,0)+prop_bifold :: Map Int Int -> Property+prop_bifold m = Bifoldable.bifold (mapKeys (:[]) ((:[]) <$> m)) === Foldable.fold ((\(k,v) -> [k,v]) <$> toList m)++prop_bifoldMap :: Map Int Int -> Property+prop_bifoldMap m = Bifoldable.bifoldMap (:[]) (:[]) m === Foldable.foldMap (\(k,v) -> [k,v]) (toList m)++prop_bifoldr :: Fun (Int, B) B -> Fun (A, B) B -> B -> Map Int A -> Property+prop_bifoldr ck cv n m = Bifoldable.bifoldr ck' cv' n m === Foldable.foldr c' n (toList m)+  where+    ck' = curry (apply ck)+    cv' = curry (apply cv)+    (k,v) `c'` acc = k `ck'` (v `cv'` acc)++prop_bifoldr' :: Fun (Int, B) B -> Fun (A, B) B -> B -> Map Int A -> Property+prop_bifoldr' ck cv n m = Bifoldable.bifoldr' ck' cv' n m === Foldable.foldr' c' n (toList m)+  where+    ck' = curry (apply ck)+    cv' = curry (apply cv)+    (k,v) `c'` acc = k `ck'` (v `cv'` acc)++prop_bifoldl :: Fun (B, Int) B -> Fun (B, A) B -> B -> Map Int A -> Property+prop_bifoldl ck cv n m = Bifoldable.bifoldl ck' cv' n m === Foldable.foldl c' n (toList m)+  where+    ck' = curry (apply ck)+    cv' = curry (apply cv)+    acc `c'` (k,v) = (acc `ck'` k) `cv'` v++prop_bifoldl' :: Fun (B, Int) B -> Fun (B, A) B -> B -> Map Int A -> Property+prop_bifoldl' ck cv n m = Bifoldable.bifoldl' ck' cv' n m === Foldable.foldl' c' n (toList m)+  where+    ck' = curry (apply ck)+    cv' = curry (apply cv)+    acc `c'` (k,v) = (acc `ck'` k) `cv'` v+#endif++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
+ tests/map-strictness.hs view
@@ -0,0 +1,186 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Test.ChasingBottoms.IsBottom+import Test.Framework (Test, TestName, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck.Function (Fun(..), apply)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import Data.Strict.Map.Autogen.Strict (Map)+import qualified Data.Strict.Map.Autogen.Strict as M+import qualified Data.Map.Lazy as L++import Utils.IsUnit++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++------------------------------------------------------------------------+-- check for extra thunks+--+-- These tests distinguish between `()`, a fully evaluated value, and+-- things like `id ()` which are extra thunks that should be avoided+-- in most cases. An exception is `L.fromListWith const`, which cannot+-- evaluate the `const` calls.++tExtraThunksM :: Test+tExtraThunksM = testGroup "Map.Strict - extra thunks" $+    if not isUnitSupported then [] else+    -- for strict maps, all the values should be evaluated to ()+    [ check "singleton"           $ m0+    , check "insert"              $ M.insert 42 () m0+    , check "insertWith"          $ M.insertWith const 42 () m0+    , check "fromList"            $ M.fromList [(42,()),(42,())]+    , check "fromListWith"        $ M.fromListWith const [(42,()),(42,())]+    , check "fromAscList"         $ M.fromAscList [(42,()),(42,())]+    , check "fromAscListWith"     $ M.fromAscListWith const [(42,()),(42,())]+    , check "fromDistinctAscList" $ M.fromAscList [(42,())]+    ]+  where+    m0 = M.singleton 42 ()+    check :: TestName -> M.Map Int () -> Test+    check n m = testCase n $ case M.lookup 42 m of+        Just v -> assertBool msg (isUnit v)+        _      -> assertString "key not found"+      where+        msg = "too lazy -- expected fully evaluated ()"++tExtraThunksL :: Test+tExtraThunksL = testGroup "Map.Lazy - extra thunks" $+    if not isUnitSupported then [] else+    -- for lazy maps, the *With functions should leave `const () ()` thunks,+    -- but the other functions should produce fully evaluated ().+    [ check "singleton"       True  $ m0+    , check "insert"          True  $ L.insert 42 () m0+    , check "insertWith"      False $ L.insertWith const 42 () m0+    , check "fromList"        True  $ L.fromList [(42,()),(42,())]+    , check "fromListWith"    False $ L.fromListWith const [(42,()),(42,())]+    , check "fromAscList"     True  $ L.fromAscList [(42,()),(42,())]+    , check "fromAscListWith" False $ L.fromAscListWith const [(42,()),(42,())]+    , check "fromDistinctAscList" True $ L.fromAscList [(42,())]+    ]+  where+    m0 = L.singleton 42 ()+    check :: TestName -> Bool -> L.Map Int () -> Test+    check n e m = testCase n $ case L.lookup 42 m of+        Just v -> assertBool msg (e == isUnit v)+        _      -> assertString "key not found"+      where+        msg | e         = "too lazy -- expected fully evaluated ()"+            | otherwise = "too strict -- expected a thunk"++------------------------------------------------------------------------+-- * 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+      ]+      , tExtraThunksM+      , tExtraThunksL+    ]++------------------------------------------------------------------------+-- * 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
+ tests/seq-properties.hs view
@@ -0,0 +1,940 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}++#include "containers.h"++import Data.Strict.Sequence.Autogen.Internal+  ( Sized (..)+  , Seq (Seq)+  , FingerTree(..)+  , Node(..)+  , Elem(..)+  , Digit (..)+  , node2+  , node3+  , deep )++import Data.Strict.Sequence.Autogen++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(..))+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (stimes, stimesMonoid)+#endif+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 "<*" prop_before+       , 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+#if MIN_VERSION_base(4,9,0)+       , testProperty "stimes" prop_stimes+#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.Strict.Sequence.Autogen.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.Strict.Sequence.Autogen.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)+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 = (0, B 0)++-- 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)++-- We take only the length of the second sequence because+-- the implementation throws the rest away; there's no+-- point wasting test cases varying other aspects of that+-- argument.+prop_before :: Seq A -> NonNegative Int -> Bool+prop_before xs (NonNegative lys) =+    toList' (xs <* ys) ~= (toList xs <* toList ys)+  where ys = replicate lys ()++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)++-- Semigroup operations++#if MIN_VERSION_base(4,9,0)+prop_stimes :: NonNegative Int -> Seq A -> Property+prop_stimes (NonNegative n) s =+  stimes n s === stimesMonoid n s+#endif++-- 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