mini-1.5.5.0: Mini/Data/Map.hs

-- incomplete patterns in 'fromDistinct{Asc,Desc}List'
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | A structure mapping unique keys to values
module Mini.Data.Map (
  -- * Type
  Map,

  -- * Primitive Recursion
  map,

  -- * Construction
  empty,
  singleton,
  fromList,
  fromListWith,
  fromListWithKey,
  fromAscList,
  fromAscListWith,
  fromAscListWithKey,
  fromDescList,
  fromDescListWith,
  fromDescListWithKey,
  fromDistinctAscList,
  fromDistinctDescList,

  -- * Combination
  compose,
  difference,
  differenceWith,
  differenceWithKey,
  intersection,
  intersectionWith,
  intersectionWithKey,
  union,
  unionWith,
  unionWithKey,
  unions,
  unionsWith,
  unionsWithKey,

  -- * Conversion
  toAscList,
  toDescList,

  -- * Fold
  foldlWithKey,
  foldrWithKey,

  -- * Modification
  adjust,
  adjustWithKey,
  adjustMax,
  adjustMaxWithKey,
  adjustMin,
  adjustMinWithKey,
  delete,
  deleteMax,
  deleteMin,
  filter,
  filterWithKey,
  insert,
  insertWith,
  insertWithKey,
  update,
  updateWithKey,
  updateMax,
  updateMaxWithKey,
  updateMin,
  updateMinWithKey,

  -- * Partition
  partition,
  partitionWithKey,
  split,
  splitMax,
  splitMin,

  -- * Query
  disjoint,
  isSubmapOf,
  isSubmapOfBy,
  lookup,
  lookupGE,
  lookupGT,
  lookupLE,
  lookupLT,
  lookupMax,
  lookupMin,
  member,
  null,
  size,

  -- * Traversal
  fmapWithKey,
  traverseWithKey,

  -- * Validation
  valid,

  -- * Examples
  -- $examples
) where

import Control.Applicative (
  liftA2,
  (<|>),
 )
import Data.Bifunctor (
  bimap,
  first,
  second,
 )
import Data.Bool (
  bool,
 )
import Data.Function (
  on,
 )
import Prelude (
  Applicative,
  Bool (
    False,
    True
  ),
  Eq,
  Foldable,
  Functor,
  Int,
  Maybe (
    Just,
    Nothing
  ),
  Monoid,
  Ord,
  Ordering (
    EQ,
    GT,
    LT
  ),
  Semigroup,
  Show,
  Traversable,
  compare,
  const,
  div,
  error,
  flip,
  fmap,
  foldl,
  foldr,
  fst,
  length,
  max,
  maybe,
  mempty,
  not,
  pure,
  show,
  splitAt,
  traverse,
  uncurry,
  until,
  ($),
  (&&),
  (*),
  (+),
  (-),
  (.),
  (<),
  (<$>),
  (<*>),
  (<>),
  (==),
  (>),
  (||),
 )

{-
 - Type
 -}

-- | A map from keys /k/ to values /a/, internally structured as an AVL tree
data Map k a
  = -- | Empty bin
    E
  | -- | Left-heavy bin
    L (Map k a) k a (Map k a)
  | -- | Balanced bin
    B (Map k a) k a (Map k a)
  | -- | Right-heavy bin
    R (Map k a) k a (Map k a)

instance (Eq k, Eq a) => Eq (Map k a) where
  (==) = (==) `on` toAscList

instance (Ord k, Ord a) => Ord (Map k a) where
  compare = compare `on` toAscList

instance (Show k, Show a) => Show (Map k a) where
  show = show . toAscList

instance Functor (Map k) where
  fmap = fmapWithKey . const

instance Foldable (Map k) where
  foldr = foldrWithKey . const

instance Traversable (Map k) where
  traverse = traverseWithKey . const

instance (Ord k) => Semigroup (Map k a) where
  (<>) = union

instance (Ord k) => Monoid (Map k a) where
  mempty = empty

{-
 - Primitive recursion
 -}

-- | Primitive recursion on maps (internally structured as trees)
map
  :: b
  -- ^ Value yielded in case of empty node
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of non-empty node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> Map k a
  -- ^ Object of the case analysis
  -> b
map e f = map' e f f f

-- Primitive recursion on maps
map'
  :: b
  -- ^ Value yielded in case of empty node
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of left-heavy node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of balanced node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of right-heavy node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> Map k a
  -- ^ Object of the case analysis
  -> b
