diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,3 @@
+## 0
+
+* repository initialized
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,32 @@
+Copyright (c) 2017-2018, Edward Kmett
+ (c) 2002 Daan Leijen
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * 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.
+
+ * Neither the name of Edward Kmett nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT
+OWNER 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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,69 @@
+unpacked-containers
+==
+
+This package supplies a simple unpacked version of `Data.Set` and `Data.Map` using backpack.
+
+This can remove a level of indirection on the heap and unpack your keys directly into nodes of your sets and maps.
+
+The exported modules roughly follow the API of `containers 0.5.11`, but with all deprecated functions removed.
+
+Note however, that all CPP has been removed relative to `containers`, because on one hand, use of backpack locks us to a current version of GHC,
+and on the other there is a bug in GHC 8.2.2 that prevents the use of CPP in a module that uses backpack. This issue is resolved in GHC 8.4.1,
+so as that comes into wider usage if we need to track `containers` API changes going forward and those need CPP we can just drop support for 8.2.2.
+
+It is intended that you will remap the names of the modules. from `Set.*` or `Map.*` to some portion of the namespace that is peculiar to your
+project, and so the module names are designed to be as short as possible, mirroring the usage of `containers` but with the `Data` prefix stripped off.
+
+Usage
+-----
+
+To work this into an existing haskell project, you'll need to be on GHC >= 8.2.2, and use cabal >= 2.
+
+First build an internal library for your project that has a module that matches the `Key` signature.
+
+```
+module MyKey where
+
+type Key = ()
+```
+
+You can put whatever you want in for `Key` as long as it is an instance of `Ord`.
+
+Then in your cabal file you can set up your internal library as an extra named internal library (multiple library support was added in cabal 2).
+
+```
+library my-keys
+ exposed-modules: MyKey
+ build-depends: base
+```
+
+and in your library or executable that wants to work with sets or maps of that key type use
+
+
+```
+library
+ build-depends: unpacked-containers, my-keys
+ mixins: unpacked-containers (Set as MyKey.Set) requires (Key as MyKey)
+```
+
+If you need several `Set`s or `Map`s you can use several `mixins:` clauses.
+
+If you need to expose the set type, remember you can use a `reexported-modules:` stanza.
+
+Now you work with `MyKey.Set` as a monomorphic set type specific to the type of `Key` you specified earlier.
+
+See the `executable unpacked-set-example` and `library example` sections in the `unpacked-containers.cabal` file for a minimal working example.
+
+Documentation
+==
+
+To build haddocks for this project you need to run `cabal new-haddock` as `cabal-haddock` doesn't work.
+
+Contact Information
+-------------------
+
+Contributions and bug reports are welcome!
+
+Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.
+
+-Edward Kmett
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/example/Int.hs b/example/Int.hs
new file mode 100644
--- /dev/null
+++ b/example/Int.hs
@@ -0,0 +1,3 @@
+module Int where
+
+type Key = Int
diff --git a/example/Main.hs b/example/Main.hs
new file mode 100644
--- /dev/null
+++ b/example/Main.hs
@@ -0,0 +1,9 @@
+module Main where
+
+import Int.Set
+
+ten :: Set
+ten = fromList [1..10]
+
+main :: IO ()
+main = print ten
diff --git a/include/containers.h b/include/containers.h
new file mode 100644
--- /dev/null
+++ b/include/containers.h
@@ -0,0 +1,65 @@
+/*
+ * 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
+
+/*
+ * We use cabal-generated MIN_VERSION_base to adapt to changes of base.
+ * Nevertheless, as a convenience, we also allow compiling without cabal by
+ * defining an approximate MIN_VERSION_base if needed. The alternative version
+ * guesses the version of base using the version of GHC. This is usually
+ * sufficiently accurate. However, it completely ignores minor version numbers,
+ * and it makes the assumption that a pre-release version of GHC will ship with
+ * base libraries with the same version numbers as the final release. This
+ * assumption is violated in certain stages of GHC development, but in practice
+ * this should very rarely matter, and will not affect any released version.
+ */
+#ifndef MIN_VERSION_base
+#if __GLASGOW_HASKELL__ >= 709
+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=8)))
+#elif __GLASGOW_HASKELL__ >= 707
+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=7)))
+#elif __GLASGOW_HASKELL__ >= 705
+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=6)))
+#elif __GLASGOW_HASKELL__ >= 703
+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=5)))
+#elif __GLASGOW_HASKELL__ >= 701
+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=4)))
+#elif __GLASGOW_HASKELL__ >= 700
+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=3)))
+#else
+#define MIN_VERSION_base(major1,major2,minor) (0)
+#endif
+#endif
+
+#endif
diff --git a/src/Key.hsig b/src/Key.hsig
new file mode 100644
--- /dev/null
+++ b/src/Key.hsig
@@ -0,0 +1,5 @@
+signature Key where
+
+data Key
+instance Eq Key
+instance Ord Key
diff --git a/src/Map.hs b/src/Map.hs
new file mode 100644
--- /dev/null
+++ b/src/Map.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE Safe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- (c) Edward Kmett 2018
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- /Note:/ You should use "Map.Strict" instead of this module if:
+--
+-- * You will eventually need all the values stored.
+--
+-- * The stored values don't represent large virtual data structures
+-- to be lazily computed.
+--
+-- An efficient implementation of ordered maps from keys to values
+-- (dictionaries).
+--
+-- These modules are intended to be imported qualified, to avoid name
+-- clashes with Prelude functions, e.g.
+--
+-- > import qualified Map 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,
+-- .
+-- * 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/\",
+-- .
+--
+-- 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 ().
+-----------------------------------------------------------------------------
+
+module Map
+ ( module Map.Lazy
+ ) where
+
+import Prelude hiding (foldr)
+import Map.Lazy
diff --git a/src/Map/Internal.hs b/src/Map/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Internal.hs
@@ -0,0 +1,3783 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map.Internal
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- (c) Edward Kmett 2018
+-- License : BSD-style
+-- Maintainer : Edward Kmett
+-- Portability : non-portable
+--
+-- = WARNING
+--
+-- This module is considered __internal__.
+--
+-- The Package Versioning Policy __does not apply__.
+--
+-- This 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.Map (Map)
+-- > import qualified Data.Map 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,
+-- .
+-- * 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/\",
+-- .
+--
+-- 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 .
+--
+-- @since 0.5.9
+-----------------------------------------------------------------------------
+
+-- [Note(EK): lack of INLINEABLE]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Unlike Data.Map, we _do_ know the Ord instance being used at all times,
+-- so the very use of this library effectively specializes to the dictionary.
+
+-- [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 Map.Internal (
+ -- * Map type
+ Map(..)
+ , 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
+
+ -- ** 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
+
+ -- * 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
+ , atKeyPlain
+ , bin
+ , balance
+ , balanceL
+ , balanceR
+ , delta
+ , insertMax
+ , link
+ , link2
+ , glue
+ , MaybeS(..)
+ , Identity(..)
+
+ -- Used by Map.Merge.Lazy
+ , mapWhenMissing
+ , mapWhenMatched
+ , lmapWhenMissing
+ , contramapFirstWhenMatched
+ , contramapSecondWhenMatched
+ , mapGentlyWhenMissing
+ , mapGentlyWhenMatched
+ ) where
+
+
+import Control.Applicative (Const (..))
+import Control.Applicative (liftA3)
+import Control.DeepSeq (NFData(rnf))
+import Data.Bits (shiftL, shiftR)
+import Data.Coerce
+import Data.Data
+import Data.Functor.Classes
+import Data.Functor.Identity (Identity (..))
+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+import GHC.Exts (build, lazy, Proxy#, proxy# )
+import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop)
+import Text.Read hiding (lift)
+import qualified Control.Category as Category
+import qualified Data.Foldable as Foldable
+import qualified GHC.Exts as GHCExts
+
+import Internal.PtrEquality (ptrEq)
+import Internal.StrictFold
+import Internal.StrictPair
+import Internal.StrictMaybe
+import Internal.BitQueue
+import Internal.BitUtil (wordSize)
+
+import qualified Set.Internal as Set
+import Set.Internal (Set)
+import Key
+
+
+{--------------------------------------------------------------------
+ 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'
+
+(!) :: Map a -> Key -> a
+(!) m k = find k m
+{-# INLINE (!) #-}
+
+-- | /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
+
+(!?) :: Map a -> Key -> Maybe a
+(!?) m k = lookup k m
+{-# INLINE (!?) #-}
+
+-- | Same as 'difference'.
+(\\) :: Map a -> Map b -> Map a
+m1 \\ m2 = difference m1 m2
+{-# INLINE (\\) #-}
+
+{--------------------------------------------------------------------
+ Size balanced trees.
+--------------------------------------------------------------------}
+-- | A Map from keys @k@ to values @a@.
+
+-- See Note: Order of constructors
+data Map a = Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Key a !(Map a) !(Map a)
+ | Tip
+
+type Size = Int
+
+type role Map representational
+
+instance Monoid (Map v) where
+ mempty = empty
+ mconcat = unions
+ mappend = (<>)
+
+instance Semigroup (Map v) where
+ (<>) = union
+ stimes = stimesIdempotentMonoid
+
+{--------------------------------------------------------------------
+ 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 Key, Data a) => Data (Map 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
+ dataCast1 f = gcast1 f
+
+fromListConstr :: Constr
+fromListConstr = mkConstr mapDataType "fromList" [] Prefix
+
+mapDataType :: DataType
+mapDataType = mkDataType "Data.Map.Internal.Map" [fromListConstr]
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the map empty?
+--
+-- > Data.Map.null (empty) == True
+-- > Data.Map.null (singleton 1 'a') == False
+
+null :: Map 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 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 Map.String -- assuming you have an appropriate example map with string keys created
+-- >
+-- > 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 :: Key -> Map 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
+
+-- | /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 :: Key -> Map 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
+
+-- | /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 :: Key -> Map a -> Bool
+notMember k m = not $ member k m
+
+-- | /O(log n)/. Find the value at a key.
+-- Calls 'error' when the element can not be found.
+find :: Key -> Map 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
+
+-- | /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 :: a -> Key -> Map 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
+
+-- | /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 :: Key -> Map v -> Maybe (Key, 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
+
+-- | /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 :: Key -> Map v -> Maybe (Key, 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
+
+-- | /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 :: Key -> Map v -> Maybe (Key, 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
+
+-- | /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 :: Key -> Map v -> Maybe (Key, 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
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty map.
+--
+-- > empty == fromList []
+-- > size empty == 0
+
+empty :: Map 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 :: Key -> a -> Map 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 :: Key -> a -> Map a -> Map 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 :: Key -> Key -> a -> Map a -> Map 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
+
+-- [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 :: Key -> a -> Map a -> Map a
+insertR kx0 = go kx0 kx0
+ where
+ go :: Key -> Key -> a -> Map a -> Map 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
+
+-- | /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 :: (a -> a -> a) -> Key -> a -> Map a -> Map 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 :: (a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+-- | 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 :: (a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWithR = go
+ where
+ go :: (a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWithKey = go
+ where
+ go :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+-- | 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 :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWithKeyR = go
+ where
+ go :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> a -> a) -> Key -> a -> Map a -> (Maybe a, Map a)
+insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0
+ where
+ go :: (Key -> a -> a -> a) -> Key -> a -> Map a -> StrictPair (Maybe a) (Map 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)
+
+{--------------------------------------------------------------------
+ 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 :: Key -> Map a -> Map a
+delete = go
+ where
+ go :: Key -> Map a -> Map 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
+
+-- | /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 :: (a -> a) -> Key -> Map a -> Map a
+adjust f = adjustWithKey (\_ x -> f x)
+
+-- | /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 :: (Key -> a -> a) -> Key -> Map a -> Map a
+adjustWithKey = go
+ where
+ go :: (Key -> a -> a) -> Key -> Map a -> Map 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
+
+-- | /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 :: (a -> Maybe a) -> Key -> Map a -> Map a
+update f = updateWithKey (\_ x -> f x)
+
+-- | /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 :: (Key -> a -> Maybe a) -> Key -> Map a -> Map a
+updateWithKey = go
+ where
+ go :: (Key -> a -> Maybe a) -> Key -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> Maybe a) -> Key -> Map a -> (Maybe a, Map a)
+updateLookupWithKey f0 k0 = toPair . go f0 k0
+ where
+ go :: (Key -> a -> Maybe a) -> Key -> Map a -> StrictPair (Maybe a) (Map 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)
+
+-- | /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 :: (Maybe a -> Maybe a) -> Key -> Map a -> Map a
+alter = go
+ where
+ go :: (Maybe a -> Maybe a) -> Key -> Map a -> Map 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
+
+-- 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 -> Int.Map String -> IO (Int.Map 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 => (Maybe a -> f (Maybe a)) -> Key -> Map a -> f (Map a)
+alterF f k m = atKeyImpl Lazy k f m
+
+{-# 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
+ #-}
+
+-- 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
+ #-}
+
+atKeyImpl :: Functor f => AreWeStrict -> Key -> (Maybe a -> f (Maybe a)) -> Map a -> f (Map a)
+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
+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 #-}
+
+-- TODO(EK): moving this out to a separate module would let us use CPP like before
+alterFCutoff :: Int
+alterFCutoff = case wordSize of
+ 30 -> 17637893
+ 31 -> 31356255
+ 32 -> 55744454
+ x -> (4^(x*2-2)) `quot` (3^(x*2-2)) -- Unlikely
+
+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 :: Key -> Map a -> TraceResult a
+lookupTrace = go emptyQB
+ where
+ go :: BitQueueB -> Key -> Map 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.
+
+-- Insert at a location (which will always be a leaf)
+-- described by the path passed in.
+insertAlong :: BitQueue -> Key -> a -> Map a -> Map 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 a -> Map a
+deleteAlong old !q0 !m = go (bogus old) q0 m where
+ go :: Proxy# () -> BitQueue -> Map a -> Map a
+ 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
+
+{-# NOINLINE bogus #-}
+bogus :: a -> Proxy# ()
+bogus _ = proxy#
+
+-- Replace the value found in the node described
+-- by the given path with a new one.
+replaceAlong :: BitQueue -> a -> Map a -> Map 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
+
+atKeyIdentity :: Key -> (Maybe a -> Identity (Maybe a)) -> Map a -> Identity (Map a)
+atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t
+
+atKeyPlain :: AreWeStrict -> Key -> (Maybe a -> Maybe a) -> Map a -> Map 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 :: Key -> (Maybe a -> Maybe a) -> Map a -> Altered 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 a = AltSmaller !(Map a) | AltBigger !(Map a) | AltAdj !(Map a) | AltSame
+
+-- 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 => AreWeStrict -> Key -> (Maybe a -> f (Maybe a)) -> Map a -> f (Map 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 :: Key -> (Maybe a -> (Maybe a -> b) -> f b) -> Map a -> (Map a -> b) -> f b
+alterFYoneda = go
+ where
+ go :: Key -> (Maybe a -> (Maybe a -> b) -> f b) -> Map a -> (Map 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 #-}
+
+{--------------------------------------------------------------------
+ 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 :: Key -> Map a -> Int
+findIndex = go 0
+ where
+ go :: Int -> Key -> Map 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
+
+-- | /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 :: Key -> Map a -> Maybe Int
+lookupIndex = go 0
+ where
+ go :: Int -> Key -> Map 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
+
+-- | /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 a -> (Key, 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 a -> Map 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 a -> Map 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 a -> (Map a, Map 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 :: (Key -> a -> Maybe a) -> Int -> Map a -> Map 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 a -> Map 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 :: Key -> a -> Map a -> (Key, 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")
+-- > findMin empty = Nothing
+--
+-- @since 0.5.9
+
+lookupMin :: Map a -> Maybe (Key, 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 a -> (Key, 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 :: Key -> a -> Map a -> (Key, 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 a -> Maybe (Key, a)
+lookupMax Tip = Nothing
+lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r
+
+findMax :: Map a -> (Key, 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 a -> Map 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 a -> Map 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 a -> Map 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 a -> Map 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 :: (Key -> a -> Maybe a) -> Map a -> Map 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 :: (Key -> a -> Maybe a) -> Map a -> Map 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 a -> Maybe ((Key,a), Map 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 a -> Maybe ((Key,a), Map 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 a -> Maybe (a, Map 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 a -> Maybe (a, Map 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 :: [Map a] -> Map a
+unions ts = foldlStrict union empty ts
+
+-- | 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 :: (a -> a -> a) -> [Map a] -> Map a
+unionsWith f ts = foldlStrict (unionWith f) empty ts
+
+-- | /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 :: Map a -> Map a -> Map 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
+
+{--------------------------------------------------------------------
+ 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 :: (a -> a -> a) -> Map a -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> a -> a) -> Map a -> Map a -> Map 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
+
+{--------------------------------------------------------------------
+ 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 :: Map a -> Map b -> Map 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
+
+-- | /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 :: Map a -> Set -> Map 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
+
+-- | /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 :: (a -> b -> Maybe a) -> Map a -> Map b -> Map a
+differenceWith f = merge preserveMissing dropMissing $
+ zipWithMaybeMatched (\_ x y -> f x y)
+
+-- | /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) -> Map a -> Map b -> Map a
+differenceWithKey f =
+ merge preserveMissing dropMissing (zipWithMaybeMatched f)
+
+
+{--------------------------------------------------------------------
+ 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 :: Map a -> Map b -> Map 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
+
+-- | /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 `'intersect' 'fromSet' (const ()) s
+-- @
+--
+-- @since 0.5.8
+restrictKeys :: Map a -> Set -> Map 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
+
+-- | /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 :: (a -> b -> c) -> Map a -> Map b -> Map 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
+
+-- | /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 :: (Key -> a -> b -> c) -> Map a -> Map b -> Map 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
+
+-- | A tactic for dealing with keys present in one map but not the other in
+-- 'merge' or 'mergeA'.
+--
+-- A tactic of type @ WhenMissing f 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 :: Map x -> f (Map y)
+ , missingKey :: Key -> x -> f (Maybe y)
+ }
+
+-- | @since 0.5.9
+instance Monad f => Functor (WhenMissing f x) where
+ fmap = mapWhenMissing
+ {-# INLINE fmap #-}
+
+-- | @since 0.5.9
+instance Monad f => Category.Category (WhenMissing f) 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 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 Monad f => Monad (WhenMissing f x) where
+ 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 :: 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 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 #-}
+
+-- | 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 k (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 k (ReaderT x (ReaderT y (MaybeT f))) @
+--
+-- @since 0.5.9
+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where
+ 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 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 k 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 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 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 :: (Key -> 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 :: (Key -> 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 #-}
+
+-- | 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 #-}
+
+-- | 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@
+ -> Map a -- ^ Map @m1@
+ -> Map b -- ^ Map @m2@
+ -> Map 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@
+ -> Map a -- ^ Map @m1@
+ -> Map b -- ^ Map @m2@
+ -> f (Map 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 :: (Key -> a -> b -> Maybe c)
+ -> (Map a -> Map c)
+ -> (Map b -> Map c)
+ -> Map a -> Map b -> Map 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 :: Eq a => Map a -> Map a -> Bool
+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2
+
+{- | /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)])
+-}
+isSubmapOfBy :: (a -> b -> Bool) -> Map a -> Map b -> Bool
+isSubmapOfBy f t1 t2
+ = (size t1 <= size t2) && (submap' f t1 t2)
+
+submap' :: (b -> c -> Bool) -> Map b -> Map c -> Bool
+submap' _ Tip _ = True
+submap' _ _ Tip = False
+submap' f (Bin _ kx x l r) t
+ = case found of
+ Nothing -> False
+ Just y -> f x y && submap' f l lt && submap' f r gt
+ where
+ (lt,found,gt) = splitLookup kx t
+
+-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).
+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
+isProperSubmapOf :: Eq a => Map a -> Map a -> Bool
+isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2
+
+{- | /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
+ @m1@ and @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) -> Map a -> Map b -> Bool
+isProperSubmapOfBy f t1 t2
+ = (size t1 < size t2) && (submap' f t1 t2)
+
+{--------------------------------------------------------------------
+ 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 a -> Map 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 :: (Key -> a -> Bool) -> Map a -> Map 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 => (Key -> a -> f Bool) -> Map a -> f (Map 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 :: (Key -> Bool) -> Map a -> Map 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 :: (Key -> Bool) -> Map a -> Map 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 = partition p 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 :: (Key -> Bool) -> Map a -> (Map a, Map 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 a -> (Map a,Map 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 :: (Key -> a -> Bool) -> Map a -> (Map a,Map 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 a -> Map b
+mapMaybe f = mapMaybeWithKey (\_ x -> f x)
+
+-- | /O(n)/. Mapeys\/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) -> Map a -> Map 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
+ => (Key -> a -> f (Maybe b)) -> Map a -> f (Map 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 a -> (Map b, Map c)
+mapEither f m
+ = mapEitherWithKey (\_ x -> f x) m
+
+-- | /O(n)/. Mapeys\/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) -> Map a -> (Map b, Map 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 a -> Map 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.
+
+{-# NOINLINE [1] map #-}
+{-# RULES
+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs
+ #-}
+
+-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
+{-# RULES
+"map/coerce" map coerce = coerce
+ #-}
+
+-- | /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) -> Map a -> Map b
+mapWithKey _ Tip = Tip
+mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f 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/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
+ #-}
+
+-- | /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 => (Key -> a -> t b) -> Map a -> t (Map 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 b -> (a,Map 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 -> Key -> b -> (a,c)) -> a -> Map b -> (a,Map 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 -> Map b -> (a,Map 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 'mapAccumR' threads an accumulating
+-- argument through the map in descending order of keys.
+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Map b -> (a,Map 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 :: (Key -> Key) -> Map a -> Map a
+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+-- | /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 :: (a -> a -> a) -> (Key -> Key) -> Map a -> Map a
+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+-- | /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 :: (Key -> Key) -> Map a -> Map 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 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 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 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 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 :: (Key -> a -> b -> b) -> b -> Map 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' :: (Key -> a -> b -> b) -> b -> Map 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 -> Key -> b -> a) -> a -> Map 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 -> Key -> b -> a) -> a -> Map 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 => (Key -> a -> m) -> Map 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 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 a -> [Key]
+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 a -> [(Key,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 a -> Set.Set
+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 :: (Key -> a) -> Set.Set -> Map 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
+ use [foldlStrict] to reduce demand on the control-stack
+--------------------------------------------------------------------}
+-- | @since 0.5.6.2
+instance GHCExts.IsList (Map v) where
+ type Item (Map v) = (Key,v)
+ fromList = fromList
+ toList = toList
+
+-- | /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 :: [(Key,a)] -> Map 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 = foldlStrict 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)
+
+-- | /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 :: (a -> a -> a) -> [(Key,a)] -> Map a
+fromListWith f xs
+ = fromListWithKey (\_ x y -> f x y) xs
+
+-- | /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 :: (Key -> a -> a -> a) -> [(Key,a)] -> Map a
+fromListWithKey f xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+
+-- | /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 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 :: Map 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 :: Map a -> [(Key,a)]
+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []
+
+-- List fusion for the list generating functions.
+-- 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 -> Map a -> b
+foldrFB = foldrWithKey
+{-# INLINE[0] foldrFB #-}
+foldlFB :: (a -> Key -> b -> a) -> a -> Map 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 #-}
+
+{--------------------------------------------------------------------
+ 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 :: [(Key,a)] -> Map 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'
+
+-- | /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 :: [(Key,a)] -> Map 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'
+
+-- | /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 :: (a -> a -> a) -> [(Key,a)] -> Map a
+fromAscListWith f xs
+ = fromAscListWithKey (\_ x y -> f x y) xs
+
+-- | /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 :: (a -> a -> a) -> [(Key,a)] -> Map a
+fromDescListWith f xs
+ = fromDescListWithKey (\_ x y -> f x y) xs
+
+-- | /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 :: (Key -> a -> a -> a) -> [(Key,a)] -> Map 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'
+
+-- | /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 :: (Key -> a -> a -> a) -> [(Key,a)] -> Map 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'
+
+
+-- | /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 :: [(Key,a)] -> Map 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 :: [(Key,a)] -> Map 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)
+
+{--------------------------------------------------------------------
+ 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 :: Key -> Map a -> (Map a,Map 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)
+
+-- | /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 :: Key -> Map a -> (Map a,Maybe a,Map a)
+splitLookup k0 m = case go k0 m of
+ StrictTriple l mv r -> (l, mv, r)
+ where
+ go :: Key -> Map a -> StrictTriple (Map a) (Maybe a) (Map 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
+
+-- | 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 :: Key -> Map a -> (Map a,Bool,Map a)
+splitMember k0 m = case go k0 m of
+ StrictTriple l mv r -> (l, mv, r)
+ where
+ go :: Key -> Map a -> StrictTriple (Map a) Bool (Map 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
+
+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 :: Key -> a -> Map a -> Map a -> Map 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 :: Key -> a -> Map a -> Map 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 a -> Map a -> Map 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 a -> Map a -> Map 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 a = MinView {-# UNPACK #-} !Key a !(Map a)
+data MaxView a = MaxView {-# UNPACK #-} !Key a !(Map a)
+
+minViewSure :: Key -> a -> Map a -> Map a -> MinView 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 :: Key -> a -> Map a -> Map a -> MaxView 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 Error: can not return the minimal element of an empty map
+
+deleteFindMin :: Map a -> ((Key,a),Map 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 a -> ((Key,a),Map 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 :: Key -> a -> Map a -> Map a -> Map 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 :: Key -> a -> Map a -> Map a -> Map 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.Map.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.Map.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 :: Key -> a -> Map a -> Map a -> Map 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.Map.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 :: Key -> a -> Map a -> Map a -> Map 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.Map.balanceR"
+ | otherwise -> Bin (1+ls+rs) k x l r
+{-# NOINLINE balanceR #-}
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: Key -> a -> Map a -> Map a -> Map 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 a => Eq (Map a) where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord v => Ord (Map v) where
+ compare m1 m2 = compare (toAscList m1) (toAscList m2)
+
+{--------------------------------------------------------------------
+ Lifted instances
+--------------------------------------------------------------------}
+
+-- | @since 0.5.9
+instance Eq1 Map where
+ liftEq eqv m n = size m == size n && liftEq (liftEq eqv) (toList m) (toList n)
+
+-- | @since 0.5.9
+instance Ord1 Map where
+ liftCompare cmpv m n = liftCompare (liftCompare cmpv) (toList m) (toList n)
+
+-- | @since 0.5.9
+instance Show Key => Show1 Map where
+ liftShowsPrec spv slv d m =
+ showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)
+ where
+ sp = liftShowsPrec spv slv
+ sl = liftShowList spv slv
+
+-- | @since 0.5.9
+instance Read Key => Read1 Map where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+{--------------------------------------------------------------------
+ Functor
+--------------------------------------------------------------------}
+instance Functor Map where
+ fmap f m = map f m
+ _ <$ Tip = Tip
+ a <$ (Bin sx kx _ l r) = Bin sx kx a (a <$ l) (a <$ r)
+
+instance Traversable Map where
+ traverse f = traverseWithKey (\_ -> f)
+
+instance Foldable.Foldable Map 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' #-}
+ 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.Map): 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.Map): 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 #-}
+
+instance (NFData Key, NFData a) => NFData (Map a) where
+ rnf Tip = ()
+ rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r
+
+{--------------------------------------------------------------------
+ Read
+--------------------------------------------------------------------}
+instance (Read Key, Read e) => Read (Map e) where
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+
+ readListPrec = readListPrecDefault
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance (Show Key, Show a) => Show (Map a) where
+ showsPrec d m = showParen (d > 10) $
+ showString "fromList " . shows (toList m)
+
+
+{--------------------------------------------------------------------
+ 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 b -> [Map b]
+splitRoot orig =
+ case orig of
+ Tip -> []
+ Bin _ k v l r -> [l, singleton k v, r]
+{-# INLINE splitRoot #-}
+
diff --git a/src/Map/Internal/Debug.hs b/src/Map/Internal/Debug.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Internal/Debug.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+module Map.Internal.Debug where
+
+import Key
+import Map.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 Key, Show a) => Map 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 :: (Key -> a -> String) -> Bool -> Bool -> Map a -> String
+showTreeWith showelem hang wide t
+ | hang = (showsTreeHang showelem wide [] t) ""
+ | otherwise = (showsTree showelem wide [] [] t) ""
+
+showsTree :: (Key -> a -> String) -> Bool -> [String] -> [String] -> Map 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 :: (Key -> a -> String) -> Bool -> [String] -> Map 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 :: Map a -> Bool
+valid t = balanced t && ordered t && validsize t
+
+-- | Test if the keys are ordered correctly.
+ordered :: Map 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) hi r
+
+-- | Test if a map obeys the balance invariants.
+balanced :: Map 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 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
diff --git a/src/Map/Lazy.hs b/src/Map/Lazy.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Lazy.hs
@@ -0,0 +1,256 @@
+{-# LANGUAGE Safe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map.Lazy
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Maps (lazy interface)
+--
+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)
+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy
+-- in its values.
+--
+-- The functions in "Map.Strict" are careful to force values before
+-- installing them in a 'Map'. This is usually more efficient in cases where
+-- laziness is not essential. The functions in this module do not do so.
+--
+-- When deciding if this is the correct data structure to use, consider:
+--
+-- * If you are using 'Int' keys, you will get much better performance for most
+-- operations using "Data.IntMap.Lazy".
+--
+-- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the
+--
+-- package instead.
+--
+-- For a walkthrough of the most commonly used functions see the
+-- .
+--
+-- This module is intended to be imported qualified, to avoid name clashes with
+-- Prelude functions:
+--
+-- > import qualified Map.Lazy 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 "Map.Lazy" 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.
+--
+--
+-- == 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,
+-- .
+-- * 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/\",
+-- .
+--
+-----------------------------------------------------------------------------
+
+module Map.Lazy (
+ -- * Map type
+ Map -- instance Eq,Show,Read
+
+ -- * 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
+
+ -- ** General combining functions
+ -- | See "Map.Merge.Lazy"
+
+ -- ** Unsafe 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
+ , valid
+ ) where
+
+import Map.Internal
+import Map.Internal.Debug (valid)
+import Prelude ()
diff --git a/src/Map/Merge/Lazy.hs b/src/Map/Merge/Lazy.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Merge/Lazy.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map.Merge.Lazy
+-- 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 'Map.Merge.Strict.mapMissing'
+-- from "Map.Merge.Strict" then the results will be forced before
+-- they are inserted. If you use 'Map.Merge.Lazy.mapMissing' from
+-- this module then they will not.
+--
+-- == Efficiency note
+--
+-- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'
+-- tactics are included because they are valid. However, they are
+-- inefficient in many cases and should usually be avoided. The instances
+-- for 'WhenMatched' tactics should not pose any major efficiency problems.
+--
+-- @since 0.5.9
+
+module Map.Merge.Lazy (
+ -- ** 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
+
+ -- *** Contravariant maps for tactics
+ , lmapWhenMissing
+ , contramapFirstWhenMatched
+ , contramapSecondWhenMatched
+
+ -- *** Miscellaneous tactic functions
+ , runWhenMatched
+ , runWhenMissing
+ ) where
+
+import Map.Internal
diff --git a/src/Map/Merge/Strict.hs b/src/Map/Merge/Strict.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Merge/Strict.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map.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 'Map.Merge.Strict.mapMissing'
+-- from this module then the results will be forced before they are
+-- inserted. If you use 'Map.Merge.Lazy.mapMissing' from
+-- "Map.Merge.Lazy" then they will not.
+--
+-- == Efficiency note
+--
+-- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'
+-- tactics are included because they are valid. However, they are
+-- inefficient in many cases and should usually be avoided. The instances
+-- for 'WhenMatched' tactics should not pose any major efficiency problems.
+--
+-- @since 0.5.9
+
+module Map.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 Map.Strict.Internal
diff --git a/src/Map/Strict.hs b/src/Map/Strict.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Strict.hs
@@ -0,0 +1,269 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Safe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map.Strict
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- (c) Edward Kmett 2018
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+--
+-- = Finite Maps (strict interface)
+--
+-- The @'Map' 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 "Map.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 '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
+--
+-- package instead.
+--
+-- For a walkthrough of the most commonly used functions see the
+-- .
+--
+-- This module is intended to be imported qualified, to avoid name clashes with
+-- Prelude functions:
+--
+-- > import qualified Map.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.
+--
+-- == 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 'Functor', 'Traversable' and 'Data' instances are the same as for
+-- the "Map.Lazy" module, so if they are used on strict maps, 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,
+-- .
+-- * 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/\",
+-- .
+--
+--
+-----------------------------------------------------------------------------
+
+-- See the notes at the beginning of Map.Internal.
+
+module Map.Strict
+ (
+ -- * Map type
+ Map -- instance Eq,Show,Read
+
+ -- * 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
+
+ -- ** General combining functions
+ -- | See "Map.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
+ , 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
+ , valid
+ ) where
+
+import Map.Strict.Internal
+import Prelude ()
diff --git a/src/Map/Strict/Internal.hs b/src/Map/Strict/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Map/Strict/Internal.hs
@@ -0,0 +1,1567 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Trustworthy #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Map.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__.
+--
+-- This 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 "Map.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 Map.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,
+-- .
+-- * 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/\",
+-- .
+--
+-- 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 ().
+--
+-- Be aware that the 'Functor', 'Traversable' and 'Data' instances
+-- are the same as for the "Map.Lazy" module, so if they are used
+-- on strict maps, the resulting maps will be lazy.
+-----------------------------------------------------------------------------
+
+-- See the notes at the beginning of Map.Internal.
+
+module Map.Strict.Internal
+ (
+ -- * Strictness properties
+ -- $strictness
+
+ -- * Map type
+ Map(..)
+ , 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
+
+ -- ** General combining function
+ , SimpleWhenMissing
+ , SimpleWhenMatched
+ , merge
+ , runWhenMatched
+ , runWhenMissing
+
+ -- *** @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
+
+ -- *** 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
+ , valid
+ ) where
+
+import Prelude hiding (lookup,map,filter,foldr,foldl,null,take,drop,splitAt)
+
+import Map.Internal
+ ( Map (..)
+ , AreWeStrict (..)
+ , WhenMissing (..)
+ , WhenMatched (..)
+ , runWhenMatched
+ , runWhenMissing
+ , SimpleWhenMissing
+ , SimpleWhenMatched
+ , preserveMissing
+ , dropMissing
+ , filterMissing
+ , filterAMissing
+ , merge
+ , mergeA
+ , (!)
+ , (!?)
+ , (\\)
+ , assocs
+ , atKeyImpl
+ , atKeyPlain
+ , balance
+ , balanceL
+ , balanceR
+ , elemAt
+ , elems
+ , empty
+ , delete
+ , deleteAt
+ , deleteFindMax
+ , deleteFindMin
+ , deleteMin
+ , deleteMax
+ , difference
+ , 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 )
+
+import Map.Internal.Debug (valid)
+
+import Control.Applicative (Const (..), liftA3)
+import qualified Set.Internal as Set
+import qualified Map.Internal as L
+import Data.Bits (shiftL, shiftR)
+import Data.Coerce
+import Data.Functor.Identity (Identity (..))
+
+import Internal.StrictFold
+import Internal.StrictPair
+import Key
+
+-- $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 :: a -> Key -> Map 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
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+
+-- | /O(1)/. A map with a single element.
+--
+-- > singleton 1 'a' == fromList [(1, 'a')]
+-- > size (singleton 1 'a') == 1
+
+singleton :: Key -> a -> Map 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 :: Key -> a -> Map a -> Map a
+insert = go
+ where
+ go :: Key -> a -> Map a -> Map 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
+
+-- | /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 :: (a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWith = go
+ where
+ go :: (a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+insertWithR :: (a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWithR = go
+ where
+ go :: (a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWithKey = go
+ where
+ go :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+insertWithKeyR :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map a
+insertWithKeyR = go
+ where
+ go :: (Key -> a -> a -> a) -> Key -> a -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> a -> a) -> Key -> a -> Map a -> (Maybe a, Map a)
+insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0
+ where
+ go :: (Key -> a -> a -> a) -> Key -> a -> Map a -> StrictPair (Maybe a) (Map 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)
+
+{--------------------------------------------------------------------
+ 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 :: (a -> a) -> Key -> Map a -> Map a
+adjust f = adjustWithKey (\_ x -> f x)
+
+-- | /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 :: (Key -> a -> a) -> Key -> Map a -> Map a
+adjustWithKey = go
+ where
+ go :: (Key -> a -> a) -> Key -> Map a -> Map 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
+
+-- | /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 :: (a -> Maybe a) -> Key -> Map a -> Map a
+update f = updateWithKey (\_ x -> f x)
+
+-- | /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 :: (Key -> a -> Maybe a) -> Key -> Map a -> Map a
+updateWithKey = go
+ where
+ go :: (Key -> a -> Maybe a) -> Key -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> Maybe a) -> Key -> Map a -> (Maybe a,Map a)
+updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0
+ where
+ go :: (Key -> a -> Maybe a) -> Key -> Map a -> StrictPair (Maybe a) (Map 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)
+
+-- | /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 :: (Maybe a -> Maybe a) -> Key -> Map a -> Map a
+alter = go
+ where
+ go :: (Maybe a -> Maybe a) -> Key -> Map a -> Map 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
+
+-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof.
+-- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'.
+-- In short: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@.
+--
+-- Example:
+--
+-- @
+-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
+-- interactiveAlter k m = alterF f k m where
+-- f Nothing -> do
+-- putStrLn $ show k ++
+-- " was not found in the map. Would you like to add it?"
+-- getUserResponse1 :: IO (Maybe String)
+-- f (Just old) -> do
+-- putStrLn "The key is currently bound to " ++ show old ++
+-- ". Would you like to change or delete it?"
+-- getUserresponse2 :: IO (Maybe String)
+-- @
+--
+-- 'alterF' is the most general operation for working with an individual
+-- key that may or may not be in a given map. When used with trivial
+-- functors like 'Identity' and 'Const', it is often slightly slower than
+-- more specialized combinators like 'lookup' and 'insert'. However, when
+-- the functor is non-trivial and key comparison is not particularly cheap,
+-- it is the fastest way.
+--
+-- Note on rewrite rules:
+--
+-- This module includes GHC rewrite rules to optimize 'alterF' for
+-- the 'Const' and 'Identity' functors. In general, these rules
+-- improve performance. The sole exception is that when using
+-- 'Identity', deleting a key that is already absent takes longer
+-- than it would without the rules. If you expect this to occur
+-- a very large fraction of the time, you might consider using a
+-- private copy of the 'Identity' type.
+--
+-- Note: 'alterF' is a flipped version of the 'at' combinator from
+-- 'Control.Lens.At'.
+alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> Map a -> f (Map a)
+alterF f k m = atKeyImpl Strict k f m
+
+{-# 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
+ #-}
+-- 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 :: Key -> (Maybe a -> Identity (Maybe a)) -> Map a -> Identity (Map a)
+atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t
+{-# INLINABLE atKeyIdentity #-}
+
+{--------------------------------------------------------------------
+ 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 :: (Key -> a -> Maybe a) -> Int -> Map a -> Map 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 a -> Map 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 a -> Map 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 :: (Key -> a -> Maybe a) -> Map a -> Map 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 :: (Key -> a -> Maybe a) -> Map a -> Map 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 :: (a->a->a) -> [Map a] -> Map a
+unionsWith f ts = foldlStrict (unionWith f) empty ts
+
+{--------------------------------------------------------------------
+ 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 :: (a -> a -> a) -> Map a -> Map a -> Map 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
+
+-- | /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 :: (Key -> a -> a -> a) -> Map a -> Map a -> Map 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
+
+{--------------------------------------------------------------------
+ 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 :: (a -> b -> Maybe a) -> Map a -> Map b -> Map a
+differenceWith f = merge preserveMissing dropMissing (zipWithMaybeMatched $ \_ x1 x2 -> f x1 x2)
+
+-- | /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) -> Map a -> Map b -> Map a
+differenceWithKey f = merge preserveMissing dropMissing (zipWithMaybeMatched f)
+
+
+{--------------------------------------------------------------------
+ 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 :: (a -> b -> c) -> Map a -> Map b -> Map 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
+
+-- | /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 :: (Key -> a -> b -> c) -> Map a -> Map b -> Map 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
+
+-- | Map covariantly over a @'WhenMissing' f 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 :: (Key -> x -> y -> Maybe z)
+-- -> SimpleWhenMatched 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 :: (Key -> x -> y -> z)
+-- -> SimpleWhenMatched 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 :: (Key -> x -> Maybe y) -> SimpleWhenMissing 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 :: (Key -> x -> y) -> SimpleWhenMissing 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 #-}
+
+{--------------------------------------------------------------------
+ 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 'Map.Merge.Strict.merge' or
+-- 'Map.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 :: (Key -> a -> b -> Maybe c)
+ -> (Map a -> Map c)
+ -> (Map b -> Map c)
+ -> Map a -> Map b -> Map 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 a -> Map b
+mapMaybe f = mapMaybeWithKey (\_ x -> f x)
+
+-- | /O(n)/. Mapeys\/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) -> Map a -> Map 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
+ => (Key -> a -> f (Maybe b)) -> Map a -> f (Map 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 a -> (Map b, Map c)
+mapEither f m
+ = mapEitherWithKey (\_ x -> f x) m
+
+-- | /O(n)/. Mapeys\/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) -> Map a -> (Map b, Map 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 a -> Map 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.
+
+{-# 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
+ #-}
+
+-- | /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) -> Map a -> Map 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)
+
+{-# 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
+ #-}
+
+-- | /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 => (Key -> a -> t b) -> Map a -> t (Map 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 b -> (a,Map 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 -> Key -> b -> (a,c)) -> a -> Map b -> (a,Map 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 -> Map b -> (a,Map 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 'mapAccumR' threads an accumulating
+-- argument through the map in descending order of keys.
+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Map b -> (a,Map 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 :: (a -> a -> a) -> (Key -> Key) -> Map a -> Map a
+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
+
+{--------------------------------------------------------------------
+ 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 :: (Key -> a) -> Set.Set -> Map 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
+ use [foldlStrict] to reduce demand on the control-stack
+--------------------------------------------------------------------}
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
+-- If the list contains more than one value for the same key, the last value
+-- 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 :: [(Key,a)] -> Map 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 = foldlStrict 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)
+
+-- | /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 :: (a -> a -> a) -> [(Key,a)] -> Map a
+fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs
+{-# INLINABLE fromListWith #-}
+
+-- | /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 :: (Key -> a -> a -> a) -> [(Key,a)] -> Map a
+fromListWithKey f xs = foldlStrict ins empty xs where
+ ins t (k,x) = insertWithKey f k x t
+
+{--------------------------------------------------------------------
+ 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 :: [(Key,a)] -> Map a
+fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs
+
+-- | /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 :: [(Key,a)] -> Map a
+fromDescList xs = fromDescListWithKey (\_ x _ -> x) xs
+
+-- | /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 :: (a -> a -> a) -> [(Key,a)] -> Map a
+fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs
+
+-- | /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 :: (a -> a -> a) -> [(Key,a)] -> Map a
+fromDescListWith f xs = fromDescListWithKey (\_ x y -> f x y) xs
+
+-- | /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 :: (Key -> a -> a -> a) -> [(Key,a)] -> Map 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'
+
+-- | /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 :: (Key -> a -> a -> a) -> [(Key,a)] -> Map 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'
+
+-- | /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 :: [(Key,a)] -> Map 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 :: [(Key,a)] -> Map 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)
diff --git a/src/Set.hs b/src/Set.hs
new file mode 100644
--- /dev/null
+++ b/src/Set.hs
@@ -0,0 +1,154 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Set
+-- Copyright : (c) Daan Leijen 2002, (c) Edward Kmett 2017-2018
+--
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- An efficient implementation of sets using backpack to unpack the element type
+--
+-- These modules are intended to be imported qualified, to avoid name
+-- clashes with Prelude functions, e.g.
+--
+-- > import Data.Set (Set)
+-- > import qualified Data.Set as Set
+--
+-- The implementation of 'Set' 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,
+-- .
+-- * 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/\",
+-- .
+--
+-- 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'. Of course, left-biasing can only be observed
+-- when equality is an equivalence relation instead of structural
+-- equality.
+--
+-- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of
+-- this condition is not detected and if the size limit is exceeded, its
+-- behaviour is undefined.
+-----------------------------------------------------------------------------
+
+module Set (
+ -- * Strictness properties
+ -- $strictness
+
+ -- * Set type
+ Set
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , S.null
+ , size
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+ , isSubsetOf
+ , isProperSubsetOf
+
+ -- * Construction
+ , empty
+ , singleton
+ , insert
+ , delete
+
+ -- * Combine
+ , union
+ , unions
+ , difference
+ , intersection
+
+ -- * Filter
+ , S.filter
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+ , partition
+ , split
+ , splitMember
+ , splitRoot
+
+ -- * Indexed
+ , lookupIndex
+ , findIndex
+ , elemAt
+ , deleteAt
+ , S.take
+ , S.drop
+ , S.splitAt
+
+ -- * Map
+ , S.map
+ , mapMonotonic
+
+ -- * Folds
+ , S.foldMap
+ , S.foldr
+ , S.foldl
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , maxView
+ , minView
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , toDescList
+ , fromAscList
+ , fromDescList
+ , fromDistinctAscList
+ , fromDistinctDescList
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+ ) where
+
+import Set.Internal as S
+
+-- $strictness
+--
+-- This module satisfies the following strictness property:
+--
+-- * Key arguments are evaluated to WHNF
+--
+-- Here are some examples that illustrate the property:
+--
+-- > delete undefined s == undefined
diff --git a/src/Set/Internal.hs b/src/Set/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Set/Internal.hs
@@ -0,0 +1,1501 @@
+{-# language BangPatterns #-}
+{-# language PatternGuards #-}
+{-# language TypeFamilies #-}
+{-# language LambdaCase #-}
+{-# language FlexibleContexts #-}
+{-# language UndecidableInstances #-}
+{-# language MagicHash #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Set.Internal
+-- Copyright : (c) Daan Leijen 2002, (c) Edward Kmett 2017-2018
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- An efficient implementation of unpacked sets using backpack,
+-- based on Data.Set.Internal from containers.
+--
+-- These modules are intended to be imported qualified, to avoid name
+-- clashes with Prelude functions, e.g.
+--
+-- > import Data.Set (Set)
+-- > import qualified Data.Set as Set
+--
+-- The implementation of 'Set' 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,
+-- .
+-- * 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/\",
+-- .
+--
+-- 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'. Of course, left-biasing can only be observed
+-- when equality is an equivalence relation instead of structural
+-- equality.
+--
+-- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of
+-- this condition is not detected and if the size limit is exceeded, the
+-- behavior of the set is completely undefined.
+-----------------------------------------------------------------------------
+
+-- [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).
+--
+-- This isn't required here, because we get to know the Ord Key dictionary
+
+-- [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 IntSet, 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 Set 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 Set.Internal (
+ -- * Set type
+ Set(..)
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+ , isSubsetOf
+ , isProperSubsetOf
+
+ -- * Construction
+ , empty
+ , singleton
+ , insert
+ , delete
+
+ -- * Combine
+ , union
+ , unions
+ , difference
+ , intersection
+
+ -- * Filter
+ , filter
+ , takeWhileAntitone
+ , dropWhileAntitone
+ , spanAntitone
+ , partition
+ , split
+ , splitMember
+ , splitRoot
+
+ -- * Indexed
+ , lookupIndex
+ , findIndex
+ , elemAt
+ , deleteAt
+ , take
+ , drop
+ , splitAt
+
+ -- * Map
+ , map
+ , mapMonotonic
+
+ -- * Folds
+ , foldMap
+ , foldr
+ , foldl
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+
+ -- * Min\/Max
+ , lookupMin
+ , lookupMax
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , maxView
+ , minView
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , toDescList
+ , fromAscList
+ , fromDistinctAscList
+ , fromDescList
+ , fromDistinctDescList
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+
+ -- Internals (for testing)
+ , bin
+ , balanced
+ , link
+ , merge
+ ) where
+
+import Control.DeepSeq (NFData(rnf))
+import Data.Bits (shiftL, shiftR)
+import Data.Data
+import Data.Default.Class
+import qualified Data.List as List
+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+import GHC.Exts (build, lazy, isTrue#, reallyUnsafePtrEquality#)
+import qualified GHC.Exts as GHCExts
+import Prelude hiding (filter,foldMap,foldl,foldr,null,map,take,drop,splitAt)
+import Text.Read
+
+import Key
+
+-- | 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 #-}
+
+ptrEq :: a -> a -> Bool
+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)
+{-# inline ptrEq #-}
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 \\ --
+
+-- | /O(m*log(n\/m+1)), m <= n/. See 'difference'.
+(\\) :: Set -> Set -> Set
+(\\) = difference
+{-# inline (\\) #-}
+
+{--------------------------------------------------------------------
+ Sets are size balanced trees
+--------------------------------------------------------------------}
+-- | A set of values @a@.
+
+-- See Note: Order of constructors
+data Set = Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Key !Set !Set | Tip
+
+instance Default Set where
+ def = Tip
+
+type Size = Int
+
+instance Monoid Set where
+ mempty = empty
+ mconcat = unions
+ mappend = (<>)
+
+instance Semigroup Set where
+ (<>) = union
+ stimes = stimesIdempotentMonoid
+
+foldMap :: Monoid m => (Key -> m) -> Set -> m
+foldMap f t = go t where
+ go Tip = mempty
+ go (Bin 1 k _ _) = f k
+ go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)
+{-# inline foldMap #-}
+
+instance Data Key => Data Set where
+ gfoldl f z set = z fromList `f` (toList set)
+ toConstr _ = fromListConstr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z fromList)
+ _ -> error "gunfold"
+ dataTypeOf _ = setDataType
+ -- dataCast1 f = gcast1 f
+
+fromListConstr :: Constr
+fromListConstr = mkConstr setDataType "fromList" [] Prefix
+
+setDataType :: DataType
+setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr]
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is this the empty set?
+null :: Set -> Bool
+null Tip = True
+null Bin {} = False
+{-# inline null #-}
+
+-- | /O(1)/. The number of elements in the set.
+size :: Set -> Int
+size Tip = 0
+size (Bin sz _ _ _) = sz
+{-# inline size #-}
+
+-- | /O(log n)/. Is the element in the set?
+member :: Key -> Set -> Bool
+member !_ Tip = False
+member x (Bin _ y l r) = case compare x y of
+ LT -> member x l
+ GT -> member x r
+ EQ -> True
+
+-- | /O(log n)/. Is the element not in the set?
+notMember :: Key -> Set -> Bool
+notMember a t = not $ member a t
+
+-- | /O(log n)/. Find largest element smaller than the given one.
+--
+-- > lookupLT 3 (fromList [3, 5]) == Nothing
+-- > lookupLT 5 (fromList [3, 5]) == Just 3
+lookupLT :: Key -> Set -> Maybe Key
+lookupLT = goNothing where
+ goNothing !_ Tip = Nothing
+ goNothing x (Bin _ y l r)
+ | x <= y = goNothing x l
+ | otherwise = goJust x y r
+ goJust !_ best Tip = Just best
+ goJust x best (Bin _ y l r)
+ | x <= y = goJust x best l
+ | otherwise = goJust x y r
+
+-- | /O(log n)/. Find smallest element greater than the given one.
+--
+-- > lookupGT 4 (fromList [3, 5]) == Just 5
+-- > lookupGT 5 (fromList [3, 5]) == Nothing
+lookupGT :: Key -> Set -> Maybe Key
+lookupGT = goNothing where
+ goNothing !_ Tip = Nothing
+ goNothing x (Bin _ y l r)
+ | x < y = goJust x y l
+ | otherwise = goNothing x r
+
+ goJust !_ best Tip = Just best
+ goJust x best (Bin _ y l r)
+ | x < y = goJust x y l
+ | otherwise = goJust x best r
+
+-- | /O(log n)/. Find largest element smaller or equal to the given one.
+--
+-- > lookupLE 2 (fromList [3, 5]) == Nothing
+-- > lookupLE 4 (fromList [3, 5]) == Just 3
+-- > lookupLE 5 (fromList [3, 5]) == Just 5
+lookupLE :: Key -> Set -> Maybe Key
+lookupLE = goNothing where
+ goNothing !_ Tip = Nothing
+ goNothing x (Bin _ y l r) = case compare x y of
+ LT -> goNothing x l
+ EQ -> Just y
+ GT -> goJust x y r
+
+ goJust !_ best Tip = Just best
+ goJust x best (Bin _ y l r) = case compare x y of
+ LT -> goJust x best l
+ EQ -> Just y
+ GT -> goJust x y r
+
+-- | /O(log n)/. Find smallest element greater or equal to the given one.
+--
+-- > lookupGE 3 (fromList [3, 5]) == Just 3
+-- > lookupGE 4 (fromList [3, 5]) == Just 5
+-- > lookupGE 6 (fromList [3, 5]) == Nothing
+lookupGE :: Key -> Set -> Maybe Key
+lookupGE = goNothing where
+ goNothing !_ Tip = Nothing
+ goNothing x (Bin _ y l r) = case compare x y of
+ LT -> goJust x y l
+ EQ -> Just y
+ GT -> goNothing x r
+
+ goJust !_ best Tip = Just best
+ goJust x best (Bin _ y l r) = case compare x y of
+ LT -> goJust x y l
+ EQ -> Just y
+ GT -> goJust x best r
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty set.
+empty :: Set
+empty = Tip
+{-# inline empty #-}
+
+-- | /O(1)/. Create a singleton set.
+singleton :: Key -> Set
+singleton x = Bin 1 x Tip Tip
+{-# inline singleton #-}
+
+{--------------------------------------------------------------------
+ Insertion, Deletion
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert an element in a set.
+-- If the set already contains an element equal to the given value,
+-- it is replaced with the new value.
+
+-- See Note: Type of local 'go' function
+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal)
+insert :: Key -> Set -> Set
+insert x0 = go x0 x0 where
+ go :: Key -> Key -> Set -> Set
+ go orig !_ Tip = singleton (lazy orig)
+ go orig !x t@(Bin sz y l r) = case compare x y of
+ LT | l' `ptrEq` l -> t
+ | otherwise -> balanceL y l' r
+ where !l' = go orig x l
+ GT | r' `ptrEq` r -> t
+ | otherwise -> balanceR y l r'
+ where !r' = go orig x r
+ EQ | lazy orig `seq` (orig `ptrEq` y) -> t
+ | otherwise -> Bin sz (lazy orig) l r
+
+-- Insert an element to the set only if it is not in the set.
+-- Used by `union`.
+
+-- See Note: Type of local 'go' function
+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal)
+insertR :: Key -> Set -> Set
+insertR x0 = go x0 x0 where
+ go :: Key -> Key -> Set -> Set
+ go orig !_ Tip = singleton (lazy orig)
+ go orig !x t@(Bin _ y l r) = case compare x y of
+ LT | l' `ptrEq` l -> t
+ | otherwise -> balanceL y l' r
+ where !l' = go orig x l
+ GT | r' `ptrEq` r -> t
+ | otherwise -> balanceR y l r'
+ where !r' = go orig x r
+ EQ -> t
+
+-- | /O(log n)/. Delete an element from a set.
+
+-- See Note: Type of local 'go' function
+delete :: Key -> Set -> Set
+delete = go where
+ go :: Key -> Set -> Set
+ go !_ Tip = Tip
+ go x t@(Bin _ y l r) = case compare x y of
+ LT | l' `ptrEq` l -> t
+ | otherwise -> balanceR y l' r
+ where !l' = go x l
+ GT | r' `ptrEq` r -> t
+ | otherwise -> balanceL y l r'
+ where !r' = go x r
+ EQ -> glue l r
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
+isProperSubsetOf :: Set -> Set -> Bool
+isProperSubsetOf s1 s2 = size s1 < size s2 && isSubsetOf s1 s2
+
+-- | /O(n+m)/. Is this a subset?
+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
+isSubsetOf :: Set -> Set -> Bool
+isSubsetOf t1 t2 = size t1 <= size t2 && isSubsetOfX t1 t2
+
+isSubsetOfX :: Set -> Set -> Bool
+isSubsetOfX Tip _ = True
+isSubsetOfX _ Tip = False
+isSubsetOfX (Bin _ x l r) t = found && isSubsetOfX l lt && isSubsetOfX r gt where
+ (lt,found,gt) = splitMember x t
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+
+-- We perform call-pattern specialization manually on lookupMin
+-- and lookupMax. Otherwise, GHC doesn't seem to do it, which is
+-- unfortunate if, for example, someone uses findMin or findMax.
+
+lookupMinSure :: Key -> Set -> Key
+lookupMinSure x Tip = x
+lookupMinSure _ (Bin _ x l _) = lookupMinSure x l
+
+-- | /O(log n)/. The minimal element of a set.
+--
+-- @since 0.5.9
+
+lookupMin :: Set -> Maybe Key
+lookupMin Tip = Nothing
+lookupMin (Bin _ x l _) = Just $! lookupMinSure x l
+
+-- | /O(log n)/. The minimal element of a set.
+findMin :: Set -> Key
+findMin t
+ | Just r <- lookupMin t = r
+ | otherwise = error "Set.findMin: empty set has no minimal element"
+
+lookupMaxSure :: Key -> Set -> Key
+lookupMaxSure x Tip = x
+lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r
+
+-- | /O(log n)/. The maximal element of a set.
+--
+-- @since 0.5.9
+
+lookupMax :: Set -> Maybe Key
+lookupMax Tip = Nothing
+lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r
+
+-- | /O(log n)/. The maximal element of a set.
+findMax :: Set -> Key
+findMax t
+ | Just r <- lookupMax t = r
+ | otherwise = error "Set.findMax: empty set has no maximal element"
+
+-- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty.
+deleteMin :: Set -> Set
+deleteMin (Bin _ _ Tip r) = r
+deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r
+deleteMin Tip = Tip
+
+-- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty.
+deleteMax :: Set -> Set
+deleteMax (Bin _ _ l Tip) = l
+deleteMax (Bin _ x l r) = balanceL x l (deleteMax r)
+deleteMax Tip = Tip
+
+{--------------------------------------------------------------------
+ Union.
+--------------------------------------------------------------------}
+-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
+unions :: [Set] -> Set
+unions = List.foldl' union empty
+
+-- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when
+-- equal elements are encountered.
+union :: Set -> Set -> Set
+union t1 Tip = t1
+union t1 (Bin _ x Tip Tip) = insertR x t1
+union (Bin _ x Tip Tip) t2 = insert x t2
+union Tip t2 = t2
+union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of
+ (l2 :*: r2)
+ | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1
+ | otherwise -> link x l1l2 r1r2
+ where !l1l2 = union l1 l2
+ !r1r2 = union r1 r2
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets.
+difference :: Set -> Set -> Set
+difference Tip _ = Tip
+difference t1 Tip = t1
+difference t1 (Bin _ x l2 r2) = case split x t1 of
+ (l1, r1)
+ | size l1l2 + size r1r2 == size t1 -> t1
+ | otherwise -> merge l1l2 r1r2
+ where !l1l2 = difference l1 l2
+ !r1r2 = difference r1 r2
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(m*log(n\/m + 1)), m <= n/. The intersection of two sets.
+-- Keyents of the result come from the first set, so for example
+--
+-- > import qualified Data.Set as S
+-- > data AB = A | B deriving Show
+-- > instance Ord AB where compare _ _ = EQ
+-- > instance Eq AB where _ == _ = True
+-- > main = print (S.singleton A `S.intersection` S.singleton B,
+-- > S.singleton B `S.intersection` S.singleton A)
+--
+-- prints @(fromList [A],fromList [B])@.
+intersection :: Set -> Set -> Set
+intersection Tip _ = Tip
+intersection _ Tip = Tip
+intersection t1@(Bin _ x l1 r1) t2
+ | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1
+ then t1
+ else link x l1l2 r1r2
+ | otherwise = merge l1l2 r1r2
+ where
+ !(l2, b, r2) = splitMember x t2
+ !l1l2 = intersection l1 l2
+ !r1r2 = intersection r1 r2
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy the predicate.
+filter :: (Key -> Bool) -> Set -> Set
+filter _ Tip = Tip
+filter p t@(Bin _ x l r)
+ | p x = if l `ptrEq` l' && r `ptrEq` r'
+ then t
+ else link x l' r'
+ | otherwise = merge l' r'
+ where
+ !l' = filter p l
+ !r' = filter p r
+
+-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
+-- the predicate and one with all elements that don't satisfy the predicate.
+-- See also 'split'.
+partition :: (Key -> Bool) -> Set -> (Set,Set)
+partition p0 t0 = toPair $ go p0 t0 where
+ go _ Tip = (Tip :*: Tip)
+ go p t@(Bin _ x l r) = case (go p l, go p r) of
+ ((l1 :*: l2), (r1 :*: r2))
+ | p x -> (if l1 `ptrEq` l && r1 `ptrEq` r
+ then t
+ else link x l1 r1) :*: merge l2 r2
+ | otherwise -> merge l1 r1 :*:
+ (if l2 `ptrEq` l && r2 `ptrEq` r
+ then t
+ else link x l2 r2)
+
+{----------------------------------------------------------------------
+ Map
+----------------------------------------------------------------------}
+
+-- | /O(n*log n)/.
+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+
+map :: (Key -> Key) -> Set -> Set
+map f = fromList . List.map f . toList
+
+-- | /O(n)/. The
+--
+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapMonotonic f s == map f s
+-- > where ls = toList s
+
+mapMonotonic :: (Key -> Key) -> Set -> Set
+mapMonotonic _ Tip = Tip
+mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+
+-- | /O(n)/. Fold the elements in the set using the given right-associative
+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.
+--
+-- For example,
+--
+-- > toAscList set = foldr (:) [] set
+foldr :: (Key -> b -> b) -> b -> Set -> 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' :: (Key -> b -> b) -> b -> Set -> 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 elements in the set using the given left-associative
+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.
+--
+-- For example,
+--
+-- > toDescList set = foldl (flip (:)) [] set
+foldl :: (a -> Key -> a) -> a -> Set -> 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 -> Key -> a) -> a -> Set -> 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' #-}
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.
+-- Subject to list fusion.
+elems :: Set -> [Key]
+elems = toAscList
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+instance GHCExts.IsList Set where
+ type Item Set = Key
+ fromList = fromList
+ toList = toList
+
+-- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.
+toList :: Set -> [Key]
+toList = toAscList
+
+-- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion.
+toAscList :: Set -> [Key]
+toAscList = foldr (:) []
+
+-- | /O(n)/. Convert the set to a descending list of elements. Subject to list
+-- fusion.
+toDescList :: Set -> [Key]
+toDescList = foldl (flip (:)) []
+
+-- List fusion for the list generating functions.
+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.
+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.
+foldrFB :: (Key -> b -> b) -> b -> Set -> b
+foldrFB = foldr
+{-# inline[0] foldrFB #-}
+
+foldlFB :: (a -> Key -> a) -> a -> Set -> a
+foldlFB = foldl
+{-# inline[0] foldlFB #-}
+
+-- Inline elems and toList, so that we need to fuse only toAscList.
+{-# inline elems #-}
+{-# inline toList #-}
+
+-- The fusion is enabled up to phase 2 included. If it does not succeed,
+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to
+-- 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 to{Asc,Desc}List -- it was forbidden to inline it
+-- before phase 0, otherwise the fusion rules would not fire at all.
+{-# NOinline[0] toAscList #-}
+{-# NOinline[0] toDescList #-}
+{-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}
+{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}
+{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}
+{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}
+
+-- | /O(n*log n)/. Create a set from a list of elements.
+--
+-- If the elements are ordered, a linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
+fromList :: [Key] -> Set
+fromList [] = Tip
+fromList [x] = Bin 1 x Tip Tip
+fromList (x0 : xs0)
+ | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0
+ | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+ where
+ not_ordered _ [] = False
+ not_ordered x (y : _) = x >= y
+ {-# inline not_ordered #-}
+
+ fromList' t0 xs = List.foldl' ins t0 xs where ins t x = insert x t
+
+ go !_ t [] = t
+ go _ t [x] = insertMax x t
+ go s l xs@(x : xss) | not_ordered x xss = fromList' l xs
+ | otherwise = case create s xss of
+ (r, ys, []) -> go (s `shiftL` 1) (link x l r) ys
+ (r, _, ys) -> fromList' (link 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@(x : xss)
+ | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)
+ else (Bin 1 x Tip Tip, xss, [])
+ | otherwise = case create (s `shiftR` 1) xs of
+ res@(_, [], _) -> res
+ (l, [y], zs) -> (insertMax y l, [], zs)
+ (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)
+ | otherwise -> case create (s `shiftR` 1) yss of
+ (r, zs, ws) -> (link y l r, zs, ws)
+
+{--------------------------------------------------------------------
+ Building trees from ascending/descending lists can be done in linear time.
+
+ Note that if [xs] is ascending that:
+ fromAscList xs == fromList xs
+--------------------------------------------------------------------}
+-- | /O(n)/. Build a set from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+fromAscList :: [Key] -> Set
+fromAscList xs = fromDistinctAscList (combineEq xs)
+
+-- | /O(n)/. Build a set from a descending list in linear time.
+-- /The precondition (input list is descending) is not checked./
+fromDescList :: [Key] -> Set
+fromDescList xs = fromDistinctDescList (combineEq xs)
+
+-- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
+--
+-- TODO: combineEq allocates an intermediate list. It *should* be better to
+-- make fromAscListBy and fromDescListBy the fundamental operations, and to
+-- implement the rest using those.
+combineEq :: [Key] -> [Key]
+combineEq [] = []
+combineEq (x : xs) = combineEq' x xs
+ where
+ combineEq' z [] = [z]
+ combineEq' z (y:ys)
+ | z == y = combineEq' z ys
+ | otherwise = z : combineEq' y ys
+
+-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
+-- /The precondition (input list is strictly ascending) is not checked./
+
+-- For some reason, when 'singleton' is used in fromDistinctAscList or in
+-- create, it is not inlined, so we inline it manually.
+fromDistinctAscList :: [Key] -> Set
+fromDistinctAscList [] = Tip
+fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+ where
+ go !_ t [] = t
+ go s l (x : xs) = case create s xs of
+ (r :*: ys) -> let !t' = link x l r
+ in go (s `shiftL` 1) t' ys
+
+ create !_ [] = (Tip :*: [])
+ create s xs@(x : xs')
+ | s == 1 = (Bin 1 x Tip Tip :*: xs')
+ | otherwise = case create (s `shiftR` 1) xs of
+ res@(_ :*: []) -> res
+ (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of
+ (r :*: zs) -> (link y l r :*: zs)
+
+-- | /O(n)/. Build a set from a descending list of distinct elements in linear time.
+-- /The precondition (input list is strictly descending) is not checked./
+
+-- For some reason, when 'singleton' is used in fromDistinctDescList or in
+-- create, it is not inlined, so we inline it manually.
+fromDistinctDescList :: [Key] -> Set
+fromDistinctDescList [] = Tip
+fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+ where
+ go !_ t [] = t
+ go s r (x : xs) = case create s xs of
+ (l :*: ys) -> let !t' = link x l r
+ in go (s `shiftL` 1) t' ys
+
+ create !_ [] = (Tip :*: [])
+ create s xs@(x : xs')
+ | s == 1 = (Bin 1 x Tip Tip :*: xs')
+ | otherwise = case create (s `shiftR` 1) xs of
+ res@(_ :*: []) -> res
+ (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of
+ (l :*: zs) -> (link y l r :*: zs)
+
+{--------------------------------------------------------------------
+ Eq converts the set 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 Set where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord Set where
+ compare s1 s2 = compare (toAscList s1) (toAscList s2)
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show Key => Show Set where
+ showsPrec p xs = showParen (p > 10) $
+ showString "fromList " . shows (toList xs)
+
+{--------------------------------------------------------------------
+ Read
+--------------------------------------------------------------------}
+instance Read Key => Read Set where
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+
+ readListPrec = readListPrecDefault
+
+{--------------------------------------------------------------------
+ NFData
+--------------------------------------------------------------------}
+
+instance NFData Key => NFData Set where
+ rnf Tip = ()
+ rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r
+
+{--------------------------------------------------------------------
+ Split
+--------------------------------------------------------------------}
+-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
+-- comprises the elements of @set@ greater than @x@.
+split :: Key -> Set -> (Set,Set)
+split x t = toPair $ splitS x t
+
+splitS :: Key -> Set -> StrictPair Set Set
+splitS _ Tip = (Tip :*: Tip)
+splitS x (Bin _ y l r) = case compare x y of
+ LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r)
+ GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt)
+ EQ -> (l :*: r)
+
+-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+splitMember :: Key -> Set -> (Set,Bool,Set)
+splitMember _ Tip = (Tip, False, Tip)
+splitMember x (Bin _ y l r) = case compare x y of
+ LT -> let (lt, found, gt) = splitMember x l
+ !gt' = link y gt r
+ in (lt, found, gt')
+ GT -> let (lt, found, gt) = splitMember x r
+ !lt' = link y l lt
+ in (lt', found, gt)
+ EQ -> (l, True, r)
+
+{--------------------------------------------------------------------
+ Indexing
+--------------------------------------------------------------------}
+
+-- | /O(log n)/. Return the /index/ of an element, which is its zero-based
+-- index in the sorted sequence of elements. The index is a number from /0/ up
+-- to, but not including, the 'size' of the set. Calls 'error' when the element
+-- is not a 'member' of the set.
+--
+-- > findIndex 2 (fromList [5,3]) Error: element is not in the set
+-- > findIndex 3 (fromList [5,3]) == 0
+-- > findIndex 5 (fromList [5,3]) == 1
+-- > findIndex 6 (fromList [5,3]) Error: element is not in the set
+
+-- See Note: Type of local 'go' function
+findIndex :: Key -> Set -> Int
+findIndex = go 0 where
+ go :: Int -> Key -> Set -> Int
+ go !_ !_ Tip = error "Set.findIndex: element is not in the set"
+ go idx x (Bin _ kx l r) = case compare x kx of
+ LT -> go idx x l
+ GT -> go (idx + size l + 1) x r
+ EQ -> idx + size l
+
+-- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in
+-- the sorted sequence of elements. The index is a number from /0/ up to, but not
+-- including, the 'size' of the set.
+--
+-- > isJust (lookupIndex 2 (fromList [5,3])) == False
+-- > fromJust (lookupIndex 3 (fromList [5,3])) == 0
+-- > fromJust (lookupIndex 5 (fromList [5,3])) == 1
+-- > isJust (lookupIndex 6 (fromList [5,3])) == False
+
+-- See Note: Type of local 'go' function
+lookupIndex :: Key -> Set -> Maybe Int
+lookupIndex = go 0 where
+ go :: Int -> Key -> Set -> Maybe Int
+ go !_ !_ Tip = Nothing
+ go idx x (Bin _ kx l r) = case compare x kx of
+ LT -> go idx x l
+ GT -> go (idx + size l + 1) x r
+ EQ -> Just $! idx + size l
+
+-- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based
+-- index in the sorted sequence of elements. If the /index/ is out of range (less
+-- than zero, greater or equal to 'size' of the set), 'error' is called.
+--
+-- > elemAt 0 (fromList [5,3]) == 3
+-- > elemAt 1 (fromList [5,3]) == 5
+-- > elemAt 2 (fromList [5,3]) Error: index out of range
+
+elemAt :: Int -> Set -> Key
+elemAt !_ Tip = error "Set.elemAt: index out of range"
+elemAt i (Bin _ x l r) = case compare i sizeL of
+ LT -> elemAt i l
+ GT -> elemAt (i-sizeL-1) r
+ EQ -> x
+ where sizeL = size l
+
+-- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in
+-- the sorted sequence of elements. If the /index/ is out of range (less than zero,
+-- greater or equal to 'size' of the set), 'error' is called.
+--
+-- > deleteAt 0 (fromList [5,3]) == singleton 5
+-- > deleteAt 1 (fromList [5,3]) == singleton 3
+-- > deleteAt 2 (fromList [5,3]) Error: index out of range
+-- > deleteAt (-1) (fromList [5,3]) Error: index out of range
+
+deleteAt :: Int -> Set -> Set
+deleteAt !i t = case t of
+ Tip -> error "Set.deleteAt: index out of range"
+ Bin _ x l r -> case compare i sizeL of
+ LT -> balanceR x (deleteAt i l) r
+ GT -> balanceL x l (deleteAt (i-sizeL-1) r)
+ EQ -> glue l r
+ where
+ sizeL = size l
+
+-- | Take a given number of elements in order, beginning
+-- with the smallest ones.
+--
+-- @
+-- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'
+-- @
+take :: Int -> Set -> Set
+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 _ x l r) = case compare i sizeL of
+ LT -> go i l
+ GT -> link x l (go (i - sizeL - 1) r)
+ EQ -> l
+ where sizeL = size l
+
+-- | Drop a given number of elements in order, beginning
+-- with the smallest ones.
+--
+-- @
+-- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'
+-- @
+drop :: Int -> Set -> Set
+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 _ x l r) =
+ case compare i sizeL of
+ LT -> link x (go i l) r
+ GT -> go (i - sizeL - 1) r
+ EQ -> insertMin x r
+ where sizeL = size l
+
+-- | /O(log n)/. Split a set at a particular index.
+--
+-- @
+-- splitAt !n !xs = ('take' n xs, 'drop' n xs)
+-- @
+splitAt :: Int -> Set -> (Set, Set)
+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 _ x l r) = case compare i sizeL of
+ LT -> case go i l of
+ ll :*: lr -> ll :*: link x lr r
+ GT -> case go (i - sizeL - 1) r of
+ rl :*: rr -> link x l rl :*: rr
+ EQ -> l :*: insertMin x r
+ where sizeL = size l
+
+-- | /O(log n)/. Take while a predicate on the elements holds.
+-- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,
+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.
+--
+-- @
+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'
+-- takeWhileAntitone p = 'filter' p
+-- @
+
+takeWhileAntitone :: (Key -> Bool) -> Set -> Set
+takeWhileAntitone _ Tip = Tip
+takeWhileAntitone p (Bin _ x l r)
+ | p x = link x l (takeWhileAntitone p r)
+ | otherwise = takeWhileAntitone p l
+
+-- | /O(log n)/. Drop while a predicate on the elements holds.
+-- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,
+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.
+--
+-- @
+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'
+-- dropWhileAntitone p = 'filter' (not . p)
+-- @
+
+dropWhileAntitone :: (Key -> Bool) -> Set -> Set
+dropWhileAntitone _ Tip = Tip
+dropWhileAntitone p (Bin _ x l r)
+ | p x = dropWhileAntitone p r
+ | otherwise = link x (dropWhileAntitone p l) r
+
+-- | /O(log n)/. Divide a set at the point where a predicate on the elements stops holding.
+-- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,
+-- @j \< k ==\> p j \>= p k@.
+--
+-- @
+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)
+-- spanAntitone p xs = partition p xs
+-- @
+--
+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set
+-- at some /unspecified/ point where the predicate switches from holding to not
+-- holding (where the predicate is seen to hold before the first element and to fail
+-- after the last element).
+
+spanAntitone :: (Key -> Bool) -> Set -> (Set, Set)
+spanAntitone p0 m = toPair (go p0 m) where
+ go _ Tip = Tip :*: Tip
+ go p (Bin _ x l r)
+ | p x = let u :*: v = go p r in link x l u :*: v
+ | otherwise = let u :*: v = go p l in u :*: link x v r
+
+
+{--------------------------------------------------------------------
+ Utility functions that maintain the balance properties of the tree.
+ All constructors assume that all values in [l] < [x] and all values
+ in [r] > [x], and that [l] and [r] are valid trees.
+
+ In order of sophistication:
+ [Bin sz x l r] The type constructor.
+ [bin x l r] Maintains the correct size, assumes that both [l]
+ and [r] are balanced with respect to each other.
+ [balance 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 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.
+ [merge l r] Merges two trees and restores balance.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ Link
+--------------------------------------------------------------------}
+link :: Key -> Set -> Set -> Set
+link x Tip r = insertMin x r
+link x l Tip = insertMax x l
+link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
+ | delta*sizeL < sizeR = balanceL z (link x l lz) rz
+ | delta*sizeR < sizeL = balanceR y ly (link x ry r)
+ | otherwise = bin x l r
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: Key -> Set -> Set
+insertMax x t = case t of
+ Tip -> singleton x
+ Bin _ y l r -> balanceR y l (insertMax x r)
+
+insertMin x t = case t of
+ Tip -> singleton x
+ Bin _ y l r -> balanceL y (insertMin x l) r
+
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Set -> Set -> Set
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
+ | delta*sizeL < sizeR = balanceL y (merge l ly) ry
+ | delta*sizeR < sizeL = balanceR x lx (merge 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 :: Set -> Set -> Set
+glue Tip r = r
+glue l Tip = l
+glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)
+ | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r
+ | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r'
+
+-- | /O(log n)/. Delete and find the minimal element.
+--
+-- > deleteFindMin set = (findMin set, deleteMin set)
+
+deleteFindMin :: Set -> (Key, Set)
+deleteFindMin t
+ | Just r <- minView t = r
+ | otherwise = (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
+
+-- | /O(log n)/. Delete and find the maximal element.
+--
+-- > deleteFindMax set = (findMax set, deleteMax set)
+deleteFindMax :: Set -> (Key, Set)
+deleteFindMax t
+ | Just r <- maxView t = r
+ | otherwise = (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
+
+minViewSure :: Key -> Set -> Set -> StrictPair Key Set
+minViewSure = go where
+ go x Tip r = x :*: r
+ go x (Bin _ xl ll lr) r = case go xl ll lr of
+ xm :*: l' -> xm :*: balanceR x l' r
+
+-- | /O(log n)/. Retrieves the minimal key of the set, and the set
+-- stripped of that element, or 'Nothing' if passed an empty set.
+minView :: Set -> Maybe (Key, Set)
+minView Tip = Nothing
+minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r
+
+maxViewSure :: Key -> Set -> Set -> StrictPair Key Set
+maxViewSure = go where
+ go x l Tip = x :*: l
+ go x l (Bin _ xr rl rr) = case go xr rl rr of
+ xm :*: r' -> xm :*: balanceL x l r'
+
+-- | /O(log n)/. Retrieves the maximal key of the set, and the set
+-- stripped of that element, or 'Nothing' if passed an empty set.
+maxView :: Set -> Maybe (Key, Set)
+maxView Tip = Nothing
+maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r
+
+{--------------------------------------------------------------------
+ [balance x l 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 correspondes 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 errorneous:
+ - 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 :: a -> Set a -> Set a -> Set a
+-- balance x l r
+-- | sizeL + sizeR <= 1 = Bin sizeX x l r
+-- | sizeR > delta*sizeL = rotateL x l r
+-- | sizeL > delta*sizeR = rotateR x l r
+-- | otherwise = Bin sizeX x l r
+-- where
+-- sizeL = size l
+-- sizeR = size r
+-- sizeX = sizeL + sizeR + 1
+--
+-- rotateL :: a -> Set a -> Set a -> Set a
+-- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r
+-- | otherwise = doubleL x l r
+-- rotateR :: a -> Set a -> Set a -> Set a
+-- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r
+-- | otherwise = doubleR x l r
+--
+-- singleL, singleR :: a -> Set a -> Set a -> Set a
+-- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
+-- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
+--
+-- doubleL, doubleR :: a -> Set a -> Set a -> Set a
+-- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
+-- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
+--
+-- It is only written in such a way that every node is pattern-matched only once.
+--
+-- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.
+-- In case it is needed, it can be found in Data.Map.
+
+-- 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 :: Key -> Set -> Set -> Set
+balanceL x l r = case r of
+ Tip -> case l of
+ Tip -> Bin 1 x Tip Tip
+ Bin _ _ Tip Tip -> Bin 2 x l Tip
+ Bin _ lx Tip (Bin _ lrx _ _) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
+ Bin _ lx ll@(Bin _ _ _ _) Tip -> Bin 3 lx ll (Bin 1 x Tip Tip)
+ Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr)
+ | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
+ | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
+
+ Bin rs _ _ _ -> case l of
+ Tip -> Bin (1+rs) x Tip r
+
+ Bin ls lx ll lr
+ | ls > delta*rs -> case (ll, lr) of
+ (Bin lls _ _ _, Bin lrs lrx lrl lrr)
+ | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
+ | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
+ (_, _) -> error "Failure in Data.Map.balanceL"
+ | otherwise -> Bin (1+ls+rs) 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 :: Key -> Set -> Set -> Set
+balanceR x l r = case l of
+ Tip -> case r of
+ Tip -> Bin 1 x Tip Tip
+ Bin _ _ Tip Tip -> Bin 2 x Tip r
+ Bin _ rx Tip rr@(Bin _ _ _ _) -> Bin 3 rx (Bin 1 x Tip Tip) rr
+ Bin _ rx (Bin _ rlx _ _) Tip -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
+ Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _)
+ | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
+ | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
+
+ Bin ls _ _ _ -> case r of
+ Tip -> Bin (1+ls) x l Tip
+
+ Bin rs rx rl rr
+ | rs > delta*ls -> case (rl, rr) of
+ (Bin rls rlx rll rlr, Bin rrs _ _ _)
+ | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
+ | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
+ (_, _) -> error "Failure in Data.Map.balanceR"
+ | otherwise -> Bin (1+ls+rs) x l r
+{-# noinline balanceR #-}
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: Key -> Set -> Set -> Set
+bin x l r
+ = Bin (size l + size r + 1) x l r
+{-# inline bin #-}
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+
+-- | /O(1)/. Decompose a set into pieces based on the structure of the underlying
+-- tree. This function is useful for consuming a set 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 subset less than all
+-- elements in the second, and so on).
+--
+-- Examples:
+--
+-- > splitRoot (fromList [1..6]) ==
+-- > [fromList [1,2,3],fromList [4],fromList [5,6]]
+--
+-- > splitRoot empty == []
+--
+-- Note that the current implementation does not return more than three subsets,
+-- but you should not depend on this behaviour because it can change in the
+-- future without notice.
+splitRoot :: Set -> [Set]
+splitRoot orig = case orig of
+ Tip -> []
+ Bin _ v l r -> [l, singleton v, r]
+{-# inline splitRoot #-}
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Show Key => Set -> String
+showTree s = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the set. 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.
+
+> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
+> 4
+> +--2
+> | +--1
+> | +--3
+> +--5
+>
+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
+> 4
+> |
+> +--2
+> | |
+> | +--1
+> | |
+> | +--3
+> |
+> +--5
+>
+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
+> +--5
+> |
+> 4
+> |
+> | +--3
+> | |
+> +--2
+> |
+> +--1
+
+-}
+showTreeWith :: Show Key => Bool -> Bool -> Set -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Show Key => Bool -> [String] -> [String] -> Set -> ShowS
+showsTree wide lbars rbars t = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin _ x Tip Tip -> showsBars lbars . shows x . showString "\n"
+ Bin _ x l r ->
+ showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . shows x . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: Show Key => Bool -> [String] -> Set -> ShowS
+showsTreeHang wide bars t = case t of
+ Tip -> showsBars bars . showString "|\n"
+ Bin _ x Tip Tip -> showsBars bars . shows x . showString "\n"
+ Bin _ x l r ->
+ showsBars bars . shows x . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang 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 set structure is valid.
+valid :: Set -> Bool
+valid t = balanced t && ordered t && validsize t
+
+ordered :: Set -> Bool
+ordered t = bounded (const True) (const True) t where
+ bounded lo hi t' = case t' of
+ Tip -> True
+ Bin _ x l r -> (lo x) && (hi x) && bounded lo (x) hi r
+
+balanced :: Set -> 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
+
+validsize :: Set -> Bool
+validsize t = realsize t == Just (size t) where
+ realsize t' = case t' of
+ Tip -> Just 0
+ Bin sz _ l r -> case (realsize l,realsize r) of
+ (Just n, Just m) | n+m+1 == sz -> Just sz
+ _ -> Nothing
diff --git a/unpacked-containers.cabal b/unpacked-containers.cabal
new file mode 100644
--- /dev/null
+++ b/unpacked-containers.cabal
@@ -0,0 +1,81 @@
+name: unpacked-containers
+category: Language
+version: 0
+license: BSD2
+license-file: LICENSE
+cabal-version: 2.0
+author: Edward A. Kmett
+maintainer: Edward A. Kmett
+stability: experimental
+homepage: http://github.com/ekmett/unpacked-containers/
+bug-reports: http://github.com/ekmett/unpacked-containers/issues
+copyright: Copyright (C) 2017-2018 Edward A. Kmett
+build-type: Simple
+synopsis: Unpacked containers via backpack
+description: This backpack mixin package supplies unpacked sets and maps exploiting backpack's ability to unpack through signatures.
+extra-source-files:
+ README.md
+ CHANGELOG.md
+ LICENSE
+ include/containers.h
+
+source-repository head
+ type: git
+ location: git://github.com/ekmett/unpacked-containers.git
+
+library
+ default-language: Haskell2010
+ ghc-options: -Wall -O2
+ hs-source-dirs: src
+ signatures: Key
+ exposed-modules:
+ Map
+ Map.Internal
+ Map.Internal.Debug
+ Map.Lazy
+ Map.Merge.Lazy
+ Map.Merge.Strict
+ Map.Strict
+ Map.Strict.Internal
+ Set
+ Set.Internal
+
+ build-depends:
+ base >= 4.10 && < 5,
+ data-default-class ^>= 0.1,
+ deepseq ^>= 1.4,
+ utils
+
+-- separate internal library to avoid recompiling these all the time
+library utils
+ default-language: Haskell2010
+ hs-source-dirs: utils
+ include-dirs: include
+ ghc-options: -Wall -O2
+
+ build-depends:
+ base >= 4.10 && < 5,
+ deepseq >= 1.2 && < 1.5,
+ ghc-prim
+
+ exposed-modules:
+ Internal.BitUtil
+ Internal.BitQueue
+ Internal.StrictPair
+ Internal.State
+ Internal.StrictFold
+ Internal.StrictMaybe
+ Internal.PtrEquality
+
+-- we have to provide a module in another library that matches the signature
+library example
+ default-language: Haskell2010
+ hs-source-dirs: example
+ exposed-modules: Int
+ build-depends: base
+
+executable unpacked-set-example
+ default-language: Haskell2010
+ main-is: example/Main.hs
+ build-depends: base, unpacked-containers, example
+ mixins: unpacked-containers (Set as Int.Set) requires (Key as Int)
diff --git a/utils/Internal/BitQueue.hs b/utils/Internal/BitQueue.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/BitQueue.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Internal.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__.
+--
+-- This 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 Internal.BitQueue
+ ( BitQueue
+ , BitQueueB
+ , emptyQB
+ , snocQB
+ , buildQ
+ , unconsQ
+ , toListQ
+ ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Word (Word)
+#endif
+import Internal.BitUtil (shiftLL, shiftRL, wordSize)
+import Data.Bits ((.|.), (.&.), testBit)
+#if MIN_VERSION_base(4,8,0)
+import Data.Bits (countTrailingZeros)
+#elif MIN_VERSION_base(4,5,0)
+import Data.Bits (popCount)
+#endif
+
+#if !MIN_VERSION_base(4,5,0)
+-- We could almost certainly improve this fall-back (copied straight from the
+-- default definition in Data.Bits), but it hardly seems worth the trouble
+-- to speed things up on GHC 7.4 and below.
+countTrailingZeros :: Word -> Int
+countTrailingZeros x = go 0
+ where
+ go i | i >= wordSize = i
+ | testBit x i = i
+ | otherwise = go (i+1)
+
+#elif !MIN_VERSION_base(4,8,0)
+countTrailingZeros :: Word -> Int
+countTrailingZeros x = popCount ((x .&. (-x)) - 1)
+{-# INLINE countTrailingZeros #-}
+#endif
+
+-- A bit queue builder. We represent a double word using two words
+-- because we don't currently have access to proper double words.
+data BitQueueB = BQB {-# UNPACK #-} !Word
+ {-# UNPACK #-} !Word
+
+newtype BitQueue = BQ BitQueueB deriving Show
+
+-- Intended for debugging.
+instance Show BitQueueB where
+ show (BQB hi lo) = "BQ"++
+ show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0]
+ ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0])
+
+-- | Create an empty bit queue builder. This is represented as a single guard
+-- bit in the most significant position.
+emptyQB :: BitQueueB
+emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0
+{-# INLINE emptyQB #-}
+
+-- Shift the double word to the right by one bit.
+shiftQBR1 :: BitQueueB -> BitQueueB
+shiftQBR1 (BQB hi lo) = BQB hi' lo' where
+ lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
+ hi' = hi `shiftRL` 1
+{-# INLINE shiftQBR1 #-}
+
+-- | Enqueue a bit. This works by shifting the queue right one bit,
+-- then setting the most significant bit as requested.
+{-# INLINE snocQB #-}
+snocQB :: BitQueueB -> Bool -> BitQueueB
+snocQB bq b = case shiftQBR1 bq of
+ BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo
+
+-- | Convert a bit queue builder to a bit queue. This shifts in a new
+-- guard bit on the left, and shifts right until the old guard bit falls
+-- off.
+{-# INLINE buildQ #-}
+buildQ :: BitQueueB -> BitQueue
+buildQ (BQB hi 0) = BQ (BQB 0 lo') where
+ zeros = countTrailingZeros hi
+ lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros
+buildQ (BQB hi lo) = BQ (BQB hi' lo') where
+ zeros = countTrailingZeros lo
+ lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
+ hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))
+ lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros))
+ hi' = hi1 `shiftRL` zeros
+
+-- Test if the queue is empty, which occurs when theres
+-- nothing left but a guard bit in the least significant
+-- place.
+nullQ :: BitQueue -> Bool
+nullQ (BQ (BQB 0 1)) = True
+nullQ _ = False
+{-# INLINE nullQ #-}
+
+-- | Dequeue an element, or discover the queue is empty.
+unconsQ :: BitQueue -> Maybe (Bool, BitQueue)
+unconsQ q | nullQ q = Nothing
+unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl)
+ where
+ !hd = (lo .&. 1) /= 0
+ !tl = shiftQBR1 bq
+{-# INLINE unconsQ #-}
+
+-- | Convert a bit queue to a list of bits by unconsing.
+-- This is used to test that the queue functions properly.
+toListQ :: BitQueue -> [Bool]
+toListQ bq = case unconsQ bq of
+ Nothing -> []
+ Just (hd, tl) -> hd : toListQ tl
diff --git a/utils/Internal/BitUtil.hs b/utils/Internal/BitUtil.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/BitUtil.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__
+{-# LANGUAGE MagicHash #-}
+#endif
+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Internal.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__.
+--
+-- This 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 Internal.BitUtil
+ ( bitcount
+ , highestBitMask
+ , shiftLL
+ , shiftRL
+ , wordSize
+ ) where
+
+import Data.Bits ((.|.), xor)
+#if MIN_VERSION_base(4,5,0)
+import Data.Bits (popCount, unsafeShiftL, unsafeShiftR)
+#else
+import Data.Bits ((.&.), shiftL, shiftR)
+#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
+#if MIN_VERSION_base(4,5,0)
+bitcount a x = a + popCount x
+#else
+bitcount a0 x0 = go a0 x0
+ where go a 0 = a
+ go a x = go (a + 1) (x .&. (x-1))
+#endif
+{-# 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
+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
+{-# INLINE highestBitMask #-}
+
+-- Right and left logical shifts.
+shiftRL, shiftLL :: Word -> Int -> Word
+#if MIN_VERSION_base(4,5,0)
+shiftRL = unsafeShiftR
+shiftLL = unsafeShiftL
+#else
+shiftRL = shiftR
+shiftLL = shiftL
+#endif
+
+{-# INLINE wordSize #-}
+wordSize :: Int
+#if MIN_VERSION_base(4,7,0)
+wordSize = finiteBitSize (0 :: Word)
+#else
+wordSize = bitSize (0 :: Word)
+#endif
diff --git a/utils/Internal/PtrEquality.hs b/utils/Internal/PtrEquality.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/PtrEquality.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE MagicHash #-}
+#endif
+
+{-# OPTIONS_HADDOCK hide #-}
+
+-- | Really unsafe pointer equality
+module Internal.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`
diff --git a/utils/Internal/State.hs b/utils/Internal/State.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/State.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+#include "containers.h"
+{-# OPTIONS_HADDOCK hide #-}
+
+-- | A clone of Control.Monad.State.Strict.
+module Internal.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)
diff --git a/utils/Internal/StrictFold.hs b/utils/Internal/StrictFold.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/StrictFold.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE CPP #-}
+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+{-# OPTIONS_HADDOCK hide #-}
+
+module Internal.StrictFold (foldlStrict) where
+
+-- | Same as regular 'Data.List.foldl'', but marked INLINE so that it is always
+-- inlined. This allows further optimization of the call to f, which can be
+-- optimized/specialised/inlined.
+
+foldlStrict :: (a -> b -> a) -> a -> [b] -> a
+foldlStrict f = go
+ where
+ go z [] = z
+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs
+{-# INLINE foldlStrict #-}
diff --git a/utils/Internal/StrictMaybe.hs b/utils/Internal/StrictMaybe.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/StrictMaybe.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE CPP #-}
+
+#include "containers.h"
+
+{-# OPTIONS_HADDOCK hide #-}
+-- | Strict 'Maybe'
+
+module Internal.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
diff --git a/utils/Internal/StrictPair.hs b/utils/Internal/StrictPair.hs
new file mode 100644
--- /dev/null
+++ b/utils/Internal/StrictPair.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE CPP #-}
+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
+{-# LANGUAGE Safe #-}
+#endif
+
+#include "containers.h"
+
+-- | A strict pair
+
+module Internal.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 #-}