primitive-containers 0.3.0 → 0.3.1

raw patch · 25 files changed

+1769/−99 lines, 25 filesdep +contiguous-checkeddep +primitive-checkeddep ~QuickCheckdep ~basedep ~contiguousPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: contiguous-checked, primitive-checked

Dependency ranges changed: QuickCheck, base, contiguous, quickcheck-classes

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−2
• benchmark-gauge/Main.hs +11/−0
• primitive-containers.cabal +27/−7
• src/Data/Concatenation.hs +30/−3
• src/Data/Dependent/Map/Internal.hs +31/−9
• src/Data/Dependent/Map/Unboxed/Lifted.hs +2/−2
• src/Data/Diet/Map/Strict/Internal.hs +1/−0
• src/Data/Diet/Map/Strict/Unboxed/Lifted.hs +6/−6
• src/Data/Map/Internal.hs +124/−10
• src/Data/Map/Interval.hs +64/−0
• src/Data/Map/Interval/DBTS/Internal.hs +383/−0
• src/Data/Map/Interval/DBTSLL.hs +148/−0
• src/Data/Map/Lifted/Lifted.hs +19/−2
• src/Data/Map/Lifted/Unlifted.hs +235/−0
• src/Data/Map/Unboxed/Lifted.hs +44/−6
• src/Data/Map/Unboxed/Unboxed.hs +65/−4
• src/Data/Map/Unboxed/Unlifted.hs +72/−6
• src/Data/Map/Unlifted/Lifted.hs +9/−9
• src/Data/Set/Internal.hs +118/−5
• src/Data/Set/Lifted.hs +5/−0
• src/Data/Set/NonEmpty/Unlifted.hs +158/−0
• src/Data/Set/Unboxed.hs +41/−1
• src/Data/Set/Unlifted.hs +10/−1
• src/Data/Set/Unlifted/Internal.hs +0/−1
• test/Main.hs +152/−25

@@ -1,3 +1,15 @@-# Changelog for primitive-containers+# Changelog+All notable changes to this project will be documented in this file. -## Unreleased changes+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [0.4.0] - 2018-??-??+### Added+- Non-empty unlifted sets. Currently, the API is similar to the API for Sets.+  However, functions that would be partial are removed (intersection,+  difference, fromList), and functions that would be constant are removed (null).+  There is no `Monoid` instance and no `IsList` instance.+- fromSet function for non-empty unlifted sets+- toSet function for non-empty unlifted sets+

@@ -11,6 +11,7 @@ import qualified Data.Set.Unboxed as DSU import qualified Data.Set.Lifted as DSL import qualified Data.Map.Unboxed.Unboxed as DMUU+import qualified Data.Map.Unboxed.Lifted as DMUL import qualified Data.Map.Lifted.Lifted as DMLL import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM@@ -21,6 +22,7 @@   [ bgroup "Map"     [ bgroup "lookup"        [ bench "primitive-unboxed-unboxed" $ whnf lookupAllUnboxed bigUnboxedMap+      , bench "primitive-unboxed-lifted" $ whnf lookupAllUnboxedLifted bigUnboxedLiftedMap       , bench "containers-map" $ whnf lookupAllContainers bigContainersMap       , bench "containers-intmap" $ whnf lookupAllIntContainers bigContainersIntMap       ]@@ -84,6 +86,9 @@ bigUnboxedMap :: DMUU.Map Int Int bigUnboxedMap = E.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843)))) +bigUnboxedLiftedMap :: DMUL.Map Int Int+bigUnboxedLiftedMap = E.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))+ bigLiftedMap :: DMLL.Map Int Int bigLiftedMap = E.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843)))) @@ -97,6 +102,12 @@ lookupAllUnboxed m = go 0 0 where   go !acc !n = if n < bigNumber     then go (acc + fromMaybe 0 (DMUU.lookup n m)) (n + 1)+    else acc++lookupAllUnboxedLifted :: DMUL.Map Int Int -> Int+lookupAllUnboxedLifted m = go 0 0 where+  go !acc !n = if n < bigNumber+    then go (acc + fromMaybe 0 (DMUL.lookup n m)) (n + 1)     else acc  lookupAllSetUnboxed :: DSU.Set Int -> Int

@@ -1,6 +1,6 @@ cabal-version: 2.0 name: primitive-containers-version: 0.3.0+version: 0.3.1 synopsis: containers backed by arrays description:   Containers backed by flat arrays. Updates require rebuilding the@@ -10,26 +10,33 @@ author: Andrew Martin maintainer: andrew.thaddeus@gmail.com copyright: 2018 Andrew Martin+category: Data Structures license: BSD3 license-file: LICENSE build-type: Simple  extra-source-files:-    ChangeLog.md-    README.md+  ChangeLog.md+  README.md  source-repository head   type: git   location: https://github.com/andrewthad/primitive-containers +flag checked+  description:+    Check all array indexing. This makes most functions slower, but+    it replaces segfaults with descriptive errors. This should+    only be used for debugging.+  default: False+  manual: True+ library   hs-source-dirs:       src   build-depends:       base >=4.9 && <5-    , primitive >= 0.6.4     , primitive-sort >= 0.1 && < 0.2-    , contiguous >= 0.3 && < 0.4     , hashable >= 1.2.5     , deepseq >= 1.4       -- move these five out when we kick out dependent maps @@ -38,6 +45,14 @@     , unordered-containers >= 0.2.8.0     , vector >= 0.11 && < 0.13     , text >= 1.2 && < 1.3+  if flag(checked)+    build-depends: +        contiguous-checked >= 0.3.2 && < 0.4+      , primitive-checked >= 0.6.4.1+  else+    build-depends: +        contiguous >= 0.3.2 && < 0.4+      , primitive >= 0.6.4   exposed-modules:     Data.Continuous.Set.Lifted     Data.Diet.Map.Strict.Lifted.Lifted@@ -47,6 +62,7 @@     Data.Diet.Set.Unboxed     Data.Diet.Unbounded.Set.Lifted     Data.Map.Lifted.Lifted+    Data.Map.Lifted.Unlifted     Data.Map.Unboxed.Lifted     Data.Map.Unboxed.Unboxed     Data.Map.Unboxed.Unlifted@@ -55,6 +71,8 @@     Data.Set.Lifted     Data.Set.Unboxed     Data.Set.Unlifted+    Data.Set.NonEmpty.Unlifted+    Data.Map.Interval     Data.Map.Subset.Strict.Lifted     Data.Map.Subset.Strict.Unlifted     Data.Map.Subset.Lazy.Lifted@@ -64,6 +82,7 @@     Data.Dependent.Map.Lifted.Lifted     Data.Dependent.Map.Unlifted.Lifted     Data.Dependent.Map.Unboxed.Lifted+    Data.Map.Interval.DBTSLL   other-modules:     Data.Concatenation     Data.Diet.Map.Strict.Internal@@ -77,6 +96,7 @@     Data.Set.Lifted.Internal     Data.Set.Unboxed.Internal     Data.Set.Unlifted.Internal+    Data.Map.Interval.DBTS.Internal   ghc-options: -O2 -Wall   default-language: Haskell2010 @@ -87,13 +107,13 @@   build-depends:       base     , HUnit-    , QuickCheck+    , QuickCheck < 2.12     , aeson     , containers >= 0.5.10     , primitive     , primitive-containers     , quantification >= 0.4-    , quickcheck-classes >= 0.4.12+    , quickcheck-classes >= 0.5     , tasty     , tasty-hunit     , tasty-quickcheck

@@ -3,10 +3,18 @@  module Data.Concatenation   ( concatSized+  , concatSized1   ) where +import Data.List.NonEmpty (NonEmpty((:|)))+ import qualified Data.List as L+import qualified Data.List.NonEmpty as NE +-- | Concatenate all the values in the list in the order they+-- are given. This function attempts to perform smaller concatenations+-- together. This is good for data structures that do not take+-- advantage of sharing. concatSized :: forall m.      (m -> Int) -- size function    -> m@@ -16,12 +24,31 @@ concatSized size empty combine = go [] where   go :: [m] -> [m] -> m   go !stack [] = L.foldl' combine empty (L.reverse stack)-  go !stack (x : xs) = if size x > 0-    then go (pushStack x stack) xs-    else go stack xs+  go !stack (x : xs) = go (pushStack x stack) xs   pushStack :: m -> [m] -> [m]   pushStack x [] = [x]   pushStack x (s : ss) = if size x >= size s     then pushStack (combine s x) ss     else x : s : ss++-- | This function is likely to be used for things like intersection+-- where the zero-sized element is not an identity but a zero.+concatSized1 :: forall m.+     (m -> Int) -- size function +  -> (m -> m -> m)+  -> NonEmpty m+  -> m+concatSized1 size combine (p :| ps) = go (p :| []) ps where+  go :: NonEmpty m -> [m] -> m+  go !stack [] = safeFoldl1' combine (NE.reverse stack)+  go !stack (x : xs) = go (pushStack x stack) xs+  pushStack :: m -> NonEmpty m -> NonEmpty m+  pushStack x (s :| ss) = if size x >= size s+    then case ss of+      [] -> combine s x :| []+      r : rs -> pushStack (combine s x) (r :| rs)+    else x :| (s : ss)++safeFoldl1' :: (a -> a -> a) -> NonEmpty a -> a+safeFoldl1' f (a :| as) = L.foldl' f a as 

@@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}  module Data.Dependent.Map.Internal   ( Map(..)@@ -51,6 +52,7 @@ import Data.Kind (Type) import Data.Aeson (ToJSON,FromJSON) import Data.Text (Text)+import qualified Data.List as L import qualified Data.Vector as V import qualified Data.Exists as EX import qualified Data.Aeson as AE@@ -154,23 +156,43 @@       Nothing -> Nothing       Just v -> Just (unwrapValue (Proxy :: Proxy v) (Proxy :: Proxy a) v) -appendWith :: forall karr varr k v.-     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, ToSing k)-  => (forall a. Sing a -> v a -> v a -> v a)+appendWith :: forall u karr varr (k :: u -> Type) (v :: u -> Type).+     (Contiguous karr, ApplyUniversally k (Element karr), Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, ToSing k)+  => (forall (a :: u). Sing a -> v a -> v a -> v a)   -> Map karr varr k v   -> Map karr varr k v   -> Map karr varr k v-appendWith f (Map m1) (Map m2) = id-  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)-  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)-  $ Map (M.appendKeyWith (\(C.Apply k) v1 v2 -> f (EX.toSing k) v1 v2) m1 m2)+appendWith f xs ys = fromList (nubUnionWith f (toList xs) (toList ys))+-- For some reason, this more natural implementation causes segfaults+-- appendWith f (Map m1) (Map m2) = id+--   $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+--   $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+--   $ Map (M.appendWithKey (\(C.Apply k) v1 v2 -> f (EX.toSing k) v1 v2) m1 m2) +nubUnionWith :: forall u (k :: u -> Type) (v :: u -> Type). (EqForallPoly k, ToSing k)+  => (forall (a :: u). Sing a -> v a -> v a -> v a)+  -> [DependentPair k v]+  -> [DependentPair k v]+  -> [DependentPair k v]+nubUnionWith f = go [] where+  go acc [] ys = acc ++ ys+  go acc (x@(DependentPair kx vx) : xs) ys = case findPair kx ys of+    Nothing -> go (x : acc) xs ys+    Just (ys',vy) -> go (DependentPair kx (f (EX.toSing kx) vx vy) : acc) xs ys'++findPair :: EqForallPoly k => k a -> [DependentPair k v] -> Maybe ([DependentPair k v], v a)+findPair k = go [] where+  go _ [] = Nothing+  go finger (x@(DependentPair kx vx) : xs) = case EX.eqForallPoly k kx of+    EX.WitnessedEqualityUnequal -> go (x : finger) xs+    EX.WitnessedEqualityEqual -> Just (L.reverse finger ++ xs, vx)+ append :: forall karr varr k v.-     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, SemigroupForeach v, ToSing k)+     (Contiguous karr, ApplyUniversally k (Element karr), Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, SemigroupForeach v, ToSing k)   => Map karr varr k v   -> Map karr varr k v   -> Map karr varr k v-append = appendWith EX.appendForeach+append = appendWith (EX.appendForeach :: (forall a. Sing a -> v a -> v a -> v a))  appendRightBiased :: forall karr varr k v.      (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)