map' e _ _ _ E = e
map' e f g h (L l k a r) = f l k a r (map' e f g h l) (map' e f g h r)
map' e f g h (B l k a r) = g l k a r (map' e f g h l) (map' e f g h r)
map' e f g h (R l k a r) = h l k a r (map' e f g h l) (map' e f g h r)

{-
 - Construction
 -}

-- | /O(1)/ The empty map
empty :: Map k a
empty = E

-- | /O(1)/ Make a map with a single bin
singleton :: k -> a -> Map k a
singleton k a = B E k a E

-- | /O(n log n)/ Make a map from a tail-biased list of @(key, value)@ pairs
fromList :: (Ord k) => [(k, a)] -> Map k a
fromList = fromListWithKey $ const const

-- | /O(n log n)/ Make a map from a list of pairs, combining matching keys
fromListWith :: (Ord k) => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith = fromListWithKey . const

-- | /O(n log n)/ Make a map from a list of pairs, combining matching keys
fromListWithKey :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromListWithKey f = foldl (flip . uncurry $ insertWithKey f) empty

-- | /O(n)/ Make a map from a tail-biased list of key-sorted pairs
fromAscList :: (Eq k) => [(k, a)] -> Map k a
fromAscList = fromDistinctAscList . essence

-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromAscListWith :: (Ord k) => (a -> a -> a) -> [(k, a)] -> Map k a
fromAscListWith = fromAscListWithKey . const

-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromAscListWithKey :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromAscListWithKey f = fromDistinctAscList . essenceWith f

-- | /O(n)/ Make a map from a tail-biased list of key-sorted pairs
fromDescList :: (Eq k) => [(k, a)] -> Map k a
fromDescList = fromDistinctDescList . essence

-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromDescListWith :: (Ord k) => (a -> a -> a) -> [(k, a)] -> Map k a
fromDescListWith = fromDescListWithKey . const

-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromDescListWithKey :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromDescListWithKey f = fromDistinctDescList . essenceWith f

-- | /O(n)/ Make a map from a sorted list of key-distinct pairs
fromDistinctAscList :: [(k, a)] -> Map k a
fromDistinctAscList = go <*> power
 where
  go [] _ = E
  go [(k, a)] _ = B E k a E
  go kas n =
    let len = length kas
        n' = n `div` 2
        c = bool B L $ len == n
        (l, (k, a) : r) = splitAt (len `div` 2) kas
     in c (go l n') k a (go r n')

-- | /O(n)/ Make a map from a sorted list of key-distinct pairs
fromDistinctDescList :: [(k, a)] -> Map k a
fromDistinctDescList = go <*> power
 where
  go [] _ = E
  go [(k, a)] _ = B E k a E
  go kas n =
    let len = length kas
        n' = n `div` 2
        c = bool B R $ len == n
        (l, (k, a) : r) = splitAt (len `div` 2) kas
     in c (go r n') k a (go l n')

{-
 - Combination
 -}

-- | /O(n log m)/ Compose the keys of one set with the values of another
compose :: (Ord b) => Map b c -> Map a b -> Map a c
compose t1 t2 = map' empty go go go t1
 where
  go _ _ _ _ _ _ =
    fromDistinctAscList $
      foldrWithKey
        (\a b ac -> maybe ac (\c -> (a, c) : ac) $ lookup b t1)
        []
        t2

-- | /O(m log n)/ Subtract a map by another via key matching
difference :: (Ord k) => Map k a -> Map k b -> Map k a
difference t1 t2 = map' empty go go go t1
 where
  go _ _ _ _ _ _ = foldrWithKey (\k _ b -> delete k b) t1 t2

-- | /O(m log n)/ Subtract a map by another, updating bins of matching keys
differenceWith
  :: (Ord k) => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
differenceWith = differenceWithKey . const

-- | /O(m log n)/ Subtract a map by another, updating bins of matching keys
differenceWithKey
  :: (Ord k) => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
differenceWithKey f t1 t2 = map' empty go go go t1
 where
  go _ _ _ _ _ _ =
    foldrWithKey
      ( \k b t' ->
          maybe
            t'
            ( \a ->
                maybe
                  (delete' k t')
                  (\a' -> insert k a' t')
                  $ f k a b
            )
            $ lookup k t1
      )
      t1
      t2

-- | /O(n log m)/ Intersect a map with another via left-biased key matching
intersection :: (Ord k) => Map k a -> Map k b -> Map k a
intersection = intersectionWithKey $ const const

-- | /O(n log m)/ Intersect a map with another by key matching, combining values
intersectionWith :: (Ord k) => (a -> b -> c) -> Map k a -> Map k b -> Map k c
intersectionWith = intersectionWithKey . const

-- | /O(n log m)/ Intersect a map with another by key matching, combining values
intersectionWithKey
  :: (Ord k) => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
intersectionWithKey f t1 t2 = map' empty go go go t2
 where
  go _ _ _ _ _ _ =
    fromDistinctAscList $
      foldrWithKey
        (\k a c -> maybe c (\b -> (k, f k a b) : c) $ lookup k t2)
        []
        t1

-- | /O(m log n)/ Unite a map with another via left-biased key matching
union :: (Ord k) => Map k a -> Map k a -> Map k a
union = unionWithKey $ const const

-- | /O(m log n)/ Unite a map with another, combining values of matching keys
unionWith :: (Ord k) => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith = unionWithKey . const

-- | /O(m log n)/ Unite a map with another, combining values of matching keys
unionWithKey :: (Ord k) => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWithKey f t1 t2 = map' t1 go go go t2
 where
  go _ _ _ _ _ _ = foldrWithKey (insertWithKey f) t2 t1

-- | Unite a collection of maps via left-biased key matching
unions :: (Foldable t, Ord k) => t (Map k a) -> Map k a
unions = unionsWithKey $ const const

-- | Unite a collection of maps, combining values of matching keys
unionsWith :: (Foldable t, Ord k) => (a -> a -> a) -> t (Map k a) -> Map k a
unionsWith = unionsWithKey . const

-- | Unite a collection of maps, combining values of matching keys
unionsWithKey :: (Foldable t, Ord k) => (k -> a -> a -> a) -> t (Map k a) -> Map k a
unionsWithKey f = foldr (unionWithKey f) empty

{-
 - Conversion
 -}

-- | /O(n)/ Turn a map into a list of @(key, value)@ pairs in ascending order
toAscList :: Map k a -> [(k, a)]
toAscList = foldrWithKey (\k a b -> (k, a) : b) []

-- | /O(n)/ Turn a map into a list of @(key, value)@ pairs in descending order
toDescList :: Map k a -> [(k, a)]
toDescList = foldlWithKey (\b k a -> (k, a) : b) []

{-
 - Fold
 -}

-- | /O(n)/ Reduce a map with a left-associative operation and an accumulator
foldlWithKey :: (b -> k -> a -> b) -> b -> Map k a -> b
foldlWithKey f b = map' b go go go
 where
  go _ k a r recl _ = foldlWithKey f (f recl k a) r

-- | /O(n)/ Reduce a map with a right-associative operation and an accumulator
foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
foldrWithKey f b = map' b go go go
 where
  go l k a _ _ recr = foldrWithKey f (f k a recr) l

{-
 - Modification
 -}

-- | /O(log n)/ Adjust with an operation the value of a key in a map
adjust :: (Ord k) => (a -> a) -> k -> Map k a -> Map k a
adjust = adjustWithKey . const

-- | /O(log n)/ Adjust with an operation the value of a key in a map
adjustWithKey :: (Ord k) => (k -> a -> a) -> k -> Map k a -> Map k a
adjustWithKey f k0 = map' E (go L) (go B) (go R)
 where
  go c l k a r recl recr = case compare k0 k of
    LT -> c recl k a r
    EQ -> c l k (f k a) r
    GT -> c l k a recr

-- | /O(log n)/ Adjust with an operation the value of the maximum key in a map
adjustMax :: (a -> a) -> Map k a -> Map k a
adjustMax = adjustMaxWithKey . const

-- | /O(log n)/ Adjust with an operation the value of the maximum key in a map
adjustMaxWithKey :: (k -> a -> a) -> Map k a -> Map k a
adjustMaxWithKey f = map' E (go L) (go B) (go R)
 where
  go c l k a r _ recr = map' (c l k (f k a) r) go' go' go' r
   where
    go' _ _ _ _ _ _ = c l k a recr

-- | /O(log n)/ Adjust with an operation the value of the minimum key in a map
adjustMin :: (a -> a) -> Map k a -> Map k a
adjustMin = adjustMinWithKey . const

-- | /O(log n)/ Adjust with an operation the value of the minimum key in a map
adjustMinWithKey :: (k -> a -> a) -> Map k a -> Map k a
adjustMinWithKey f = map' E (go L) (go B) (go R)
 where
  go c l k a r recl _ = map' (c l k (f k a) r) go' go' go' l
   where
    go' _ _ _ _ _ _ = c recl k a r

-- | /O(log n)/ Delete a key from a map
delete :: (Ord k) => k -> Map k a -> Map k a
delete k t = bool t (delete' k t) $ k `member` t

-- | /O(log n)/ Delete the maximum key from a map
deleteMax :: (Ord k) => Map k a -> Map k a
deleteMax t = maybe t (flip delete' t . fst) $ lookupMax t

-- | /O(log n)/ Delete the minimum key from a map
deleteMin :: (Ord k) => Map k a -> Map k a
deleteMin t = maybe t (flip delete' t . fst) $ lookupMin t

-- | /O(n)/ Keep the bins whose values satisfy a predicate
filter :: (a -> Bool) -> Map k a -> Map k a
filter = filterWithKey . const

-- | /O(n)/ Keep the bins whose keys and values satisfy a predicate
filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a
filterWithKey p =
  fromDistinctAscList
    . foldrWithKey (\k a b -> bool b ((k, a) : b) $ p k a) []

-- | /O(log n)/ Insert a key and its value into a map, overwriting if present
insert :: (Ord k) => k -> a -> Map k a -> Map k a
insert = insertWithKey $ const const

-- | /O(log n)/ Insert a key and its value, combining new and old if present
insertWith :: (Ord k) => (a -> a -> a) -> k -> a -> Map k a -> Map k a
insertWith = insertWithKey . const

-- | /O(log n)/ Modify the value of a key or delete its bin with an operation
update :: (Ord k) => (a -> Maybe a) -> k -> Map k a -> Map k a
update = updateWithKey . const

-- | /O(log n)/ Modify the value of a key or delete its bin with an operation
updateWithKey :: (Ord k) => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
updateWithKey f k t =
  maybe
    t
    ( maybe
        (delete' k t)
        (\a' -> insert k a' t)
        . f k
    )
    $ lookup k t

-- | /O(log n)/ Modify the value of the maximum key or delete its bin
updateMax :: (Ord k) => (a -> Maybe a) -> Map k a -> Map k a
updateMax = updateMaxWithKey . const

-- | /O(log n)/ Modify the value of the maximum key or delete its bin
updateMaxWithKey :: (Ord k) => (k -> a -> Maybe a) -> Map k a -> Map k a
updateMaxWithKey f t =
  maybe
    t
    ( \(k, a) ->
        maybe
          (delete' k t)
          (\a' -> insert k a' t)
          $ f k a
    )
    $ lookupMax t

-- | /O(log n)/ Modify the value of the minimum key or delete its bin
updateMin :: (Ord k) => (a -> Maybe a) -> Map k a -> Map k a
updateMin = updateMinWithKey . const

-- | /O(log n)/ Modify the value of the minimum key or delete its bin
updateMinWithKey :: (Ord k) => (k -> a -> Maybe a) -> Map k a -> Map k a
updateMinWithKey f t =
  maybe
    t
    ( \(k, a) ->
        maybe
          (delete' k t)
          (\a' -> insert k a' t)
          $ f k a
    )
    $ lookupMin t

{-
 - Partition
 -}

-- | /O(n)/ Partition a map with a predicate into @(true, false)@ submaps
partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a)
partition = partitionWithKey . const

-- | /O(n)/ Partition a map with a predicate into @(true, false)@ submaps
partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
partitionWithKey p =
  bimap fromDistinctAscList fromDistinctAscList
    . foldrWithKey
      (\k a -> bool second first (p k a) ((k, a) :))
      ([], [])

-- | /O(n)/ Split a map by a key into @(lt, eq, gt)@ submaps
split :: (Ord k) => k -> Map k a -> (Map k a, Maybe a, Map k a)
split k0 =
  (\(lt, a, gt) -> (fromDistinctAscList lt, a, fromDistinctAscList gt))
    . foldrWithKey
      ( \k a (lt, a', gt) -> case compare k k0 of
          LT -> ((k, a) : lt, a', gt)
          EQ -> (lt, Just a, gt)
          GT -> (lt, a', (k, a) : gt)
      )
      ([], Nothing, [])

-- | /O(log n)/ Split a map by its maximum key
splitMax :: (Ord k) => Map k a -> Maybe ((k, a), Map k a)
splitMax t = ((,) <*> flip delete' t . fst) <$> lookupMax t

-- | /O(log n)/ Split a map by its minimum key
splitMin :: (Ord k) => Map k a -> Maybe ((k, a), Map k a)
splitMin t = ((,) <*> flip delete' t . fst) <$> lookupMin t

{-
 - Query
 -}

-- | /O(m log n)/ Check whether two maps have no keys in common
disjoint :: (Ord k) => Map k a -> Map k a -> Bool
disjoint t1 t2 = map' True go go go t1
 where
  go _ _ _ _ _ _ = not $ foldrWithKey (\k _ b -> k `member` t1 || b) False t2

-- | /O(n log m)/ Check whether the bins of one map exist in the other
isSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool
isSubmapOf = isSubmapOfBy (==)

-- | /O(n log m)/ Check if the bins of one map exist in the other by combination
isSubmapOfBy :: (Ord k) => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
isSubmapOfBy p t1 t2 = map' (null t1) go go go t2
 where
  go _ _ _ _ _ _ =
    foldrWithKey
      (\k a b -> maybe False ((&& b) . p a) $ lookup k t2)
      True
      t1

-- | /O(log n)/ Fetch the value of a key in a map, or 'Nothing' if absent
lookup :: (Ord k) => k -> Map k a -> Maybe a
lookup k = map' Nothing go go go
 where
  go _ k' a _ recl recr = case compare k k' of
    LT -> recl
    EQ -> Just a
    GT -> recr

-- | /O(log n)/ Fetch the least bin greater than or equal to a key
lookupGE :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupGE k0 = map' Nothing go go go
 where
  go _ k a _ recl recr = case compare k k0 of
    LT -> recr
    EQ -> Just (k, a)
    GT -> recl <|> Just (k, a)

-- | /O(log n)/ Fetch the least bin strictly greater than a key
lookupGT :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupGT k0 = map' Nothing go go go
 where
  go _ k a _ recl recr = case compare k k0 of
    LT -> recr
    EQ -> recr
    GT -> recl <|> Just (k, a)

-- | /O(log n)/ Fetch the greatest bin less than or equal to a key
lookupLE :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupLE k0 = map' Nothing go go go
 where
  go _ k a _ recl recr = case compare k k0 of
    LT -> recr <|> Just (k, a)
    EQ -> Just (k, a)
    GT -> recl

-- | /O(log n)/ Fetch the greatest bin strictly less than a key
lookupLT :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupLT k0 = map' Nothing go go go
 where
  go _ k a _ recl recr = case compare k k0 of
    LT -> recr <|> Just (k, a)
    EQ -> recl
    GT -> recl

-- | /O(log n)/ Fetch the bin with the maximum key, or 'Nothing' if empty
lookupMax :: Map k a -> Maybe (k, a)
lookupMax = map' Nothing go go go
 where
  go _ k a r _ recr = map' (Just (k, a)) go' go' go' r
   where
    go' _ _ _ _ _ _ = recr

-- | /O(log n)/ Fetch the bin with the minimum key, or 'Nothing' if empty
lookupMin :: Map k a -> Maybe (k, a)
lookupMin = map' Nothing go go go
 where
  go l k a _ recl _ = map' (Just (k, a)) go' go' go' l
   where
    go' _ _ _ _ _ _ = recl

-- | /O(log n)/ Check whether a key is in a map
member :: (Ord k) => k -> Map k a -> Bool
member k0 = map' False go go go
 where
  go _ k _ _ recl recr = case compare k0 k of
    LT -> recl
    EQ -> True
    GT -> recr

-- | /O(1)/ Check whether a map is empty
null :: Map k a -> Bool
null = map' True go go go where go _ _ _ _ _ _ = False

-- | /O(n)/ Get the size of a map
size :: Map k a -> Int
size = map' 0 go go go where go _ _ _ _ recl recr = 1 + recl + recr

{-
 - Traversal
 -}

-- | /O(n)/ Apply an operation across a map, transforming its values
fmapWithKey :: (k -> a -> b) -> Map k a -> Map k b
fmapWithKey f = map' E (go L) (go B) (go R)
 where
  go c _ k a _ recl = c recl k (f k a)

-- | /O(n)/ Lift a map with a lifting operation on keys and values
traverseWithKey :: (Applicative f) => (k -> a -> f b) -> Map k a -> f (Map k b)
traverseWithKey f = map' (pure E) (go L) (go B) (go R)
 where
  go c _ k a _ recl recr = c <$> recl <*> pure k <*> f k a <*> recr

{-
 - Validation
 -}

-- | /O(n^2)/ Check whether a map is internally height-balanced and ordered
valid :: (Ord k) => Map k a -> Bool
valid = liftA2 (&&) balanced ordered
 where
  balanced =
    map'
      True
      (\l _ _ r recl recr -> levels l - levels r == 1 && recl && recr)
      (\l _ _ r recl recr -> levels l - levels r == 0 && recl && recr)
      (\l _ _ r recl recr -> levels r - levels l == 1 && recl && recr)
  levels = map' 0 go go go
   where
    go _ _ _ _ recl recr = 1 + max recl recr :: Int
  ordered = map' True go go go
   where
    go l k _ r recl recr =
      map' True lt lt lt l
        && map' True gt gt gt r
     where
      lt _ lk _ _ _ _ = lk < k && recl && recr
      gt _ rk _ _ _ _ = rk > k && recl && recr

{-
 - Helpers
 -}

-- O(n) 'nub' on keys for sorted lists of pairs
essence :: (Eq k) => [(k, a)] -> [(k, a)]
essence [] = []
essence (x : xs) = essence' x xs
 where
  essence' ka1 [] = [ka1]
  essence' ka1@(k1, _) (ka2@(k2, _) : kas) =
    let rest = essence' ka2 kas
     in bool (ka1 : rest) rest $ k1 == k2

-- O(n) 'nub' with a combining function for sorted lists of pairs
essenceWith :: (Eq k) => (k -> a -> a -> a) -> [(k, a)] -> [(k, a)]
essenceWith _ [] = []
essenceWith f (x : xs) = essenceWith' x xs
 where
  essenceWith' ka1 [] = [ka1]
  essenceWith' ka1@(k1, a1) (ka2@(k2, a2) : kas) =
    bool
      (ka1 : essenceWith' ka2 kas)
      (essenceWith' (k1, f k1 a2 a1) kas)
      $ k1 == k2

-- The greatest power of 2 <= the length of a non-empty collection
power :: (Foldable t) => t a -> Int
power as = until (> length as) (* 2) 2 `div` 2

{-
 - Let this comment serve as your warning. Return from whence you came and your
 - sanity will be spared. You have been admonished.
 -}

-- O(log n) Delete a key from a map without checking for membership
delete' :: (Ord k) => k -> Map k a -> Map k a
delete' k0 =
  map'
    (error "Map.delete: L0")
    ( \l k a r _ _ ->
        case compare k0 k of
          LT -> deleteLl l k a r
          EQ -> substituteL l r
          GT -> deleteLr l k a r
    )
    ( \l k a r _ _ ->
        case compare k0 k of
          LT -> deleteBl l k a r
          EQ -> substituteBr l r
          GT -> deleteBr l k a r
    )
    ( \l k a r _ _ ->
        case compare k0 k of
          LT -> deleteRl l k a r
          EQ -> substituteR l r
          GT -> deleteRr l k a r
    )
 where
  deleteRl l k a r =
    map'
      (error "Map.delete: L1")
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> checkLeftR (deleteLl ll lk la lr) k a r
            EQ -> checkLeftR (substituteL ll lr) k a r
            GT -> checkLeftR (deleteLr ll lk la lr) k a r
      )
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> R (deleteBl ll lk la lr) k a r
            EQ -> checkLeftR' (substituteBr ll lr) k a r
            GT -> R (deleteBr ll lk la lr) k a r
      )
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> checkLeftR (deleteRl ll lk la lr) k a r
            EQ -> checkLeftR (substituteR ll lr) k a r
            GT -> checkLeftR (deleteRr ll lk la lr) k a r
      )
      l
  deleteRr l k a =
    map'
      (error "Map.delete: L2")
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> checkRightR l k a (deleteLl rl rk ra rr)
            EQ -> checkRightR l k a (substituteL rl rr)
            GT -> checkRightR l k a (deleteLr rl rk ra rr)
      )
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> R l k a (deleteBl rl rk ra rr)
            EQ -> checkRightR' l k a (substituteBl rl rr)
            GT -> R l k a (deleteBr rl rk ra rr)
      )
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> checkRightR l k a (deleteRl rl rk ra rr)
            EQ -> checkRightR l k a (substituteR rl rr)
            GT -> checkRightR l k a (deleteRr rl rk ra rr)
      )
  deleteBl l k a r =
    map'
      (error "Map.delete: L3")
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> checkLeftB (deleteLl ll lk la lr) k a r
            EQ -> checkLeftB (substituteL ll lr) k a r
            GT -> checkLeftB (deleteLr ll lk la lr) k a r
      )
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> B (deleteBl ll lk la lr) k a r
            EQ -> checkLeftB' (substituteBr ll lr) k a r
            GT -> B (deleteBr ll lk la lr) k a r
      )
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> checkLeftB (deleteRl ll lk la lr) k a r
            EQ -> checkLeftB (substituteR ll lr) k a r
            GT -> checkLeftB (deleteRr ll lk la lr) k a r
      )
      l
  deleteBr l k a =
    map'
      (error "Map.delete: L4")
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> checkRightB l k a (deleteLl rl rk ra rr)
            EQ -> checkRightB l k a (substituteL rl rr)
            GT -> checkRightB l k a (deleteLr rl rk ra rr)
      )
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> B l k a (deleteBl rl rk ra rr)
            EQ -> checkRightB' l k a (substituteBl rl rr)
            GT -> B l k a (deleteBr rl rk ra rr)
      )
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> checkRightB l k a (deleteRl rl rk ra rr)
            EQ -> checkRightB l k a (substituteR rl rr)
            GT -> checkRightB l k a (deleteRr rl rk ra rr)
      )
  deleteLl l k a r =
    map'
      (error "Map.delete: L5")
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> checkLeftL (deleteLl ll lk la lr) k a r
            EQ -> checkLeftL (substituteL ll lr) k a r
            GT -> checkLeftL (deleteLr ll lk la lr) k a r
      )
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> L (deleteBl ll lk la lr) k a r
            EQ -> checkLeftL' (substituteBr ll lr) k a r
            GT -> L (deleteBr ll lk la lr) k a r
      )
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> checkLeftL (deleteRl ll lk la lr) k a r
            EQ -> checkLeftL (substituteR ll lr) k a r
            GT -> checkLeftL (deleteRr ll lk la lr) k a r
      )
      l
  deleteLr l k a =
    map'
      (error "Map.delete: L6")
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> checkRightL l k a (deleteLl rl rk ra rr)
            EQ -> checkRightL l k a (substituteL rl rr)
            GT -> checkRightL l k a (deleteLr rl rk ra rr)
      )
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> L l k a (deleteBl rl rk ra rr)
            EQ -> checkRightL' l k a (substituteBl rl rr)
            GT -> L l k a (deleteBr rl rk ra rr)
      )
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> checkRightL l k a (deleteRl rl rk ra rr)
            EQ -> checkRightL l k a (substituteR rl rr)
            GT -> checkRightL l k a (deleteRr rl rk ra rr)
      )
  rebalanceR l k a =
    map'
      (error "Map.delete: L7")
      ( \rl rk ra rr _ _ ->
          map'
            (error "Map.delete: L8")
            (\rll rlk rla rlr _ _ -> B (B l k a rll) rlk rla (R rlr rk ra rr))
            (\rll rlk rla rlr _ _ -> B (B l k a rll) rlk rla (B rlr rk ra rr))
            (\rll rlk rla rlr _ _ -> B (L l k a rll) rlk rla (B rlr rk ra rr))
            rl
      )
      (\rl rk ra rr _ _ -> L (R l k a rl) rk ra rr)
      (\rl rk ra rr _ _ -> B (B l k a rl) rk ra rr)
  rebalanceL l k a r =
    map'
      (error "Map.delete: L9")
      (\ll lk la lr _ _ -> B ll lk la (B lr k a r))
      (\ll lk la lr _ _ -> R ll lk la (L lr k a r))
      ( \ll lk la lr _ _ ->
          map'
            (error "Map.delete: L10")
            (\lrl lrk lra lrr _ _ -> B (B ll lk la lrl) lrk lra (R lrr k a r))
            (\lrl lrk lra lrr _ _ -> B (B ll lk la lrl) lrk lra (B lrr k a r))
            (\lrl lrk lra lrr _ _ -> B (L ll lk la lrl) lrk lra (B lrr k a r))
            lr
      )
      l
  checkLeftR l k a r =
    map'
      (error "Map.delete: L11")
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> rebalanceR l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      l
  checkLeftB l k a r =
    map'
      (error "Map.delete: L12")
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      l
  checkLeftL l k a r =
    map'
      (error "Map.delete: L13")
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      l
  checkRightR l k a r =
    map'
      (error "Map.delete: L14")
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      r
  checkRightB l k a r =
    map'
      (error "Map.delete: L15")
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      r
  checkRightL l k a r =
    map'
      (error "Map.delete: L16")
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> rebalanceL l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      r
  substituteR l =
    map'
      (error "Map.delete: L17")
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightR l k a r) $
            popLeftL rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightR' l k a r) $
            popLeftB rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightR l k a r) $
            popLeftR rl rk ra rr
      )
  substituteBr l =
    map'
      E
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightB l k a r) $
            popLeftL rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightB' l k a r) $
            popLeftB rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightB l k a r) $
            popLeftR rl rk ra rr
      )
  substituteBl l r =
    map'
      E
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftB l' k a r) $
            popRightL ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftB' l' k a r) $
            popRightB ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftB l' k a r) $
            popRightR ll lk la lr
      )
      l
  substituteL l r =
    map'
      (error "Map.delete: L18")
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftL l' k a r) $
            popRightL ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftL' l' k a r) $
            popRightB ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftL l' k a r) $
            popRightR ll lk la lr
      )
      l
  checkLeftR' l k a r =
    map'
      (rebalanceR l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      l
  checkLeftB' l k a r =
    map'
      (R l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      l
  checkLeftL' l k a r =
    map'
      (B l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      l
  checkRightR' l k a r =
    map'
      (B l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      r
  checkRightB' l k a r =
    map'
      (L l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      r
  checkRightL' l k a r =
    map'
      (rebalanceL l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      r
  popLeftR l k a r =
    map'
      (k, a, r)
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftR l' k a r)) $
            popLeftL ll lk la lr
      )
      (\ll lk la lr _ _ -> popLeftRB ll lk la lr k a r)
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftR l' k a r)) $
            popLeftR ll lk la lr
      )
      l
  popLeftB l k a r =
    map'
      (k, a, E)
      (\ll lk la lr _ _ -> popLeftBL ll lk la lr k a r)
      (\ll lk la lr _ _ -> popLeftBB ll lk la lr k a r)
      (\ll lk la lr _ _ -> popLeftBR ll lk la lr k a r)
      l
  popLeftL l k a r =
    map'
      (error "Map.delete: L19")
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftL l' k a r)) $
            popLeftL ll lk la lr
      )
      (\ll lk la lr _ _ -> popLeftLB ll lk la lr k a r)
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftL l' k a r)) $
            popLeftR ll lk la lr
      )
      l
  popLeftRB ll lk la lr k a r =
    map'
      (lk, la, rebalanceR E k a r)
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', R l k a r)) $
            popLeftBL lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', R l k a r)) $
            popLeftBB lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', R l k a r)) $
            popLeftBR lll llk lla llr lk la lr
      )
      ll
  popLeftBB ll lk la lr k a r =
    map'
      (lk, la, R E k a r)
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', B l k a r)) $
            popLeftBL lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', B l k a r)) $
            popLeftBB lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', B l k a r)) $
            popLeftBR lll llk lla llr lk la lr
      )
      ll
  popLeftLB ll lk la lr k a r =
    map'
      (lk, la, B E k a E)
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', L l k a r)) $
            popLeftBL lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', L l k a r)) $
            popLeftBB lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', L l k a r)) $
            popLeftBR lll llk lla llr lk la lr
      )
      ll
  popLeftBR ll lk la lr k a r =
    (\(k', a', l) -> (k', a', checkLeftB l k a r)) $
      popLeftR ll lk la lr
  popLeftBL ll lk la lr k a r =
    (\(k', a', l) -> (k', a', checkLeftB l k a r)) $
      popLeftL ll lk la lr
  popRightR l k a =
    map'
      (error "Map.delete: L20")
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightR l k a r, k', a')) $
            popRightL rl rk ra rr
      )
      (\rl rk ra rr _ _ -> popRightRB l k a rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightR l k a r, k', a')) $
            popRightR rl rk ra rr
      )
  popRightB l k a =
    map'
      (E, k, a)
      (\rl rk ra rr _ _ -> popRightBL l k a rl rk ra rr)
      (\rl rk ra rr _ _ -> popRightBB l k a rl rk ra rr)
      (\rl rk ra rr _ _ -> popRightBR l k a rl rk ra rr)
  popRightL l k a =
    map'
      (l, k, a)
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightL l k a r, k', a')) $
            popRightL rl rk ra rr
      )
      (\rl rk ra rr _ _ -> popRightLB l k a rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightL l k a r, k', a')) $
            popRightR rl rk ra rr
      )
  popRightRB l k a rl rk ra =
    map'
      (B E k a E, rk, ra)
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (R l k a r, k', a')) $
            popRightBL rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (R l k a r, k', a')) $
            popRightBB rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (R l k a r, k', a')) $
            popRightBR rl rk ra rrl rrk rra rrr
      )
  popRightBB l k a rl rk ra =
    map'
      (L l k a E, rk, ra)
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (B l k a r, k', a')) $
            popRightBL rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (B l k a r, k', a')) $
            popRightBB rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (B l k a r, k', a')) $
            popRightBR rl rk ra rrl rrk rra rrr
      )
  popRightLB l k a rl rk ra =
    map'
      (rebalanceL l k a E, rk, ra)
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (L l k a r, k', a')) $
            popRightBL rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (L l k a r, k', a')) $
            popRightBB rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (L l k a r, k', a')) $
            popRightBR rl rk ra rrl rrk rra rrr
      )
  popRightBR l k a rl rk ra rr =
    (\(r, k', a') -> (checkRightB l k a r, k', a')) $
      popRightR rl rk ra rr
  popRightBL l k a rl rk ra rr =
    (\(r, k', a') -> (checkRightB l k a r, k', a')) $
      popRightL rl rk ra rr

