packages feed

unpacked-containers (empty) → 0

raw patch · 26 files changed

+8602/−0 lines, 26 filesdep +basedep +data-default-classdep +deepseqsetup-changed

Dependencies added: base, data-default-class, deepseq, ghc-prim, unpacked-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0++* repository initialized
+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Int.hs view
@@ -0,0 +1,3 @@+module Int where++type Key = Int
+ example/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Int.Set++ten :: Set+ten = fromList [1..10]++main :: IO ()+main = print ten
+ include/containers.h view
@@ -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
+ src/Key.hsig view
@@ -0,0 +1,5 @@+signature Key where++data Key +instance Eq Key+instance Ord Key
+ src/Map.hs view
@@ -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,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of+-- this condition is not detected and if the size limit is exceeded, its+-- behaviour is undefined.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+-----------------------------------------------------------------------------++module Map+    ( module Map.Lazy+    ) where++import Prelude hiding (foldr)+import Map.Lazy
+ src/Map/Internal.hs view
@@ -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 <ekmett@gmail.com>+-- 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,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note(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 #-}+
+ src/Map/Internal/Debug.hs view
@@ -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) l && bounded (>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
+ src/Map/Lazy.hs view
@@ -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+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import qualified 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,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-----------------------------------------------------------------------------++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 ()
+ src/Map/Merge/Lazy.hs view
@@ -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
+ src/Map/Merge/Strict.hs view
@@ -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
+ src/Map/Strict.hs view
@@ -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+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import qualified 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,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of 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 ()
+ src/Map/Strict/Internal.hs view
@@ -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,+--     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of+-- this condition is not detected and if the size limit is exceeded, its+-- behaviour is undefined.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+--+-- Be aware that the 'Functor', 'Traversable' and 'Data' 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)
+ src/Set.hs view
@@ -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,+--      <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.  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
+ src/Set/Internal.hs view
@@ -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,+--      <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Just Join for Parallel Ordered Sets/\",+--      <https://arxiv.org/abs/1602.02120v3>.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.  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) l && bounded (>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
+ unpacked-containers.cabal view
@@ -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 <ekmett@gmail.com>+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)
+ utils/Internal/BitQueue.hs view
@@ -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
+ utils/Internal/BitUtil.hs view
@@ -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
+ utils/Internal/PtrEquality.hs view
@@ -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`
+ utils/Internal/State.hs view
@@ -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)
+ utils/Internal/StrictFold.hs view
@@ -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 #-}
+ utils/Internal/StrictMaybe.hs view
@@ -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
+ utils/Internal/StrictPair.hs view
@@ -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 #-}