@@ -180,10 +180,10 @@ instance (Universally k Prim, ApplyUniversally k Prim, ToSing k, FromJSONKeyExists k, FromJSONForeach v, OrdForallPoly k) => FromJSON (Map k v) where   parseJSON v = fmap Map (I.parseJSON v) -instance (Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Semigroup (Map k v) where+instance (ApplyUniversally k Prim, Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Semigroup (Map k v) where   Map x <> Map y = Map (I.append x y) -instance (Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Monoid (Map k v) where+instance (ApplyUniversally k Prim, Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Monoid (Map k v) where   mempty = Map I.empty   mappend = (SG.<>) 

@@ -50,6 +50,7 @@ empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v empty = Map I.empty I.empty +-- Note: this is only correct when the function is a bijection. map :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) => (v -> w) -> Map karr varr k v -> Map karr varr k w map f (Map k v) = Map k (I.map f v) 

@@ -9,7 +9,7 @@   , empty   , singleton   , lookup-  , mapEqualityMorphism+  , mapBijection   , fromSet     -- * List Conversion   , fromList@@ -86,18 +86,18 @@   -> Map k v fromListAppendN n = Map . I.fromListAppendN n --- | Map an equality morphism over the values in a diet map. An equality--- morphism @f@ must satisfy the law:+-- | Map an equality morphism over the values in a diet map. An bijection+-- @f@ must satisfy the law: -- -- > ∀ x y. x == y ↔ f x == f y -- -- Since this does not actually use the 'Eq' constraint on the new value -- type, it is lazy in the values.-mapEqualityMorphism :: (Prim k, Ord k)-  => (v -> w) -- ^ equality morphism+mapBijection :: (Prim k, Ord k)+  => (v -> w) -- ^ bijection   -> Map k v   -> Map k w-mapEqualityMorphism f (Map m) = Map (I.map f m)+mapBijection f (Map m) = Map (I.map f m)  -- | Convert a diet set to a diet map, constructing each value -- from the low and high key in its corresponding range.

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}@@ -15,6 +16,7 @@   , map   , mapWithKey   , mapMaybe+  , mapMaybeP   , mapMaybeWithKey     -- * Folds   , foldrWithKey@@ -28,13 +30,17 @@   , foldlMapWithKeyM'   , foldrMapWithKeyM'     -- * Traversals+  , traverse   , traverseWithKey_     -- * Functions   , append   , appendWith-  , appendKeyWith+  , appendWithKey   , appendRightBiased   , intersectionWith+  , intersectionsWith+  , adjustMany+  , adjustManyInline   , lookup   , showsPrec   , equals@@ -42,6 +48,7 @@   , toList   , concat   , size+  , sizeKeys   , keys   , elems   , restrict@@ -52,25 +59,29 @@   , fromListAppend   , fromListAppendN   , fromSet+  , fromSetP     -- * Array Conversion   , unsafeFreezeZip   , unsafeZipPresorted   ) where -import Prelude hiding (compare,showsPrec,lookup,map,concat,null)+import Prelude hiding (compare,showsPrec,lookup,map,concat,null,traverse)  import Control.Applicative (liftA2) import Control.DeepSeq (NFData)+import Control.Monad.Primitive (PrimMonad,PrimState) import Control.Monad.ST (ST,runST)-import Data.Semigroup (Semigroup)+import Data.List.NonEmpty (NonEmpty) import Data.Primitive.Contiguous (Contiguous,Mutable,Element) import Data.Primitive.Sort (sortUniqueTaggedMutable)+import Data.Semigroup (Semigroup) import Data.Set.Internal (Set(..))++import qualified Data.Concatenation as C import qualified Data.List as L+import qualified Data.Primitive.Contiguous as I import qualified Data.Semigroup as SG import qualified Prelude as P-import qualified Data.Primitive.Contiguous as I-import qualified Data.Concatenation as C  -- TODO: Do some sneakiness with UnliftedRep data Map karr varr k v = Map !(karr k) !(varr v)@@ -206,7 +217,7 @@ map :: (Contiguous varr, Element varr v, Element varr w) => (v -> w) -> Map karr varr k v -> Map karr varr k w map f (Map k v) = Map k (I.map f v) --- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- | /O(n)/ Map over the elements with access to their corresponding keys. mapWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)   => (k -> v -> w)   -> Map karr varr k v@@ -234,7 +245,7 @@   => (v -> Maybe w)   -> Map karr varr k v   -> Map karr varr k w-{-# INLINEABLE mapMaybe #-}+{-# INLINE mapMaybe #-} mapMaybe f (Map ks vs) = runST $ do   let !sz = I.size vs   !(karr :: Mutable karr s k) <- I.new sz@@ -255,6 +266,31 @@   return (Map ksFinal vsFinal)  -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+mapMaybeP :: forall karr varr m k v w. (PrimMonad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)+  => (v -> m (Maybe w))+  -> Map karr varr k v+  -> m (Map karr varr k w)+{-# INLINE mapMaybeP #-}+mapMaybeP f (Map ks vs) = do+  let !sz = I.size vs+  !(karr :: Mutable karr (PrimState m) k) <- I.new sz+  !(varr :: Mutable varr (PrimState m) w) <- I.new sz+  let go !ixSrc !ixDst = if ixSrc < sz+        then do+          a <- I.indexM vs ixSrc+          f a >>= \case+            Nothing -> go (ixSrc + 1) ixDst+            Just b -> do+              I.write varr ixDst b+              I.write karr ixDst =<< I.indexM ks ixSrc+              go (ixSrc + 1) (ixDst + 1)+        else return ixDst+  dstLen <- go 0 0+  ksFinal <- I.resize karr dstLen >>= I.unsafeFreeze+  vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze+  return (Map ksFinal vsFinal)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'. mapMaybeWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)   => (k -> v -> Maybe w)   -> Map karr varr k v@@ -316,6 +352,58 @@              in mappend (f k v) (go (i + 1))    in go 0 +adjustMany :: forall karr varr m k v a. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, PrimMonad m, Ord k)+  => ((k -> (v -> m v) -> m ()) -> m a) -- Callback that takes a modify function+  -> Map karr varr k v+  -> m (Map karr varr k v, a)+{-# INLINABLE adjustMany #-}+adjustMany f (Map theKeys theVals) = do+  mvals <- I.thaw theVals 0 (I.size theVals)+  let g :: k -> (v -> m v) -> m ()+      g !k updateVal = +        let go !start !end = if end < start+              then pure ()+              else+                let !mid = div (end + start) 2+                    !(# v #) = I.index# theKeys mid+                 in case P.compare k v of+                      LT -> go start (mid - 1)+                      EQ -> do+                        r <- I.read mvals mid+                        r' <- updateVal r+                        I.write mvals mid r'+                      GT -> go (mid + 1) end+         in go 0 (I.size theVals - 1)+  r <- f g+  rvals <- I.unsafeFreeze mvals+  pure (Map theKeys rvals, r)++adjustManyInline :: forall karr varr m k v a. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, PrimMonad m, Ord k)+  => ((k -> (v -> m v) -> m ()) -> m a) -- Callback that takes a modify function+  -> Map karr varr k v+  -> m (Map karr varr k v, a)+{-# INLINE adjustManyInline #-}+adjustManyInline f (Map theKeys theVals) = do+  mvals <- I.thaw theVals 0 (I.size theVals)+  let g :: k -> (v -> m v) -> m ()+      g !k updateVal = +        let go !start !end = if end < start+              then pure ()+              else+                let !mid = div (end + start) 2+                    !(# v #) = I.index# theKeys mid+                 in case P.compare k v of+                      LT -> go start (mid - 1)+                      EQ -> do+                        r <- I.read mvals mid+                        r' <- updateVal r+                        I.write mvals mid r'+                      GT -> go (mid + 1) end+         in go 0 (I.size theVals - 1)+  r <- f g+  rvals <- I.unsafeFreeze mvals+  pure (Map theKeys rvals, r)+ concat :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => [Map karr varr k v] -> Map karr varr k v concat = concatWith (SG.<>) @@ -325,12 +413,18 @@   -> Map karr varr k v concatWith combine = C.concatSized size empty (appendWith combine) +intersectionsWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)+  => (v -> v -> v)+  -> NonEmpty (Map karr varr k v)+  -> Map karr varr k v+intersectionsWith f = C.concatSized1 size (intersectionWith f)+ appendRightBiased :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v appendRightBiased = appendWith const -appendKeyWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)+appendWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)   => (k -> v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v-appendKeyWith combine (Map ksA vsA) (Map ksB vsB) =+appendWithKey combine (Map ksA vsA) (Map ksB vsB) =   case unionArrWith combine ksA vsA ksB vsB of     (k,v) -> Map k v   @@ -437,6 +531,7 @@   => k   -> Map karr varr k v   -> Maybe v+{-# INLINEABLE lookup #-} lookup a (Map arr vals) = go 0 (I.size vals - 1) where   go :: Int -> Int -> Maybe v   go !start !end = if end < start@@ -449,11 +544,14 @@             EQ -> case I.index# vals mid of               (# r #) -> Just r             GT -> go (mid + 1) end-{-# INLINEABLE lookup #-}  size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int size (Map _ arr) = I.size arr +-- This may have less constraints than size+sizeKeys :: (Contiguous karr, Element karr k) => Map karr varr k v -> Int+sizeKeys (Map arr _) = I.size arr+ -- | Sort and deduplicate the key array, preserving the last value associated -- with each key. The argument arrays may not be reused after being passed -- to this function. This function is only unsafe because of the requirement@@ -534,6 +632,14 @@     else return accl {-# INLINEABLE foldlMapWithKeyM' #-} +traverse :: (Applicative m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)+  => (v -> m w)+  -> Map karr varr k v+  -> m (Map karr varr k w)+{-# INLINEABLE traverse #-}+traverse f (Map theKeys theVals) =+  fmap (Map theKeys) (I.traverse f theVals)+ traverseWithKey_ :: forall karr varr k v m b. (Applicative m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)   => (k -> v -> m b)   -> Map karr varr k v@@ -678,6 +784,14 @@   -> Set karr k   -> Map karr varr k v fromSet f (Set arr) = Map arr (I.map f arr)+{-# INLINE fromSet #-}++fromSetP :: (PrimMonad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (k -> m v)+  -> Set karr k+  -> m (Map karr varr k v)+fromSetP f (Set arr) = fmap (Map arr) (I.traverseP f arr)+{-# INLINE fromSetP #-}  keys :: Map karr varr k v -> Set karr k keys (Map k _) = Set k

@@ -0,0 +1,64 @@+{-| ++This module only exists for documentation. It should never be imported.++The interval maps provided by the submodules of `Data.Map.Interval`+coallesce overlapping intervals. Their behavior differs from that+of the type from the `IntervalMap` package. The interval map from+that package preserves all the original interval that were used+as keys for the map. The interval map from this package creates a+new interval from the overlap, combining the values.++There are several points in the design space to explore with this+kind of interval map. A motivation for some of these variants is+having `Eq` instances that satisfy a bidirectional variant of the+substition law. That is:++> ∀ x y. (x == y ↔ ∀ f. f x == f y)++Here are the different design choices that we face:++* Discrete (D) vs Continuous (C): The basically comes down to whether or+  not there is an `Enum` instance for the type. Although it cannot be+  enforced by the type system, continuous-keyed maps should not use discrete+  types as keys. The bidirectional substituion law is not upheld in this+  case. The discrete-keyed interval map uses `succ` and `pred`+  to coalesce adjacent intervals. The continuous-keyed interval map,+  assuming that unequal values have infinitely many values between+  them, only considers merging adjacent intervals when an open interval+  butts up against a closed interval with a matching key.+* Bounded (B) vs Unbounded (U): Is there a Bounded instance for the type?+  Bounded types can treat `maxBound` as infinity. Unbounded types like+  `Integer` and `Text` have no value for infinity. If the key type has+  a `Bounded` instance, it is incorrect to use it in an unbounded interval+  map since the `Eq` instance will not satisfy the bidirectional substitution law.+* Partial (P) vs Total (T): Is there a value corresponding to every key?+  The decides whether or not the return value of `lookup` is wrapped in a+  `Maybe`. Total maps with unconstrained values also have an `Applicative`+  instance. The internal representation of total maps is also more+  efficient than that of partial maps since we only need to store the+  upper bound of each interval.+* Coalesce (S) vs Detach (H): The names here a little here are a little+  misleading. The strict variant uses on an `Eq` instance for values+  to coallesce adjacent ranges. For example, with discrete integers,+  the interval-value pairs ([4,6],12) and ([7,9],12) can be coallesced+  because 6 is adjacent to 7 and both pairs share value 12. Coalescing+  in this way is crucial to satisfying the bidirectional substitution+  law. It also induces value-strictness. Some users may prefer+  laziness in the values. This is also offered, but none of the+  value-lazy interval maps have `Eq` instances since it is not possible+  to satisfy the bidirectional substitution law without forcing the+  values.++The modules are named using acronyms that refer to various combinations+of these flavors. For exmaple, `Data.Map.Interval.DUTS` provides the+discrete unbounded total strict interval map. Some combinations are not+provided because the author is unaware of useful types that meet the+restrictions (for example, pairing continuous and bounded seems+dubious).++For users who want to use 'Double' as the key type, it is recommended+that CUxx be used since the `Enum` instance for `Double` is dubious.++-}+module Data.Map.Interval () where

@@ -0,0 +1,383 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Interval.DBTS.Internal+  ( Map+  , pure+  , singleton+  , empty+  , lookup+  , union+  , unionWith+  , equals+  , map+  , mapBijection+  , traverseP+  , traverse+  , traverse_+  , fromList+  , foldrWithKey+  , foldlWithKeyM'+  , foldl'+  , foldMap+  , toList+  , showsPrec+  , concat+  , elems+  ) where++import Prelude hiding (pure,lookup,compare,map,showsPrec,concat,traverse,foldMap)++import Control.Monad.ST (ST,runST)+import Control.Monad.Primitive (PrimMonad)+import Data.Primitive (PrimArray)+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)+import qualified Data.Concatenation as C+import qualified Data.Primitive.Contiguous as I+import qualified Prelude as P++-- | The key array is the same length as the value array. Every key+--   is the upper bound of a range. The keys array always has a length+--   of at least one. The last element is always maxBound. The lowest bound+--   is assumed to be minBound. For example, the interval map of @Int16@:+--+--   > [-inf,5],[6,17],[18,20],[21,+inf]+--+--   Would be represented by the keys:+--   +--   > 5,17,20,65536+data Map karr varr k v = Map !(karr k) !(varr v)++equals :: (Contiguous karr, Element karr k, Eq k, Contiguous varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool+equals (Map k1 v1) (Map k2 v2) = I.equals k1 k2 && I.equals v1 v2++size :: (Contiguous varr, Element varr v)+  => Map karr varr k v+  -> Int+size (Map _ v) = I.size v++-- compare :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Ord v) => Map karr varr k v -> Map karr varr k v -> Bool+-- compare (Map k1 v1) (Map k2 v2) = mappend (I.compare k1 k2) (I.compare v1 v2)++-- Note: this is only correct when the function is a bijection.+mapBijection :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)+  => (v -> w) -> Map karr varr k v -> Map karr varr k w+mapBijection f (Map k v) = Map k (I.map f v)++-- The function does not need to be a bijection. It may cause adjacent+-- keys to collapse if their values become the same.+map :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w, Eq w)+  => (v -> w)+  -> Map karr varr k v+  -> Map karr varr k w+map f (Map keys vals) = runST action where+  !sz = I.size vals+  action :: forall s. ST s (Map karr varr k w)+  action = do+    m <- I.new sz+    let go :: Int -> Int -> w -> [Int] -> Int -> ST s (Int,[Int],Int)+        go !ixSrc !ixDst !prevVal !dropped !droppedCount = if ixSrc < sz+          then do+            oldVal <- I.indexM vals ixSrc+            let val = f oldVal+            if val == prevVal+              then go (ixSrc + 1) ixDst val ((ixSrc - 1) : dropped) (droppedCount + 1)+              else do+                I.write m ixDst val+                go (ixSrc + 1) (ixDst + 1) val dropped droppedCount+          else return (ixDst,dropped,droppedCount)+    v0 <- I.indexM vals 0+    let !w0 = f v0+    I.write m 0 w0+    (len,dropped,droppedCount) <- go 1 1 w0 [] 0+    vals' <- I.resize m len >>= I.unsafeFreeze+    case droppedCount of+      0 -> return (Map keys vals')+      _ -> do+        n <- I.new len+        let !(d :: PrimArray Int) = I.unsafeFromListReverseN (droppedCount + 1) (maxBound : dropped)+        let run :: Int -> Int -> Int -> ST s ()+            run !ixKey !ixDst !ixDrop = if ixKey < sz+              then if I.index d ixDrop == ixKey+                then run (ixKey + 1) ixDst (ixDrop + 1)+                else do+                  I.write n ixDst =<< I.indexM keys ixKey+                  run (ixKey + 1) (ixDst + 1) ixDrop+              else return ()+        run 0 0 0+        keys' <- I.unsafeFreeze n+        return (Map keys' vals')+        ++-- Note: this is only correct when the function is a bijection.+traverseP :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w, PrimMonad m)+  => (v -> m w) -> Map karr varr k v -> m (Map karr varr k w)+traverseP f (Map k v) = fmap (Map k) (I.traverseP f v)++-- Note: this is only correct when the function is a bijection.+traverse :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w, Applicative m)+  => (v -> m w) -> Map karr varr k v -> m (Map karr varr k w)+traverse f (Map k v) = fmap (Map k) (I.traverse f v)++traverse_ :: (Contiguous varr, Element varr v, Element varr w, Applicative m)+  => (v -> m w) -> Map karr varr k v -> m ()+traverse_ f (Map _ v) = I.traverse_ f v++pure :: (Contiguous karr, Contiguous varr, Element karr k, Element varr v, Bounded k) => v -> Map karr varr k v+pure v = Map+  (runST $ do+     !(arr :: Mutable karr s k) <- I.replicateM 1 maxBound+     I.unsafeFreeze arr+  )+  (runST $ do+     !(arr :: Mutable varr s v) <- I.replicateM 1 v+     I.unsafeFreeze arr+  )++-- This is not actually empty, but it is the monoidal identity.+empty :: (Contiguous karr, Contiguous varr, Element karr k, Element varr v, Bounded k, Monoid v) => Map karr varr k v+empty = pure mempty++singleton :: forall karr varr k v. (Contiguous karr, Contiguous varr, Element karr k, Element varr v, Bounded k, Enum k, Ord k, Eq v)+  => v -- value outside of the interval+  -> k -- lower bound+  -> k -- upper bound+  -> v -- value inside the interval+  -> Map karr varr k v+singleton def lo hi v = if lo <= hi && def /= v+  then if lo > minBound+    then if hi < maxBound+      then Map+        (runST $ do+           !(arr :: Mutable karr s k) <- I.new 3+           I.write arr 0 (pred lo)+           I.write arr 1 hi+           I.write arr 2 maxBound+           I.unsafeFreeze arr+        )+        (runST $ do+           !(arr :: Mutable varr s v) <- I.new 3+           I.write arr 0 def+           I.write arr 1 v+           I.write arr 2 def+           I.unsafeFreeze arr+        )+      else Map+        (runST $ do+           !(arr :: Mutable karr s k) <- I.new 2+           I.write arr 0 (pred lo)+           I.write arr 1 maxBound+           I.unsafeFreeze arr+        )+        (runST $ do+           !(arr :: Mutable varr s v) <- I.new 2+           I.write arr 0 def+           I.write arr 1 v+           I.unsafeFreeze arr+        )+    else if hi < maxBound+      then Map+        (runST $ do+           !(arr :: Mutable karr s k) <- I.new 2+           I.write arr 0 hi+           I.write arr 1 maxBound+           I.unsafeFreeze arr+        )+        (runST $ do+           !(arr :: Mutable varr s v) <- I.new 2+           I.write arr 0 v+           I.write arr 1 def+           I.unsafeFreeze arr+        )+      else pure v+  else pure def++lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> v+lookup a (Map keys vals) = go 0 (I.size vals - 1) where+  go :: Int -> Int -> v+  go !start !end = if end == start+    then+      let !(# v #) = I.index# vals start+       in v+    else+      let !mid = div (end + start) 2+          !valHi = I.index keys mid+       in case P.compare a valHi of+            LT -> go start mid+            EQ -> case I.index# vals mid of+              (# v #) -> v+            GT -> go (mid + 1) end+{-# INLINEABLE lookup #-}++union :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Eq v, Semigroup v)+  => Map karr varr k v+  -> Map karr varr k v+  -> Map karr varr k v+union = unionWith (<>)++-- This is also known as liftA2+unionWith :: forall karr aarr barr carr k a b c. (Contiguous karr, Element karr k, Ord k, Contiguous aarr, Element aarr a, Contiguous barr, Element barr b, Contiguous carr, Element carr c, Eq c)+  => (a -> b -> c)+  -> Map karr aarr k a+  -> Map karr barr k b+  -> Map karr carr k c+unionWith combine (Map keysA valsA) (Map keysB valsB) = runST action where+  action :: forall s. ST s (Map karr carr k c)+  action = do+    let szA = I.size keysA+        szB = I.size keysB+        szMax = szA + szB+    keysDst <- I.new szMax+    valsDst <- I.new szMax+    -- For total maps, we don't have to worry about one map running out+    -- before the other. Also, this function has a precondition that+    -- all three indices are greater than zero.+    let go :: Int -> Int -> Int -> c -> ST s Int+        go !ixA !ixB !ixDst prevVal = if ixA < szA && ixB < szB+          then do+            keyA <- I.indexM keysA ixA+            keyB <- I.indexM keysB ixB+            case P.compare keyA keyB of+              EQ -> do+                valA <- I.indexM valsA ixA+                valB <- I.indexM valsB ixB+                let !v = combine valA valB+                if v == prevVal+                  then do+                    I.write keysDst (ixDst - 1) keyA+                    go (ixA + 1) (ixB + 1) ixDst v+                  else do+                    I.write keysDst ixDst keyA+                    I.write valsDst ixDst v+                    go (ixA + 1) (ixB + 1) (ixDst + 1) v+              LT -> do+                valA <- I.indexM valsA ixA+                valB <- I.indexM valsB ixB+                let !v = combine valA valB+                if v == prevVal+                  then do+                    I.write keysDst (ixDst - 1) keyA+                    go (ixA + 1) ixB ixDst v+                  else do+                    I.write keysDst ixDst keyA+                    I.write valsDst ixDst v+                    go (ixA + 1) ixB (ixDst + 1) v+              GT -> do+                valA <- I.indexM valsA ixA+                valB <- I.indexM valsB ixB+                let !v = combine valA valB+                if v == prevVal+                  then do+                    I.write keysDst (ixDst - 1) keyB+                    go ixA (ixB + 1) ixDst v+                  else do+                    I.write keysDst ixDst keyB+                    I.write valsDst ixDst v+                    go ixA (ixB + 1) (ixDst + 1) v+          else return ixDst+    keyA <- I.indexM keysA 0+    keyB <- I.indexM keysB 0+    valA <- I.indexM valsA 0+    valB <- I.indexM valsB 0+    let v = combine valA valB+    dstIx <- case P.compare keyA keyB of+      EQ -> do+        I.write keysDst 0 keyA+        I.write valsDst 0 v+        go 1 1 1 v+      LT -> do+        I.write keysDst 0 keyA+        I.write valsDst 0 v+        go 1 0 1 v+      GT -> do+        I.write keysDst 0 keyB+        I.write valsDst 0 v+        go 0 1 1 v+    keys <- I.resize keysDst dstIx >>= I.unsafeFreeze+    vals <- I.resize valsDst dstIx >>= I.unsafeFreeze+    return (Map keys vals)++showsPrec :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k, Show k, Show v)+  => Int -> Map karr varr k v -> ShowS+showsPrec p m = showParen (p > 10)+  $ showString "fromList "+  . shows (toList m)++foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k)+  => (k -> k -> v -> b -> b)+  -> b+  -> Map karr varr k v+  -> b+foldrWithKey f z (Map keys vals) =+  let !sz = I.size vals+      -- we must be lazy in the second argument+      go !i lo+        | i == sz = z+        | otherwise =+            let !hi = I.index keys i+                !(# v #) = I.index# vals i+             in f lo hi v (go (i + 1) (succ hi))+   in go 0 minBound++foldlWithKeyM' :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k, Monad m)+  => (b -> k -> k -> v -> m b)+  -> b+  -> Map karr varr k v+  -> m b+foldlWithKeyM' f z (Map keys vals) =+  let !sz = I.size vals+      -- we must be lazy in the third argument+      go !i !acc lo+        | i == sz = return acc+        | otherwise = do+            let !hi = I.index keys i+                !(# v #) = I.index# vals i+            acc' <- f acc lo hi v+            go (i + 1) acc' (succ hi)+   in go 0 z minBound++foldl' :: (Contiguous varr, Element varr v)+  => (b -> v -> b)+  -> b+  -> Map karr varr k v+  -> b+foldl' f b0 (Map _ vals) = I.foldl' f b0 vals++foldMap :: (Contiguous varr, Element varr v, Monoid m)+  => (v -> m)+  -> Map karr varr k v+  -> m+foldMap f (Map _ vals) = I.foldMap f vals++toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Bounded k, Enum k)+  => Map karr varr k v+  -> [(k,k,v)]+toList = foldrWithKey (\lo hi v xs -> (lo,hi,v) : xs) []++fromList :: (Contiguous karr, Element karr k, Bounded k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)+  => v -- value outside of the ranges+  -> [(k,k,v)]+  -> Map karr varr k v+fromList def xs = concatWith+  def+  (\x y -> if x == def then y else x)+  (P.map (\(lo,hi,v) -> singleton def lo hi v) xs)++concatWith :: forall karr varr k v. (Contiguous karr, Bounded k, Element karr k, Ord k, Contiguous varr, Element varr v, Eq v)+  => v -- value used if the list is empty+  -> (v -> v -> v)+  -> [Map karr varr k v]+  -> Map karr varr k v+concatWith def combine = C.concatSized size (pure def) (unionWith combine)++concat :: (Contiguous karr, Bounded k, Element karr k, Ord k, Contiguous varr, Element varr v, Eq v, Monoid v)+  => [Map karr varr k v]+  -> Map karr varr k v+concat = concatWith mempty mappend++elems :: Map karr varr k v -> varr v+elems (Map _ v) = v+

@@ -0,0 +1,148 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Interval.DBTSLL+  ( Map+  , pure+  , singleton+  , lookup+  , fromList+  , unionWith+    -- * Mapping+  , map+  , mapBijection+    -- * Traversals+  , traverseBijectionP+  , traverseBijection+    -- * Folds+  , foldl'+  , foldMap+  , foldrWithKey+  , foldlWithKeyM'+  , traverse_+    -- * Conversion+  , elems+  ) where++import Prelude hiding (lookup,map,pure,foldMap)++import Data.Semigroup (Semigroup)+import Data.Primitive.Array (Array)+import Control.Monad.Primitive (PrimMonad)+import qualified Data.Semigroup as SG+import qualified Data.Map.Interval.DBTS.Internal as I+import qualified GHC.Exts as E++-- | A total interval map from keys @k@ to values @v@. The key type must be discrete+--   and bounded. This map is strict in the values.+newtype Map k v = Map (I.Map Array Array k v)++instance (Eq k, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++-- instance (Ord k, Ord v) => Ord (Map k v) where+--   compare (Map x) (Map y) = I.compare x y++instance (Ord k, Semigroup v, Eq v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.union x y)++-- The redundant constraint is needed for GHC < 8.4+instance (Ord k, Bounded k, Semigroup v, Monoid v, Eq v) => Monoid (Map k v) where+  mappend = (SG.<>) +  mempty = Map I.empty+  mconcat = Map . I.concat . E.coerce++instance (Bounded k, Enum k, Show k, Show v) => Show (Map k v) where+  showsPrec p (Map m) = I.showsPrec p m++instance (Bounded k, Enum k, Ord k, Eq v, Monoid v) => E.IsList (Map k v) where+  type Item (Map k v) = (k,k,v)+  fromList xs = Map (I.fromList mempty xs)+  toList (Map m) = I.toList m++pure :: Bounded k => v -> Map k v+pure = Map . I.pure ++singleton :: (Bounded k, Enum k, Ord k, Eq v)+  => v -- ^ value outside of the interval+  -> k -- ^ lower bound+  -> k -- ^ upper bound+  -> v -- ^ value inside the interval+  -> Map k v+singleton def lo hi v = Map (I.singleton def lo hi v)++lookup :: Ord k => k -> Map k v -> v+lookup k (Map m) = I.lookup k m++-- | Create an interval map from a list of range-value triples. The first+--   argument is a default value used everywhere outside of the given+--   ranges. In the case of overlapping ranges, the leftmost value is+--   used.+fromList :: (Bounded k, Ord k, Enum k, Eq v)+  => v -- ^ value outside of the ranges+  -> [(k,k,v)] -- ^ low-high inclusive ranges with their corresponding values+  -> Map k v+fromList def xs = Map (I.fromList def xs)++-- | This only provides a correct result when the effectful mapping+--   is a bijection.+traverseBijectionP :: PrimMonad m+  => (v -> m w) -> Map k v -> m (Map k w)+traverseBijectionP f (Map m) = fmap Map (I.traverseP f m)++-- | This only provides a correct result when the effectful mapping+--   is a bijection.+traverseBijection :: Applicative m+  => (v -> m w) -> Map k v -> m (Map k w)+traverseBijection f (Map m) = fmap Map (I.traverse f m)++traverse_ :: Applicative m => (v -> m w) -> Map k v -> m ()+traverse_ f (Map m) = I.traverse_ f m++mapBijection :: (v -> w) -> Map k v -> Map k w+mapBijection f (Map m) = Map (I.mapBijection f m)++map :: Eq w => (v -> w) -> Map k v -> Map k w+map f (Map m) = Map (I.map f m)++foldl' :: +     (b -> v -> b)+  -> b+  -> Map k v+  -> b+foldl' f b0 (Map m) = I.foldl' f b0 m++foldMap :: (Monoid m)+  => (v -> m)+  -> Map k v+  -> m+foldMap f (Map m) = I.foldMap f m++unionWith :: (Ord k, Eq c)+  => (a -> b -> c)+  -> Map k a+  -> Map k b+  -> Map k c+unionWith f (Map a) (Map b) = Map (I.unionWith f a b)++foldrWithKey :: (Bounded k, Enum k)+  => (k -> k -> v -> b -> b)+  -> b+  -> Map k v+  -> b+foldrWithKey f z (Map m) = I.foldrWithKey f z m++foldlWithKeyM' :: (Bounded k, Enum k, Monad m)+  => (b -> k -> k -> v -> m b)+  -> b+  -> Map k v+  -> m b+foldlWithKeyM' f z (Map m) = I.foldlWithKeyM' f z m++elems :: Map k v -> Array v+elems (Map m) = I.elems m+

@@ -13,6 +13,7 @@   , map   , mapMaybe   , mapMaybeWithKey+  , appendWithKey   , union     -- * Folds   , foldlWithKey'@@ -24,11 +25,13 @@   , foldlMapWithKeyM'   , foldrMapWithKeyM'     -- * List Conversion+  , toList   , fromList   , fromListAppend   , fromListN   , fromListAppendN   , fromSet+  , keys   , elems   ) where @@ -41,8 +44,7 @@ import qualified Data.Semigroup as SG import qualified Data.Map.Internal as I --- | A map from keys @k@ to values @v@. The key type and the value---   type must both have 'Prim' instances.+-- | A map from keys @k@ to values @v@. newtype Map k v = Map (I.Map Array Array k v)  instance Functor (Map k) where@@ -83,6 +85,10 @@ singleton :: k -> v -> Map k v singleton k v = Map (I.singleton k v) +-- | /O(n)/ A list of key-value pairs in ascending order.+toList :: Ord k => Map k v -> [(k,v)]+toList (Map m) = I.toList m+ -- | /O(n*log n)/ Create a map from a list of key-value pairs. -- If the list contains more than one value for the same key, -- the last value is retained. If the keys in the argument are@@ -152,6 +158,13 @@   -> Map k w mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m) +appendWithKey :: Ord k+  => (k -> v -> v -> v)+  -> Map k v+  -> Map k v+  -> Map k v+appendWithKey f (Map m) (Map n) = Map (I.appendWithKey f m n)+ -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. foldlWithKeyM' :: Monad m@@ -218,6 +231,10 @@ -- of @t1@ and @t2@. It prefers @t1@ when duplicate keys are encountered. union :: Ord k => Map k v -> Map k v -> Map k v union (Map a) (Map b) = Map (I.appendWith const a b)++-- | /O(1)/ The values in a map. This is a zero-cost operation.+keys :: Map k v -> Set k+keys (Map m) = Set (I.keys m)  -- | /O(1)/ The values in a map. This is a zero-cost operation. elems :: Map k v -> Array v

@@ -0,0 +1,235 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Map.Lifted.Unlifted+  ( Map(..)+  , empty+  , singleton+  , lookup+  , size+  , map+  , mapMaybe+  , mapMaybeWithKey+  , appendWithKey+  , union+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * List Conversion+  , toList+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  , fromSet+  , elems+  ) where++import Prelude hiding (lookup,map)++import Data.Semigroup (Semigroup)+import Data.Primitive (Array,UnliftedArray,PrimUnlifted)+import Data.Set.Lifted.Internal (Set(..))+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Map.Internal as I++-- | A map from keys @k@ to values @v@.+newtype Map k v = Map (I.Map Array UnliftedArray k v)++instance (Ord k, Semigroup v, PrimUnlifted v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Ord k, Semigroup v, PrimUnlifted v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (Eq k, Eq v, PrimUnlifted v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Ord k, Ord v, PrimUnlifted v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (Ord k, PrimUnlifted v) => E.IsList (Map k v) where+  type Item (Map k v) = (k,v)+  fromListN n = Map . I.fromListN n+  fromList = Map . I.fromList+  toList (Map s) = I.toList s++instance (Show k, Show v, PrimUnlifted v) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++-- | The empty diet map.+empty :: Map k v+empty = Map I.empty++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: (Ord k, PrimUnlifted v) => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++-- | /O(1)/ Create a map with a single element.+singleton :: PrimUnlifted v => k -> v -> Map k v+singleton k v = Map (I.singleton k v)++-- | /O(n)/ A list of key-value pairs in ascending order.+toList :: (Ord k, PrimUnlifted v) => Map k v -> [(k,v)]+toList (Map m) = I.toList m++-- | /O(n*log n)/ Create a map from a list of key-value pairs.+-- If the list contains more than one value for the same key,+-- the last value is retained. If the keys in the argument are+-- in nondescending order, this algorithm runs in /O(n)/ time instead.+fromList :: (Ord k, PrimUnlifted v) => [(k,v)] -> Map k v+fromList = Map . I.fromList++-- | /O(n*log n)/ This function has the same behavior as 'fromList'+-- regardless of whether or not the expected size is accurate. Additionally,+-- negative sizes are handled correctly. The expected size is used as the+-- size of the initially allocated buffer when building the 'Map'. If the+-- keys in the argument are in nondescending order, this algorithm runs+-- in /O(n)/ time.+fromListN :: (Ord k, PrimUnlifted v)+  => Int -- ^ expected size of resulting 'Map'+  -> [(k,v)] -- ^ key-value pairs+  -> Map k v+fromListN n = Map . I.fromListN n++-- | /O(n*log n)/ This function has the same behavior as 'fromList',+-- but it combines values with the 'Semigroup' instances instead of+-- choosing the last occurrence.+fromListAppend :: (Ord k, Semigroup v, PrimUnlifted v) => [(k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key.+fromSet :: PrimUnlifted v+  => (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)++-- | /O(n*log n)/ This function has the same behavior as 'fromListN',+-- but it combines values with the 'Semigroup' instances instead of+-- choosing the last occurrence.+fromListAppendN :: (Ord k, Semigroup v, PrimUnlifted v)+  => Int -- ^ expected size of resulting 'Map'+  -> [(k,v)] -- ^ key-value pairs+  -> Map k v+fromListAppendN n = Map . I.fromListAppendN n++-- | /O(1)/ The number of elements in the map.+size :: Map k v -> Int+size (Map m) = I.sizeKeys m++-- | /O(n)/ Map over the values in the map.+map :: (PrimUnlifted v, PrimUnlifted w)+  => (v -> w)+  -> Map k v+  -> Map k w+map f (Map m) = Map (I.map f m)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+mapMaybe :: (PrimUnlifted v, PrimUnlifted w)+  => (v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey :: (PrimUnlifted v, PrimUnlifted w)+  => (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)++appendWithKey :: (Ord k, PrimUnlifted v)+  => (k -> v -> v -> v)+  -> Map k v+  -> Map k v+  -> Map k v+appendWithKey f (Map m) (Map n) = Map (I.appendWithKey f m n)++-- | /O(n)/ Left monadic fold over the keys and values of the map. This fold+-- is strict in the accumulator.+foldlWithKeyM' :: (Monad m, PrimUnlifted v)+  => (b -> k -> v -> m b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> m b+foldlWithKeyM' f b0 (Map m) = I.foldlWithKeyM' f b0 m++-- | /O(n)/ Right monadic fold over the keys and values of the map. This fold+-- is strict in the accumulator.+foldrWithKeyM' :: (Monad m, PrimUnlifted v)+  => (k -> v -> b -> m b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> m b+foldrWithKeyM' f b0 (Map m) = I.foldrWithKeyM' f b0 m++-- | /O(n)/ Monadic left fold over the keys and values of the map with a strict+-- monoidal accumulator. The monoidal accumulator is appended to the left+-- after each reduction.+foldlMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted v)+  => (k -> v -> m b) -- ^ reduction+  -> Map k v -- ^ map+  -> m b+foldlMapWithKeyM' f (Map m) = I.foldlMapWithKeyM' f m++-- | /O(n)/ Monadic right fold over the keys and values of the map with a strict+-- monoidal accumulator. The monoidal accumulator is appended to the right+-- after each reduction.+foldrMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted v)+  => (k -> v -> m b) -- ^ reduction+  -> Map k v -- ^ map+  -> m b+foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m++-- | /O(n)/ Fold over the keys and values of the map with a strict monoidal+-- accumulator. This function does not have left and right variants since+-- the associativity required by a monoid instance means that both variants+-- would always produce the same result.+foldMapWithKey' :: (Monoid b, PrimUnlifted v)+  => (k -> v -> b) -- ^ reduction +  -> Map k v -- ^ map+  -> b+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m++-- | /O(n)/ Left fold over the keys and values with a strict accumulator.+foldlWithKey' :: PrimUnlifted v+  => (b -> k -> v -> b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> b+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m++-- | /O(n)/ Right fold over the keys and values with a strict accumulator.+foldrWithKey' :: PrimUnlifted v+  => (k -> v -> b -> b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> b+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m++-- | /O(n+m)/ The expression (@'union' t1 t2@) takes the left-biased union+-- of @t1@ and @t2@. It prefers @t1@ when duplicate keys are encountered.+union :: (Ord k, PrimUnlifted v) => Map k v -> Map k v -> Map k v+union (Map a) (Map b) = Map (I.appendWith const a b)++-- | /O(1)/ The values in a map. This is a zero-cost operation.+elems :: Map k v -> UnliftedArray v+elems (Map m) = I.elems m++

@@ -13,9 +13,12 @@   , map   , mapMaybe   , mapMaybeWithKey+  , mapWithKey   , keys   , intersectionWith+  , intersectionsWith   , restrict+  , appendWithKey     -- * Folds   , foldrWithKey   , foldlWithKey'@@ -33,6 +36,7 @@   , fromListAppend   , fromListN   , fromListAppendN+  , fromSet   , elems     -- * Array Conversion   , unsafeFreezeZip@@ -42,14 +46,16 @@  import Control.DeepSeq (NFData) import Control.Monad.ST (ST)-import Data.Semigroup (Semigroup)-import Data.Primitive.Types (Prim)+import Data.List.NonEmpty (NonEmpty) import Data.Primitive (PrimArray,Array,MutablePrimArray,MutableArray)+import Data.Primitive.Types (Prim)+import Data.Semigroup (Semigroup) import Data.Set.Unboxed.Internal (Set(..))+ import qualified Control.DeepSeq-import qualified GHC.Exts as E-import qualified Data.Semigroup as SG import qualified Data.Map.Internal as I+import qualified Data.Semigroup as SG+import qualified GHC.Exts as E  -- | A map from keys @k@ to values @v@. The key type must have a --   'Prim' instance and the value type is unconstrained.@@ -94,11 +100,11 @@ empty = Map I.empty  -- | /O(1)/ Create a map with a single element.-singleton :: (Prim k) => k -> v -> Map k v+singleton :: Prim k => k -> v -> Map k v singleton k v = Map (I.singleton k v)  -- | /O(n)/ A list of key-value pairs in ascending order.-toList :: (Prim k, Ord k, Prim v) => Map k v -> [(k,v)]+toList :: (Prim k, Ord k) => Map k v -> [(k,v)] toList (Map m) = I.toList m  -- | /O(n*log n)/ Create a map from a list of key-value pairs.@@ -135,6 +141,15 @@   -> Map k v fromListAppendN n = Map . I.fromListAppendN n +-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by applying the given function to each key.+fromSet :: Prim k+  => (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)+ -- | /O(1)/ The number of elements in the map. size :: Map k v -> Int size (Map m) = I.size m@@ -161,6 +176,20 @@   -> Map k w mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m) +-- | /O(n)/ Map over the elements with access to their corresponding keys.+mapWithKey :: Prim k+  => (k -> v -> w)+  -> Map k v+  -> Map k w+mapWithKey f (Map m) = Map (I.mapWithKey f m)++appendWithKey :: (Prim k, Ord k)+  => (k -> v -> v -> v)+  -> Map k v+  -> Map k v+  -> Map k v+appendWithKey f (Map m) (Map n) = Map (I.appendWithKey f m n)+ -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. foldlWithKeyM' :: (Monad m, Prim k)@@ -267,6 +296,15 @@   -> Map k b   -> Map k c intersectionWith f (Map a) (Map b) = Map (I.intersectionWith f a b)++-- | Take the intersection of all of the maps, combining elements at+-- equal keys with the provided function. Since intersection of maps lacks an+-- identity, this is provided with a non-empty list.+intersectionsWith :: (Prim k, Ord k)+  => (v -> v -> v)+  -> NonEmpty (Map k v)+  -> Map k v+intersectionsWith f xs = Map (I.intersectionsWith f (E.coerce xs))  restrict :: (Prim k, Ord k)   => Map k v

@@ -10,9 +10,12 @@   , singleton   , lookup   , size+    -- * Transform   , map   , mapMaybe   , mapMaybeWithKey+  , adjustMany+  , adjustManyInline     -- * Folds   , foldlWithKey'   , foldrWithKey'@@ -30,19 +33,25 @@   , fromListAppend   , fromListN   , fromListAppendN+  , fromSet+  , fromSetP     -- * Array Conversion   , unsafeFreezeZip   ) where  import Prelude hiding (lookup,map) +import Control.Monad.Primitive (PrimMonad) import Control.Monad.ST (ST)-import Data.Semigroup (Semigroup)-import Data.Primitive.Types (Prim) import Data.Primitive.PrimArray (PrimArray,MutablePrimArray)-import qualified GHC.Exts as E-import qualified Data.Semigroup as SG+import Data.Primitive.Types (Prim)+import Data.Semigroup (Semigroup)+import Data.Set.Unboxed.Internal (Set(..))+import GHC.Exts (inline)+ import qualified Data.Map.Internal as I+import qualified Data.Semigroup as SG+import qualified GHC.Exts as E  -- | A map from keys @k@ to values @v@. The key type and the value --   type must both have 'Prim' instances.@@ -121,6 +130,25 @@   -> Map k v fromListAppendN n = Map . I.fromListAppendN n +-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key.+fromSet :: (Prim k, Prim v)+  => (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)++-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key. The function can perform+-- primitive monadic effects.+fromSetP :: (PrimMonad m, Prim k, Prim v)+  => (k -> m v)+  -> Set k+  -> m (Map k v)+fromSetP f (Set s) = fmap Map (I.fromSetP f s)+ -- | /O(1)/ The number of elements in the map. size :: Prim v => Map k v -> Int size (Map m) = I.size m@@ -146,6 +174,39 @@   -> Map k v   -> Map k w mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)++-- | Update the values at any number of keys. This is done+-- on in a buffer without building intermediate maps. Example use:+--+-- > adjustMany+-- >   (\adjust -> do+-- >     adjust 2 (\x -> pure (x + 1))+-- >     adjust 3 (\_ -> pure 42)+-- >   ) myMap+--+-- This increments by 1 the value associated with key 2. Then,+-- it replaces with 42 the value associated with key 3.+adjustMany :: (Prim k, Prim v, PrimMonad m, Ord k)+  => ((k -> (v -> m v) -> m ()) -> m a) -- ^ Modification-applying function+  -> Map k v -- ^ Map+  -> m (Map k v, a)+{-# INLINABLE adjustMany #-}+adjustMany f (Map m) = do+  (r,a) <- I.adjustMany f m+  pure (Map r, a)++-- | This has the same behavior as 'adjustMany'. However, it will be+--   inlined rather than specialized. The can prevent needless boxing+--   in the callback. Use @-ddump-simpl@ and standard profiling techniques+--   to figure out if this function actually helps you.+adjustManyInline :: (Prim k, Prim v, PrimMonad m, Ord k)+  => ((k -> (v -> m v) -> m ()) -> m a) -- ^ Modification-applying function+  -> Map k v -- ^ Map+  -> m (Map k v, a)+{-# INLINE adjustManyInline #-}+adjustManyInline f (Map m) = do+  (r,a) <- I.adjustManyInline f m+  pure (Map r, a)  -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator.

@@ -10,9 +10,12 @@   , singleton   , lookup   , size+    -- * Transform   , map   , mapMaybe+  , mapMaybeP   , mapMaybeWithKey+  , adjustMany     -- * Folds   , foldlWithKey'   , foldrWithKey'@@ -22,25 +25,32 @@   , foldrWithKeyM'   , foldlMapWithKeyM'   , foldrMapWithKeyM'+    -- * Traversals+  , traverse     -- * List Conversion   , fromList   , fromListAppend   , fromListN   , fromListAppendN+  , fromSet+  , fromSetP     -- * Array Conversion   , unsafeFreezeZip   ) where -import Prelude hiding (lookup,map)+import Prelude hiding (lookup,map,traverse) -import Data.Semigroup (Semigroup)+import Control.Monad.Primitive (PrimMonad)+import Control.Monad.ST (ST)+import Data.Primitive (PrimArray,MutablePrimArray) import Data.Primitive.Types (Prim) import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)-import Data.Primitive (PrimArray,MutablePrimArray)-import Control.Monad.ST (ST)-import qualified GHC.Exts as E-import qualified Data.Semigroup as SG+import Data.Semigroup (Semigroup)+import Data.Set.Unboxed.Internal (Set(..))+ import qualified Data.Map.Internal as I+import qualified Data.Semigroup as SG+import qualified GHC.Exts as E  -- | A map from keys @k@ to values @v@. The key type and the value --   type must both have 'Prim' instances.@@ -115,6 +125,27 @@   -> Map k v fromListAppendN n = Map . I.fromListAppendN n +-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key.+fromSet :: (Prim k, PrimUnlifted v)+  => (k -> v)+  -> Set k+  -> Map k v+{-# INLINE fromSet #-}+fromSet f (Set s) = Map (I.fromSet f s)++-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key. The function can perform+-- primitive monadic effects.+fromSetP :: (PrimMonad m, Prim k, PrimUnlifted v)+  => (k -> m v)+  -> Set k+  -> m (Map k v)+{-# INLINE fromSetP #-}+fromSetP f (Set s) = fmap Map (I.fromSetP f s)+ -- | /O(1)/ The number of elements in the map. size :: PrimUnlifted v => Map k v -> Int size (Map m) = I.size m@@ -131,9 +162,18 @@   => (v -> Maybe w)   -> Map k v   -> Map k w+{-# INLINE mapMaybe #-} mapMaybe f (Map m) = Map (I.mapMaybe f m)  -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+mapMaybeP :: (PrimMonad m, Prim k, PrimUnlifted v, PrimUnlifted w)+  => (v -> m (Maybe w))+  -> Map k v+  -> m (Map k w)+{-# INLINE mapMaybeP #-}+mapMaybeP f (Map m) = fmap Map (I.mapMaybeP f m)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'. -- The predicate is given access to the key. mapMaybeWithKey :: (Prim k, PrimUnlifted v, PrimUnlifted w)   => (k -> v -> Maybe w)@@ -141,6 +181,25 @@   -> Map k w mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m) +-- | Update the values at any number of keys. This is done+-- on in a buffer without building intermediate maps. Example use:+--+-- > adjustMany+-- >   (\adjust -> do+-- >     adjust 2 (\x -> pure (x + 1))+-- >     adjust 3 (\_ -> pure 42)+-- >   ) myMap+--+-- This increments by 1 the value associated with key 2. Then,+-- it replaces with 42 the value associated with key 3.+adjustMany :: (Prim k, PrimUnlifted v, PrimMonad m, Ord k)+  => ((k -> (v -> m v) -> m ()) -> m a) -- ^ Modification-applying function+  -> Map k v -- ^ Map+  -> m (Map k v, a)+adjustMany f (Map m) = do+  (r,a) <- I.adjustMany f m+  pure (Map r, a)+ -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold -- is strict in the accumulator. foldlWithKeyM' :: (Monad m, Prim k, PrimUnlifted v)@@ -176,6 +235,13 @@   -> Map k v -- ^ map   -> m b foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m++-- | /O(n)/ Traverse the values of the map.+traverse :: (Applicative m, Prim k, PrimUnlifted v, PrimUnlifted w)+  => (v -> m w)+  -> Map k v+  -> m (Map k w)+traverse f (Map m) = fmap Map (I.traverse f m)  -- | /O(n)/ Fold over the keys and values of the map with a strict monoidal -- accumulator. This function does not have left and right variants since

@@ -110,15 +110,6 @@ fromListAppend :: (PrimUnlifted k, Ord k, Semigroup v) => [(k,v)] -> Map k v fromListAppend = Map . I.fromListAppend --- | /O(n)/ Build a map from a set. This function is uses the underlying--- array that backs the set as the array for the keys. It constructs the--- values by apply the given function to each key.-fromSet :: PrimUnlifted k-  => (k -> v)-  -> Set k-  -> Map k v-fromSet f (Set s) = Map (I.fromSet f s)- -- | /O(n*log n)/ This function has the same behavior as 'fromListN', -- but it combines values with the 'Semigroup' instances instead of -- choosing the last occurrence.@@ -127,6 +118,15 @@   -> [(k,v)] -- ^ key-value pairs   -> Map k v fromListAppendN n = Map . I.fromListAppendN n++-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by applying the given function to each key.+fromSet :: PrimUnlifted k+  => (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)  -- | /O(1)/ The number of elements in the map. size :: Map k v -> Int

@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-}  {-# OPTIONS_GHC -Wall #-}@@ -12,6 +13,8 @@   , empty   , null   , singleton+  , doubleton+  , tripleton   , difference   , intersection   , append@@ -25,6 +28,8 @@   , toArray   , size   , concat+  , subset+  , enumFromTo     -- * Folds   , foldr   , foldMap@@ -36,9 +41,10 @@     -- * Traversals   , traverse_   , itraverse_+  , map   ) where -import Prelude hiding (compare,showsPrec,concat,foldr,foldMap,null)+import Prelude hiding (compare,showsPrec,concat,foldr,foldMap,null,map,enumFromTo)  import Control.Monad.ST (ST,runST) import Data.Hashable (Hashable)@@ -69,6 +75,10 @@ compare :: (Contiguous arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Ordering compare (Set x) (Set y) = compareArr x y +-- Only correct if the function is a monotone.+map :: (Contiguous arr, Element arr a, Element arr b) => (a -> b) -> Set arr a -> Set arr b+map f (Set x) = Set (A.map f x)+ fromListN :: (Contiguous arr, Element arr a, Ord a) => Int -> [a] -> Set arr a fromListN n xs = -- fromList xs   case xs of@@ -80,6 +90,35 @@ fromList :: (Contiguous arr, Element arr a, Ord a) => [a] -> Set arr a fromList = fromListN 1 +-- This is intended to be used with things like Word8,Int8,Word16,Int16,etc.+-- It does the minimal number of allocations. It does some extra checks+-- just in case someone write a bad Num instance for something. If+-- you have a Num instance that doesn't satisfy the laws one would+-- intuitively expect, this function will bail out and return+-- the empty set.+enumFromTo :: (Contiguous arr, Element arr a, Enum a, Ord a, Num a)+  => a -- Low+  -> a -- High+  -> Set arr a+enumFromTo !lo !hi = if hi >= lo+  then runST $ do+    let go !arr !ix !a !old = if ix >= 0+          then if a < old+            then A.write arr ix a *> go arr (ix - 1) (a - 1) a+            else pure (Set A.empty)+          else do+            r <- A.unsafeFreeze arr+            pure (Set r)+    let total = fromEnum (hi - lo)+    if total >= 0+      then do+        arr <- A.new (total + 1)+        A.write arr total hi+        go arr (total - 1) (hi - 1) hi+      else pure (Set A.empty)+  else Set A.empty++ difference :: forall a arr. (Contiguous arr, Element arr a, Ord a)   => Set arr a   -> Set arr a@@ -214,11 +253,38 @@       else EQ  singleton :: (Contiguous arr, Element arr a) => a -> Set arr a-singleton a = Set $ runST $ do-  arr <- A.new 1-  A.write arr 0 a-  A.unsafeFreeze arr+singleton a = Set (A.singleton a) +doubleton :: (Contiguous arr, Element arr a, Ord a) => a -> a -> Set arr a+doubleton a b = case P.compare a b of+  LT -> Set (A.doubleton a b)+  GT -> Set (A.doubleton b a)+  EQ -> Set (A.singleton a)++tripleton :: (Contiguous arr, Element arr a, Ord a) => a -> a -> a -> Set arr a+tripleton a b c = case P.compare a b of+  LT -> case P.compare b c of+    LT -> Set (A.tripleton a b c)+    EQ -> doubleton a b+    GT -> case P.compare a c of+      LT -> Set (A.tripleton a c b)+      EQ -> doubleton a b+      GT -> Set (A.tripleton c a b)+  GT -> case P.compare b c of+    LT -> case P.compare a c of+      LT -> Set (A.tripleton b a c)+      EQ -> doubleton b a+      GT -> Set (A.tripleton b c a)+    EQ -> doubleton b a+    GT -> Set (A.tripleton c b a)+  EQ -> doubleton b c++-- The shortcuts help when:+-- +-- * One of the arrays is empty. In this situation, we can just return+--   the other array instead of reconstructing it.+-- * All elements in one array are smaller than all elements in the+--   other. In this case, we can append the arrays, which uses memcpy. unionArr :: forall arr a. (Contiguous arr, Element arr a, Ord a)   => arr a -- array x   -> arr a -- array y@@ -226,6 +292,7 @@ unionArr arrA arrB   | szA < 1 = arrB   | szB < 1 = arrA+  | A.index arrA (szA - 1) < A.index arrB 0 = A.append arrA arrB   | otherwise = runST $ do       !(arrDst :: Mutable arr s a)  <- A.new (szA + szB)       let go !ixA !ixB !ixDst = if ixA < szA@@ -330,4 +397,50 @@ liftHashWithSalt f s (Set arr) = A.liftHashWithSalt f s arr {-# INLINEABLE liftHashWithSalt #-} +-- Returns true if the first set is a subset of the second set.+-- This algorithm could be improved by performing some kind of+-- galloping.+subset :: (Contiguous arr, Element arr a, Ord a)+  => Set arr a+  -> Set arr a+  -> Bool+subset (Set arrA) (Set arrB) = go 0 0+  where+  !szA = A.size arrA+  !szB = A.size arrB+  go !ixA !ixB = if ixA < szA+    then if ixB < szB+      then+        let !(# a #) = A.index# arrA ixA+            !(# b #) = A.index# arrB ixB+         in case P.compare a b of+              LT -> False+              EQ -> go (ixA + 1) (ixB + 1)+              GT -> go ixA (ixB + 1)+      else False+    else True +-- This relies on a sensible @Num@ instance for correctness. It is not totally+-- correcty yet because of the existence of zero+-- scale :: (Contiguous arr, Element arr a, Num a)+--   => a+--   -> Set arr a+--   -> Set arr a+-- scale x (Set arr) = Set (A.map' (x *)  arr)+-- {-# INLINEABLE scale #-}++-- Take the cross product of the two sets. That is, combine every+-- element in @A@ with every element in @B@ using the provided function.+-- If the combining function @f@ is an inequality morphism satisfying+-- @forall x y w z. x >= y ==> f x w >= f y z@, then this algorithm runs+-- in /O(n*m)/. Otherwise, it runs in @/O(n*m*log(n*m)/@.+-- cross :: (Contiguous arr, Element arr a, Element arr b, Element arr c)+--   => (a -> b -> c)+--   -> Set arr a+--   -> Set arr b+--   -> Set arr c+-- cross f (Set as) (Set bs) = runST $ do+--   let !maxSz = A.size as * A.size bs+--   !m <- A.new maxSz+--   let go !ixA !ixB !ixCount !ixDst !morphism = if ixCount < maxSz+--         then

@@ -14,6 +14,7 @@   , difference   , (\\)   , intersection+  , subset     -- * Conversion   , toArray   , LI.toList@@ -43,6 +44,10 @@ -- | The intersection of two sets. intersection :: Ord a => Set a -> Set a -> Set a intersection (Set x) (Set y) = Set (I.intersection x y)++-- | Is the first argument a subset of the second argument?+subset :: Ord a => Set a -> Set a -> Bool+subset (Set x) (Set y) = I.subset x y  -- | The empty set. empty :: Set a

@@ -0,0 +1,158 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Set.NonEmpty.Unlifted+  ( Set+  , singleton+  , member+  , size+    -- * Conversion+  , toArray+  , toList+  , fromNonEmpty+  , toSet+  , fromSet+    -- * Folds+  , foldr+  , foldMap+  , foldl'+  , foldr'+  , foldMap'+    -- * Traversals+  , traverse_+  , itraverse_+  ) where++import Prelude hiding (foldr,foldMap,null)++import Data.Hashable (Hashable)+import Data.Primitive.UnliftedArray (PrimUnlifted(..),UnliftedArray)+import Data.Semigroup (Semigroup)+import Data.List.NonEmpty (NonEmpty)++import qualified Data.Foldable as F+import qualified Data.Hashable as H+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as SG+import qualified Data.Set.Internal as I+import qualified GHC.Exts as E+import qualified Data.Set.Unlifted as S+import qualified Data.Set.Unlifted.Internal as SI++newtype Set a = Set (I.Set UnliftedArray a)++instance PrimUnlifted (Set a) where+  toArrayArray# (Set x) = toArrayArray# x+  fromArrayArray# y = Set (fromArrayArray# y)++instance (Ord a, PrimUnlifted a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)+  stimes = SG.stimesIdempotent+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))++instance (Hashable a, PrimUnlifted a) => Hashable (Set a) where+  hashWithSalt s (Set arr) = I.liftHashWithSalt H.hashWithSalt s arr++instance (PrimUnlifted a, Eq a) => Eq (Set a) where+  Set x == Set y = I.equals x y++instance (PrimUnlifted a, Ord a) => Ord (Set a) where+  compare (Set x) (Set y) = I.compare x y++instance (PrimUnlifted a, Show a) => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++-- | /O(n)/ Convert a set to a list. The elements are given in ascending order.+toList :: PrimUnlifted a => Set a -> [a]+toList (Set s) = I.toList s++-- | /O(n*log n)/ Convert a list to a set.+fromNonEmpty :: (PrimUnlifted a, Ord a) => NonEmpty a -> Set a+fromNonEmpty = Set . I.fromList . NE.toList++-- | /O(1)/ Convert a set to a non-empty set. This returns @Nothing@ if+-- the set is empty. The resulting non-empty set shares internal+-- represention as the argument.+fromSet :: SI.Set a -> Maybe (Set a)+fromSet s@(SI.Set x) = if S.null s+  then Nothing+  else Just (Set x)++-- | /O(0)/ Convert a non-empty set to a set. The resulting set shares+-- the internal representation with the argument.+toSet :: Set a -> SI.Set a+toSet = E.coerce++-- | Test for membership in the set.+member :: (PrimUnlifted a, Ord a) => a -> Set a -> Bool+member a (Set s) = I.member a s++-- | Construct a set with a single element.+singleton :: PrimUnlifted a => a -> Set a+singleton = Set . I.singleton++-- | The number of elements in the set.+size :: PrimUnlifted a => Set a -> Int+size (Set s) = I.size s++-- | /O(1)/ Convert a set to an array. The elements are given in ascending+-- order. This function is zero-cost.+toArray :: Set a -> UnliftedArray a+toArray (Set s) = I.toArray s++-- | Right fold over the elements in the set. This is lazy in the accumulator.+foldr :: PrimUnlifted a+  => (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr f b0 (Set s) = I.foldr f b0 s++-- | Monoidal fold over the elements in the set. This is lazy in the accumulator.+foldMap :: (PrimUnlifted a, Monoid m)+  => (a -> m)+  -> Set a+  -> m+foldMap f (Set s) = I.foldMap f s++-- | Strict left fold over the elements in the set.+foldl' :: PrimUnlifted a+  => (b -> a -> b)+  -> b+  -> Set a+  -> b+foldl' f b0 (Set s) = I.foldl' f b0 s++-- | Strict right fold over the elements in the set.+foldr' :: PrimUnlifted a+  => (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr' f b0 (Set s) = I.foldr' f b0 s++-- | Strict monoidal fold over the elements in the set.+foldMap' :: (PrimUnlifted a, Monoid m)+  => (a -> m)+  -> Set a+  -> m+foldMap' f (Set arr) = I.foldMap' f arr++-- | Traverse a set, discarding the result.+traverse_ :: (Applicative m, PrimUnlifted a)+  => (a -> m b)+  -> Set a+  -> m ()+traverse_ f (Set arr) = I.traverse_ f arr++-- | Traverse a set with the indices, discarding the result.+itraverse_ :: (Applicative m, PrimUnlifted a)+  => (Int -> a -> m b)+  -> Set a+  -> m ()+itraverse_ f (Set arr) = I.itraverse_ f arr+

@@ -9,15 +9,20 @@   ( S.Set   , empty   , singleton+  , doubleton+  , tripleton   , null   , member   , size   , difference   , (\\)   , intersection+  , subset+  , enumFromTo     -- * List Conversion   , S.toList   , S.fromList+  , toArray     -- * Folds   , foldr   , foldMap@@ -27,9 +32,10 @@     -- * Traversals   , traverse_   , itraverse_+  , mapMonotonic   ) where -import Prelude hiding (foldr,foldMap,null)+import Prelude hiding (foldr,foldMap,null,enumFromTo) import Data.Hashable (Hashable) import Data.Primitive.PrimArray (PrimArray) import Data.Primitive.Types (Prim)@@ -59,6 +65,18 @@ intersection :: (Ord a, Prim a) => Set a -> Set a -> Set a intersection (Set x) (Set y) = Set (I.intersection x y) +-- | Is the first argument a subset of the second argument?+subset :: (Ord a, Prim a) => Set a -> Set a -> Bool+subset (Set x) (Set y) = I.subset x y++-- | The set that includes all elements from the lower bound to the+-- upper bound.+enumFromTo :: (Enum a, Ord a, Num a, Prim a)+  => a -- ^ Inclusive lower bound+  -> a -- ^ Inclusive upper bound+  -> Set a+enumFromTo lo hi = Set (I.enumFromTo lo hi)+ -- | Test whether or not an element is present in a set. member :: (Prim a, Ord a) => a -> Set a -> Bool member a (Set s) = I.member a s@@ -71,6 +89,14 @@ singleton :: Prim a => a -> Set a singleton = Set . I.singleton +-- | Construct a set with two elements.+doubleton :: (Prim a, Ord a) => a -> a -> Set a+doubleton a b = Set (I.doubleton a b)++-- | Construct a set with two elements.+tripleton :: (Prim a, Ord a) => a -> a -> a -> Set a+tripleton a b c = Set (I.tripleton a b c)+ -- | The number of elements in the set. size :: Prim a => Set a -> Int size (Set s) = I.size s@@ -113,6 +139,11 @@   -> m foldMap f (Set arr) = I.foldMap f arr +-- | /O(1)/ Convert a set to an array. The elements are given in ascending+-- order. This function is zero-cost.+toArray :: Set a -> PrimArray a+toArray (Set s) = I.toArray s+ -- | Traverse a set, discarding the result. traverse_ :: (Applicative m, Prim a)   => (a -> m b)@@ -127,4 +158,13 @@   -> m () itraverse_ f (Set arr) = I.itraverse_ f arr {-# INLINEABLE itraverse_ #-}++-- | Map over the elements of a set. The provided function must be+-- monotonic.+mapMonotonic :: (Prim a, Prim b)+  => (a -> b)+  -> Set a+  -> Set b+mapMonotonic f (Set arr) = Set (I.map f arr)+{-# INLINEABLE mapMonotonic #-} 

@@ -14,6 +14,7 @@   , size   , difference   , intersection+  , enumFromTo     -- * Conversion   , toArray   , S.toList@@ -29,7 +30,7 @@   , itraverse_   ) where -import Prelude hiding (foldr,foldMap,null)+import Prelude hiding (foldr,foldMap,null,enumFromTo)  import Data.Primitive.UnliftedArray (UnliftedArray, PrimUnlifted(..)) import Data.Semigroup (Semigroup)@@ -64,6 +65,14 @@ -- | The intersection of two sets. intersection :: (Ord a, PrimUnlifted a) => Set a -> Set a -> Set a intersection (Set x) (Set y) = Set (I.intersection x y)++-- | The set that includes all elements from the lower bound to the+-- upper bound.+enumFromTo :: (Enum a, Ord a, Num a, PrimUnlifted a)+  => a -- ^ Inclusive lower bound+  -> a -- ^ Inclusive upper bound+  -> Set a+enumFromTo lo hi = Set (I.enumFromTo lo hi)  -- | /O(1)/ Convert a set to an array. The elements are given in ascending -- order. This function is zero-cost.

@@ -16,7 +16,6 @@ import Data.Primitive.UnliftedArray (PrimUnlifted(..),UnliftedArray) import Data.Primitive (Array) import Data.Semigroup (Semigroup)-import Text.Show (showListWith)  import qualified Data.Foldable as F import qualified Data.Hashable as H

@@ -18,31 +18,32 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  import Data.Primitive-import Data.Primitive.UnliftedArray (PrimUnlifted) import Data.Word-import Data.Proxy (Proxy(..)) import Data.Int-import Data.Functor.Const (Const(..))-import Data.Kind (Type) -import Test.Tasty (defaultMain,testGroup,TestTree)-import Test.Tasty.HUnit (testCase,(@?=))-import Test.QuickCheck (Arbitrary,Gen,(===),(==>))-import Test.HUnit.Base (assertEqual)+import Control.Applicative (liftA2)+import Control.Monad (forM) import Data.Bool (bool)-import Data.List.NonEmpty (NonEmpty((:|)))-import Data.Exists (ToSing(..),DependentPair(..),ShowForall(..),ShowForeach(..))-import Data.Exists (WitnessedEquality(..),WitnessedOrdering(..),EqForall(..),OrdForall(..))+import Data.Continuous.Set.Lifted (Inclusivity(..))+import Data.Dependent.Map.Class (Universally(..),ApplyUniversally(..)) import Data.Exists (EqForeach(..),OrdForeach(..),EqForallPoly(..),OrdForallPoly(..),Sing)+import Data.Exists (FromJSONForeach(..),SemigroupForeach(..)) import Data.Exists (PrimForall(..),ToJSONKeyForall(..),ToJSONKeyFunctionForall(..)) import Data.Exists (ToJSONForeach(..),FromJSONKeyExists(..),Exists(..))-import Data.Exists (FromJSONForeach(..))-import Control.Monad (forM)+import Data.Exists (ToSing(..),DependentPair(..),ShowForall(..),ShowForeach(..))+import Data.Exists (WitnessedEquality(..),WitnessedOrdering(..),EqForall(..),OrdForall(..))+import Data.Functor.Const (Const(..))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Primitive.UnliftedArray (PrimUnlifted)+import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup)-import Unsafe.Coerce (unsafeCoerce)-import Data.Dependent.Map.Class (Universally(..),ApplyUniversally(..))+import Test.HUnit.Base (assertEqual)+import Test.QuickCheck (Arbitrary,Gen,(===),(==>))+import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.Tasty.HUnit (testCase,(@?=)) import Text.Read (readMaybe)-import Data.Continuous.Set.Lifted (Inclusivity(..))+import Unsafe.Coerce (unsafeCoerce) import qualified Data.Aeson as AE import qualified Data.Aeson.Encoding as AEE import qualified Data.Text as T@@ -59,6 +60,8 @@ import qualified Data.Set.Unboxed as SU import qualified Data.Set.Lifted as SL import qualified Data.Set.Unlifted as SUL+import qualified Data.Map.Lifted.Lifted as MLL+import qualified Data.Map.Unboxed.Lifted as MUL import qualified Data.Map.Unboxed.Unboxed as MUU import qualified Data.Diet.Map.Strict.Unboxed.Lifted as DMUL import qualified Data.Diet.Map.Strict.Lifted.Lifted as DMLL@@ -68,6 +71,7 @@ import qualified Data.Dependent.Map.Lifted.Lifted as DPMLL import qualified Data.Dependent.Map.Unboxed.Lifted as DPMUL import qualified Data.Map.Subset.Strict.Lifted as MSL+import qualified Data.Map.Interval.DBTSLL as MIDBTS  main :: IO () main = defaultMain $ testGroup "Data"@@ -75,16 +79,20 @@     [ testGroup "Unboxed"       [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SU.Set Int16)))       , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SU.Set Int16)))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SU.Set Int16)))       , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (SU.Set Int16)))       , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SU.Set Int16)))       , TQC.testProperty "member" (memberProp @Int16 E.fromList SU.member)+      , TQC.testProperty "tripleton" setTripletonProp       ]     , testGroup "Lifted"       [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SL.Set Integer)))       , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SL.Set Integer)))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SL.Set Integer)))       , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (SL.Set Integer)))       , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SL.Set Integer)))       , TQC.testProperty "member" (memberProp @Integer E.fromList SL.member)+      , TQC.testProperty "nonMember" (nonMemberProp E.fromList SL.member)       , TQC.testProperty "foldr" (QCCL.foldrProp int32 SL.foldr)       , TQC.testProperty "foldl'" (QCCL.foldlProp int16 SL.foldl')       , TQC.testProperty "foldr'" (QCCL.foldrProp int32 SL.foldr')@@ -98,6 +106,7 @@     , testGroup "Unlifted"       [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))       , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))       , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))       , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))       , TQC.testProperty "member" (memberProp @(PrimArray Int16) E.fromList SUL.member)@@ -109,6 +118,7 @@         [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MUU.Map Word32 Int)))         , lawsToTest (QCC.ordLaws (Proxy :: Proxy (MUU.Map Word32 Int)))         , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MUU.Map Word32 Word)))+        , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (MUU.Map Word32 Int)))         , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MUU.Map Word32 Int)))         , lawsToTest (QCC.isListLaws (Proxy :: Proxy (MUU.Map Word32 Int)))         , TQC.testProperty "lookup" (lookupProp @Word32 @Int E.fromList MUU.lookup)@@ -117,23 +127,77 @@         , TQC.testProperty "foldMapWithKey'" (mapFoldMonoidAgreement MUU.foldMapWithKey' M.foldMapWithKey)         , TQC.testProperty "mapMaybe" mapMaybeProp         ]+      , testGroup "Lifted"+        [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MUL.Map Word32 Integer)))+        , lawsToTest (QCC.ordLaws (Proxy :: Proxy (MUL.Map Word32 Integer)))+        , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MUL.Map Word32 Integer)))+        , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (MUL.Map Word32 Integer)))+        , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MUL.Map Word32 Integer)))+        , lawsToTest (QCC.isListLaws (Proxy :: Proxy (MUL.Map Word32 Integer)))+        , TQC.testProperty "lookup-empty" lookupEmptyUnboxedLiftedMapProp+        , TQC.testProperty "mapWithKey" mapWithKeyProp+        , TQC.testProperty "appendWithKey" appendWithKeyUnboxedLiftedProp+        ]       ]-    ]-  , testGroup "Dependent"-    [ testGroup "Map"+    , testGroup "Lifted"       [ testGroup "Lifted"-        [ testGroup "Lifted"-          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMLL.Map Key Value)))-          , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMLL.Map Key Value)))-          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+        [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MLL.Map Integer Integer)))+        , lawsToTest (QCC.ordLaws (Proxy :: Proxy (MLL.Map Integer Integer)))+        , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MLL.Map Integer Integer)))+        , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (MLL.Map Integer Integer)))+        , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MLL.Map Integer Integer)))+        , lawsToTest (QCC.isListLaws (Proxy :: Proxy (MLL.Map Integer Integer)))+        , TQC.testProperty "appendWithKey" appendWithKeyLiftedLiftedProp+        ]+      ]+    , testGroup "Interval"+      [ testGroup "DBTS"+        [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MIDBTS.Map Word8 Integer)))+        , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MIDBTS.Map Word8 (S.Set Integer))))+        , lawsToTest (QCC.commutativeSemigroupLaws (Proxy :: Proxy (MIDBTS.Map Word8 (S.Set Integer))))+        , lawsToTest (QCC.idempotentSemigroupLaws (Proxy :: Proxy (MIDBTS.Map Word8 (S.Set Integer))))+        , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MIDBTS.Map Word8 Integer)))+        , lawsToTest (QCC.isListLaws (Proxy :: Proxy (MIDBTS.Map Word8 Integer)))+        , TQC.testProperty "lookup" dbtsIntervalMapLookupProp+        , testGroup "Unit"+          [ testCase "A" $ do+              let s = MIDBTS.singleton 102 (1 :: Word8) (2 :: Word8) (101 :: Integer)+              show s @?= "fromList [(0,0,102),(1,2,101),(3,255,102)]"+          , testCase "B" $ do+              let s = MIDBTS.singleton 102 (2 :: Word8) (2 :: Word8) (101 :: Integer)+              show s @?= "fromList [(0,1,102),(2,2,101),(3,255,102)]"+          , testCase "C" $ do+              let s = MIDBTS.singleton 102 (0 :: Word8) (0 :: Word8) (101 :: Integer)+              show s @?= "fromList [(0,0,101),(1,255,102)]"+          , testCase "D" $ do+              let s = MIDBTS.fromList 102 [(1 :: Word8, 2 :: Word8, 100 :: Integer),(5,7,101)]+              show s @?= "fromList [(0,0,102),(1,2,100),(3,4,102),(5,7,101),(8,255,102)]"+          , testCase "E" $ do+              let s = MIDBTS.fromList 102 [(5,7,101),(1 :: Word8, 2 :: Word8, 100 :: Integer)]+              show s @?= "fromList [(0,0,102),(1,2,100),(3,4,102),(5,7,101),(8,255,102)]"           ]         ]-      , testGroup "Unboxed"+      ]+    ]+  , testGroup "Dependent"+    [ testGroup "Map"+      [ -- testGroup "Lifted"+        -- [ testGroup "Lifted"+        --   [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+        --   , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+        --   , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+        --   , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+        --   , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+        --   ]+        -- ]+        testGroup "Unboxed"         [ testGroup "Lifted"           [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))           , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))           , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))           , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))+          , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))+          , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))           ]         ]       ]@@ -172,6 +236,7 @@       [ testGroup "Set"         [ testGroup "Lifted"           [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DUSL.Set Word8)))+          , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DUSL.Set Word8)))           , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DUSL.Set Word8)))           ]         ]@@ -180,6 +245,7 @@       [ testGroup "Lifted"         [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DSL.Set Word16)))         , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DSL.Set Word16)))+        , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DSL.Set Word16)))         , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DSL.Set Word16)))         , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DSL.Set Word16)))         , TQC.testProperty "member" (dietMemberProp @Word8 E.fromList DSL.member)@@ -204,6 +270,7 @@         [ testGroup "Lifted"           [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer))))           , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MSL.Map Integer (SG.First Integer))))+          , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer))))           , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer))))           , TQC.testProperty "lookup" subsetMapLookupProp           ]@@ -367,6 +434,26 @@       func x = if even x then Just (x * x) else Nothing    in MUU.toList (MUU.mapMaybe func xs') === M.toList (M.mapMaybe func xs) +mapWithKeyProp :: QC.Property+mapWithKeyProp = QC.property $ \(xs :: M.Map Word8 Word8) ->+  let xs' = MUL.fromList (M.toList xs)+      func x y = if even x then y * x else x + 1+   in MUL.toList (MUL.mapWithKey func xs') === M.toList (M.mapWithKey func xs)++appendWithKeyUnboxedLiftedProp :: QC.Property+appendWithKeyUnboxedLiftedProp = QC.property $ \(xs :: M.Map Word8 Word8) ys ->+  let xs' = MUL.fromList (M.toList xs)+      ys' = MUL.fromList (M.toList ys) +      func k x y = k + 2 * x + 3 * y+   in MUL.toList (MUL.appendWithKey func xs' ys') === M.toList (M.unionWithKey func xs ys)++appendWithKeyLiftedLiftedProp :: QC.Property+appendWithKeyLiftedLiftedProp = QC.property $ \(xs :: M.Map Word8 Word8) ys ->+  let xs' = MLL.fromList (M.toList xs)+      ys' = MLL.fromList (M.toList ys) +      func k x y = k + 2 * x + 3 * y+   in MLL.toList (MLL.appendWithKey func xs' ys') === M.toList (M.unionWithKey func xs ys)+ itraverseSetProp :: QC.Property itraverseSetProp = QC.property $ \(xs :: S.Set Int) ->   let xs' = SL.fromList (S.toList xs)@@ -399,12 +486,31 @@   let c = containerFromList xs    in all (\x -> containerMember x c) xs === True +setTripletonProp :: QC.Property+setTripletonProp = QC.property $ \(a :: Int16) (b :: Int16) (c :: Int16) ->+  SU.tripleton a b c === SU.fromList [a,b,c]++nonMemberProp :: forall t. ([Integer] -> t Integer) -> (Integer -> t Integer -> Bool) -> QC.Property+nonMemberProp containerFromList containerMember = QC.property $ \(xs :: [Integer]) ->+  let c = containerFromList xs+      upper = case xs of+        [] -> 42+        _ : _ -> maximum xs+      lower = case xs of+        [] -> (-42)+        _ : _ -> minimum xs+   in (containerMember (succ upper) c, containerMember (pred lower) c) === (False,False)+ lookupProp :: forall k v t. (Arbitrary k, Show k, Ord k, Arbitrary v, Show v, Eq v) => ([(k,v)] -> t k v) -> (k -> t k v -> Maybe v) -> QC.Property lookupProp containerFromList containerLookup = QC.property $ \(xs :: [(k,v)]) ->   let ys = M.fromList xs       c = containerFromList xs    in all (\(x,_) -> containerLookup x c == M.lookup x ys) xs === True +lookupEmptyUnboxedLiftedMapProp :: QC.Property+lookupEmptyUnboxedLiftedMapProp = QC.property $ \(x :: Word16) ->+  MUL.lookup x (MUL.empty :: MUL.Map Word16 Integer) === Nothing+ dietMemberProp :: forall a t. (Arbitrary a, Show a, Ord a, Arbitrary a, Show (t a)) => ([(a,a)] -> t a) -> (a -> t a -> Bool) -> QC.Property dietMemberProp containerFromList containerLookup = QC.property $ \(xs :: [a]) ->   let c = containerFromList (map (\a -> (a,a)) xs)@@ -416,6 +522,12 @@       c = containerFromList (map (\(k,v) -> (k,k,v)) xs)    in QC.counterexample ("original list: " ++ show xs ++ "; diet map: " ++ show c) (all (\(x,_) -> containerLookup x c == M.lookup x ys) xs === True) +dbtsIntervalMapLookupProp :: QC.Property+dbtsIntervalMapLookupProp = QC.property $ \(xs :: [(Word8,Word8,Integer)]) (k :: Word8) ->+  let ys = MIDBTS.fromList Nothing (fmap (\(lo,hi,r) -> (lo,hi,Just r)) xs)+      expected = fmap (\(_,_,r) -> r) (F.find (\(lo,hi,_) -> lo <= k && k <= hi) xs)+   in expected === MIDBTS.lookup k ys+ dietDoubletonProp :: QC.Property dietDoubletonProp = QC.property $ \(loA :: Word8) (hiA :: Word8) (valA :: Int) (loB :: Word8) (hiB :: Word8) (valB :: Int) ->   (hiA >= loA && hiB >= loB)@@ -491,9 +603,18 @@ instance (Arbitrary k, Prim k, Ord k, Arbitrary v, Prim v) => Arbitrary (MUU.Map k v) where   arbitrary = fmap E.fromList QC.arbitrary +instance (Arbitrary k, Prim k, Ord k, Arbitrary v) => Arbitrary (MUL.Map k v) where+  arbitrary = fmap E.fromList QC.arbitrary++instance (Arbitrary k, Ord k, Arbitrary v) => Arbitrary (MLL.Map k v) where+  arbitrary = fmap E.fromList QC.arbitrary+ instance (Arbitrary k, Ord k, Enum k, Bounded k, Arbitrary v, Semigroup v, Eq v) => Arbitrary (DMLL.Map k v) where   arbitrary = DMLL.fromListAppend <$> QC.vectorOf 10 arbitraryOrderedPairValue   shrink x = map E.fromList (QC.shrink (E.toList x))++instance (Ord k, Enum k, Eq v, Bounded k, Arbitrary k, Arbitrary v) => Arbitrary (MIDBTS.Map k v) where+  arbitrary = liftA2 MIDBTS.fromList QC.arbitrary (QC.vectorOf 10 arbitraryOrderedPairValue)      instance (Arbitrary k, Ord k, Arbitrary v, Eq v, Semigroup v) => Arbitrary (MSL.Map k v) where   arbitrary = do@@ -613,7 +734,7 @@ type instance Sing = SingUniverse  type family Interpret (u :: Universe) :: Type where-  Interpret 'UniverseInt = Int+  Interpret 'UniverseInt = Integer   Interpret 'UniverseOrdering = Ordering   Interpret 'UniverseBool = Bool   Interpret 'UniverseChar = Char@@ -638,6 +759,12 @@   showsPrecForeach SingUniverseBool p (Value x) = showsPrec p x   showsPrecForeach SingUniverseOrdering p (Value x) = showsPrec p x   showsPrecForeach SingUniverseChar p (Value x) = showsPrec p x++instance SemigroupForeach Value where+  appendForeach SingUniverseInt (Value x) (Value y) = Value (x + y)+  appendForeach SingUniverseBool (Value x) (Value y) = Value (x && y)+  appendForeach SingUniverseOrdering (Value x) (Value y) = Value (x <> y)+  appendForeach SingUniverseChar (Value x) (Value _) = Value x  -- This type interpret the lowest two bits of the Word8 -- as the Universe value. Doing this is unsafe, but if the