-- | /O(log n)/ Insert a key and its value, combining new and old if present
insertWithKey :: (Ord k) => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
insertWithKey f k0 a0 =
  map'
    (B E k0 a0 E)
    (\l k a r _ _ -> insertL l k a r)
    (\l k a r _ _ -> insertB l k a r)
    (\l k a r _ _ -> insertR l k a r)
 where
  insertR l k a r =
    case compare k0 k of
      LT -> insertRl l k a r
      EQ -> R l k (f k a0 a) r
      GT -> insertRr l k a r
  insertB l k a r =
    case compare k0 k of
      LT -> insertBl l k a r
      EQ -> B l k (f k a0 a) r
      GT -> insertBr l k a r
  insertL l k a r =
    case compare k0 k of
      LT -> insertLl l k a r
      EQ -> L l k (f k a0 a) r
      GT -> insertLr l k a r
  insertRl l k a r =
    map'
      (B (B E k0 a0 E) k a r)
      (\ll lk la lr _ _ -> R (insertL ll lk la lr) k a r)
      ( \ll lk la lr _ _ ->
          let l' = insertB ll lk la lr
           in map'
                (error "Map.insert: L0")
                (\_ _ _ _ _ _ -> B l' k a r)
                (\_ _ _ _ _ _ -> R l' k a r)
                (\_ _ _ _ _ _ -> B l' k a r)
                l'
      )
      (\ll lk la lr _ _ -> R (insertR ll lk la lr) k a r)
      l
  insertBl l k a r =
    map'
      (L (B E k0 a0 E) k a r)
      (\ll lk la lr _ _ -> B (insertL ll lk la lr) k a r)
      ( \ll lk la lr _ _ ->
          let l' = insertB ll lk la lr
           in map'
                (error "Map.insert: L1")
                (\_ _ _ _ _ _ -> L l' k a r)
                (\_ _ _ _ _ _ -> B l' k a r)
                (\_ _ _ _ _ _ -> L l' k a r)
                l'
      )
      (\ll lk la lr _ _ -> B (insertR ll lk la lr) k a r)
      l
  insertBr l k a =
    map'
      (R l k a (B E k0 a0 E))
      (\rl rk ra rr _ _ -> B l k a (insertL rl rk ra rr))
      ( \rl rk ra rr _ _ ->
          let r = insertB rl rk ra rr
           in map'
                (error "Map.insert: L2")
                (\_ _ _ _ _ _ -> R l k a r)
                (\_ _ _ _ _ _ -> B l k a r)
                (\_ _ _ _ _ _ -> R l k a r)
                r
      )
      (\rl rk ra rr _ _ -> B l k a (insertR rl rk ra rr))
  insertLr l k a =
    map'
      (B l k a (B E k0 a0 E))
      (\rl rk ra rr _ _ -> L l k a (insertL rl rk ra rr))
      ( \rl rk ra rr _ _ ->
          let r = insertB rl rk ra rr
           in map'
                (error "Map.insert: L3")
                (\_ _ _ _ _ _ -> B l k a r)
                (\_ _ _ _ _ _ -> L l k a r)
                (\_ _ _ _ _ _ -> B l k a r)
                r
      )
      (\rl rk ra rr _ _ -> L l k a (insertR rl rk ra rr))
  insertRr l k a =
    map'
      (error "Map.insert: L4")
      (\rl rk ra rr _ _ -> R l k a (insertL rl rk ra rr))
      ( \rl rk ra rr _ _ ->
          case compare k0 rk of
            LT -> insertRrl l k a rl rk ra rr
            EQ -> R l k a (B rl rk (f rk a0 ra) rr)
            GT -> insertRrr l k a rl rk ra rr
      )
      (\rl rk ra rr _ _ -> R l k a (insertR rl rk ra rr))
  insertLl l k a r =
    map'
      (error "Map.insert: L5")
      (\ll lk la lr _ _ -> L (insertL ll lk la lr) k a r)
      ( \ll lk la lr _ _ ->
          case compare k0 lk of
            LT -> insertLll ll lk la lr k a r
            EQ -> L (B ll lk (f lk a0 la) lr) k a r
            GT -> insertLlr ll lk la lr k a r
      )
      (\ll lk la lr _ _ -> L (insertR ll lk la lr) k a r)
      l
  insertRrr l k a rl rk ra =
    map'
      (B (B l k a rl) rk ra (B E k0 a0 E))
      (\rrl rrk rra rrr _ _ -> R l k a (B rl rk ra (insertL rrl rrk rra rrr)))
      ( \rrl rrk rra rrr _ _ ->
          let rr = insertB rrl rrk rra rrr
           in map'
                (error "Map.insert: L6")
                (\_ _ _ _ _ _ -> B (B l k a rl) rk ra rr)
                (\_ _ _ _ _ _ -> R l k a (B rl rk ra rr))
                (\_ _ _ _ _ _ -> B (B l k a rl) rk ra rr)
                rr
      )
      (\rrl rrk rra rrr _ _ -> R l k a (B rl rk ra (insertR rrl rrk rra rrr)))
  insertLll ll lk la lr k a r =
    map'
      (B (B E k0 a0 E) lk la (B lr k a r))
      (\lll llk lla llr _ _ -> L (B (insertL lll llk lla llr) lk la lr) k a r)
      ( \lll llk lla llr _ _ ->
          let ll' = insertB lll llk lla llr
           in map'
                (error "Map.insert: L7")
                (\_ _ _ _ _ _ -> B ll' lk la (B lr k a r))
                (\_ _ _ _ _ _ -> L (B ll' lk la lr) k a r)
                (\_ _ _ _ _ _ -> B ll' lk la (B lr k a r))
                ll'
      )
      (\lll llk lla llr _ _ -> L (B (insertR lll llk lla llr) lk la lr) k a r)
      ll
  insertRrl l k a rl rk ra rr =
    map'
      (B (B l k a E) k0 a0 (B E rk ra rr))
      (\rll rlk rla rlr _ _ -> R l k a (B (insertL rll rlk rla rlr) rk ra rr))
      ( \rll rlk rla rlr _ _ ->
          let rl' = insertB rll rlk rla rlr
           in map'
                (error "Map.insert: L8")
                ( \rll' rlk' rla' rlr' _ _ ->
                    B
                      (B l k a rll')
                      rlk'
                      rla'
                      (R rlr' rk ra rr)
                )
                (\_ _ _ _ _ _ -> R l k a (B rl' rk ra rr))
                ( \rll' rlk' rla' rlr' _ _ ->
                    B
                      (L l k a rll')
                      rlk'
                      rla'
                      (B rlr' rk ra rr)
                )
                rl'
      )
      (\rll rlk rla rlr _ _ -> R l k a (B (insertR rll rlk rla rlr) rk ra rr))
      rl
  insertLlr ll lk la lr k a r =
    map'
      (B (B ll lk la E) k0 a0 (B E k a r))
      (\lrl lrk lra lrr _ _ -> L (B ll lk la (insertL lrl lrk lra lrr)) k a r)
      ( \lrl lrk lra lrr _ _ ->
          let lr' = insertB lrl lrk lra lrr
           in map'
                (error "Map.insert: L9")
                ( \lrl' lrk' lra' lrr' _ _ ->
                    B
                      (B ll lk la lrl')
                      lrk'
                      lra'
                      (R lrr' k a r)
                )
                (\_ _ _ _ _ _ -> L (B ll lk la lr') k a r)
                ( \lrl' lrk' lra' lrr' _ _ ->
                    B
                      (L ll lk la lrl')
                      lrk'
                      lra'
                      (B lrr' k a r)
                )
                lr'
      )
      (\lrl lrk lra lrr _ _ -> L (B ll lk la (insertR lrl lrk lra lrr)) k a r)
      lr

{-
 - Examples
 -}

{- $examples
'fromList': /tail-biased/ means that if a list of @(key, value)@ pairs contains
pairs with identical keys, the rightmost one is kept.

>>> fromList [('a',1),('b',2),('c',3),('b',4),('a',5)]
[('a',5),('b',4),('c',3)]

'fromListWith', 'fromListWithKey': If a list of @(key, value)@ pairs contains
pairs with identical keys, the leftmost one is inserted as is and the subsequent
ones adjust the value with the combining function left-associatively. The
combining function takes the new value as the left operand, and the existing
value as the right operand.

>>> fromListWith (<>) [(1,"a"),(2,"b"),(1,"c"),(1,"d")]
[(1,"dca"),(2,"b")]
>>> let f k new old = old <> ", " <> show k <> new
>>> fromListWithKey f [(1,"a"),(2,"b"),(1,"c"),(1,"d")]
[(1,"a, 1c, 1d"),(2,"b")]

'intersection', 'union', 'unions': /left-biased/ means that if the operands
contain bins with identical keys, the bins from the /left/ operand is kept.

>>> fromList [('a',1),('b',2)] `intersection` fromList [('c',3),('b',4),('a',5)]
[('a',1),('b',2)]
>>> fromList [('a',1),('b',2)] `union` fromList [('c',3),('b',4),('a',5)]
[('a',1),('b',2),('c',3)]

'insertWith', 'insertWithKey': If the key does not exist in the map, it is
inserted with the given value as is. Otherwise, the existing value is adjusted
with the combining function, which takes the given value as the left operand and
the existing value as the right operand.

>>> insertWith (<>) 1 "foo" $ fromList [(2,"bar"),(3,"baz")]
[(1,"foo"),(2,"bar"),(3,"baz")]
>>> insertWith (<>) 2 "foo" $ fromList [(2,"bar"),(3,"baz")]
[(2,"foobar"),(3,"baz")]
>>> let f k new old = k + new - old
>>> insertWithKey f 1 2 $ fromList [(2,3),(3,5)]
[(1,2),(2,3),(3,5)]
>>> insertWithKey f 2 7 $ fromList [(2,3),(3,5)]
[(2,6),(3,5)]

'update': If the key does not exist, the map is unchanged. If the key exists and
the result of the operation is @Just x@, the value of the corresponding bin is
updated to @x@. If the key exists and the result of the operation is @Nothing@,
the corresponding bin is removed.

>>> f a = if a == 2 then Just 9 else Nothing
>>> update f 'c' $ fromList [('a',1),('b',2)]
[('a',1),('b',2)]
>>> update f 'b' $ fromList [('a',1),('b',2)]
[('a',1),('b',9)]
>>> update f 'a' $ fromList [('a',1),('b',2)]
[('b',2)]
-}