packages feed

primitive-containers (empty) → 0.2.0

raw patch · 29 files changed

+4348/−0 lines, 29 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, contiguous, gauge, ghc-prim, primitive, primitive-containers, primitive-sort, quickcheck-classes, random, tasty, tasty-quickcheck

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for primitive-containers++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# primitive-containers
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark-gauge/Main.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -O2 #-}++import Gauge.Main+import System.Random (randoms,mkStdGen)+import Data.Foldable (foldMap)+import Data.Maybe (fromMaybe)+import Data.Bool (bool)+import qualified GHC.Exts as E+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.Lifted.Lifted as DMLL+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IM+import qualified Data.Set as S++main :: IO ()+main = defaultMain+  [ bgroup "Map"+    [ bgroup "lookup" +      [ bench "primitive-unboxed-unboxed" $ whnf lookupAllUnboxed bigUnboxedMap+      , bench "containers-map" $ whnf lookupAllContainers bigContainersMap+      , bench "containers-intmap" $ whnf lookupAllIntContainers bigContainersIntMap+      ]+    , bgroup "fold"+      [ bench "primitive-unboxed-unboxed" $ whnf (DMUU.foldlWithKey' reduction 0) bigUnboxedMap+      , bench "primitive-lifted-lifted" $ whnf (DMLL.foldlWithKey' reduction 0) bigLiftedMap+      , bench "containers-map" $ whnf (M.foldlWithKey' reduction 0) bigContainersMap+      ]+    ]+  , bgroup "Set"+    [ bgroup "lookup" +      [ bench "primitive-unboxed" $ whnf lookupAllSetUnboxed bigUnboxedSet+      , bench "primitive-lifted" $ whnf lookupAllSetLifted bigLiftedSet+      ]+    , bgroup "fold"+      [ bench "primitive-unboxed" $ whnf (DSU.foldl' (+) 0) bigUnboxedSet+      , bench "containers-set" $ whnf (S.foldl' (+) 0) bigContainersSet+      ]+    , bgroup "concat"+      [ bgroup "fold"+        [ bench "20" $ whnf (foldMap DSU.singleton) randomArray20+        , bench "200" $ whnf (foldMap DSU.singleton) randomArray200+        , bench "2000" $ whnf (foldMap DSU.singleton) randomArray2000+        ]+      , bgroup "fromList"+        [ bench "20" $ whnf (E.fromList :: [Word] -> DSU.Set Word) randomArray20+        , bench "200" $ whnf (E.fromList :: [Word] -> DSU.Set Word) randomArray200+        , bench "2000" $ whnf (E.fromList :: [Word] -> DSU.Set Word) randomArray2000+        ]+      , bgroup "fromAscList"+        [ bench "20" $ whnf (E.fromList :: [Word] -> DSU.Set Word) ascArray20+        , bench "200" $ whnf (E.fromList :: [Word] -> DSU.Set Word) ascArray200+        , bench "2000" $ whnf (E.fromList :: [Word] -> DSU.Set Word) ascArray2000+        ]+      ]+    ]+  ]++reduction :: Int -> Int -> Int -> Int+reduction x y z = x + y + z++bigNumber :: Int+bigNumber = 100000++bigContainersSet :: S.Set Int+bigContainersSet = E.fromList (map (\x -> x `mod` (bigNumber * 2)) (take bigNumber (randoms (mkStdGen 75843))))++bigUnboxedSet :: DSU.Set Int+bigUnboxedSet = E.fromList (map (\x -> x `mod` (bigNumber * 2)) (take bigNumber (randoms (mkStdGen 75843))))++bigLiftedSet :: DSL.Set Int+bigLiftedSet = E.fromList (map (\x -> x `mod` (bigNumber * 2)) (take bigNumber (randoms (mkStdGen 75843))))++bigUnboxedMap :: DMUU.Map Int Int+bigUnboxedMap = 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))))++bigContainersMap :: M.Map Int Int+bigContainersMap = M.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))++bigContainersIntMap :: IM.IntMap Int+bigContainersIntMap = IM.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))++lookupAllUnboxed :: DMUU.Map Int Int -> Int+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++lookupAllSetUnboxed :: DSU.Set Int -> Int+lookupAllSetUnboxed m = go 0 0 where+  go !acc !n = if n < bigNumber+    then go (acc + bool 2 3 (DSU.member n m)) (n + 1)+    else acc++lookupAllSetLifted :: DSL.Set Int -> Int+lookupAllSetLifted m = go 0 0 where+  go !acc !n = if n < bigNumber+    then go (acc + bool 2 3 (DSL.member n m)) (n + 1)+    else acc++lookupAllContainers :: M.Map Int Int -> Int+lookupAllContainers m = go 0 0 where+  go !acc !n = if n < bigNumber+    then go (acc + fromMaybe 0 (M.lookup n m)) (n + 1)+    else acc++lookupAllIntContainers :: IM.IntMap Int -> Int+lookupAllIntContainers m = go 0 0 where+  go !acc !n = if n < bigNumber+    then go (acc + fromMaybe 0 (IM.lookup n m)) (n + 1)+    else acc++ascArray20 :: [Word]+ascArray20 = take 20 (enumFrom 0)++ascArray200 :: [Word]+ascArray200 = take 200 (enumFrom 0)++ascArray2000 :: [Word]+ascArray2000 = take 2000 (enumFrom 0)++randomArray20 :: [Word]+randomArray20 = take 20 (randoms (mkStdGen 75843))++randomArray200 :: [Word]+randomArray200 = take 200 (randoms (mkStdGen 75843))++randomArray2000 :: [Word]+randomArray2000 = take 2000 (randoms (mkStdGen 75843))
+ primitive-containers.cabal view
@@ -0,0 +1,88 @@+name: primitive-containers+version: 0.2.0+description: Please see the README on Github at <https://github.com/andrewthad/primitive-containers>+homepage: https://github.com/andrewthad/primitive-containers+bug-reports: https://github.com/andrewthad/primitive-containers/issues+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2018 Andrew Martin+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 2.0++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/andrewthad/primitive-containers++library+  hs-source-dirs:+      src+  build-depends:+      base >=4.9 && <5+    , primitive >= 0.6.4+    , primitive-sort >= 0.1 && < 0.2+    , contiguous >= 0.2 && < 0.3+  exposed-modules:+    Data.Diet.Map.Lifted.Lifted+    Data.Diet.Map.Unboxed.Lifted+    Data.Diet.Set+    Data.Diet.Set.Lifted+    Data.Diet.Set.Unboxed+    Data.Diet.Unbounded.Set.Lifted+    Data.Map.Lifted.Lifted+    Data.Map.Unboxed.Lifted+    Data.Map.Unboxed.Unboxed+    Data.Map.Unboxed.Unlifted+    Data.Set.Lifted+    Data.Set.Unboxed+    Data.Set.Unlifted+    Data.Map.Subset.Lifted+  other-modules:+    Data.Concatenation+    Data.Diet.Map.Internal+    Data.Diet.Set.Internal+    Data.Diet.Unbounded.Set.Internal+    Data.Map.Internal+    Data.Map.Subset.Internal+    Data.Set.Internal+    Data.Set.Lifted.Internal+  ghc-options: -O2 -Wall+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+      base+    , QuickCheck+    , containers+    , primitive+    , primitive-containers+    , quickcheck-classes >= 0.4.12+    , tasty+    , tasty-quickcheck+  ghc-options: -Wall -O2+  default-language: Haskell2010++benchmark gauge+  default-language: Haskell2010+  hs-source-dirs:+    benchmark-gauge+  main-is: Main.hs+  type: exitcode-stdio-1.0+  ghc-options: -Wall -O2+  build-depends:+      base >= 4.8 && < 4.12+    , primitive+    , primitive-containers+    , ghc-prim+    , gauge+    , random+    , containers+
+ src/Data/Concatenation.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Concatenation+  ( concatSized+  ) where++import qualified Data.List as L++concatSized :: forall m.+     (m -> Int) -- size function +  -> m+  -> (m -> m -> m)+  -> [m]+  -> m+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+  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+
+ src/Data/Diet/Map/Internal.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Diet.Map.Internal+  ( Map+  , empty+  , singleton+  , map+  , append+  , lookup+  , concat+  , equals+  , showsPrec+  , liftShowsPrec2+    -- list conversion+  , fromListN+  , fromList+  , fromListAppend+  , fromListAppendN+  , toList+  ) where++import Prelude hiding (lookup,showsPrec,concat,map)++import Control.Applicative (liftA2)+import Control.Monad.ST (ST,runST)+import Data.Semigroup (Semigroup)+import Data.Foldable (foldl')+import Text.Show (showListWith)+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)+import qualified Data.List as L+import qualified Data.Semigroup as SG+import qualified Prelude as P+import qualified Data.Primitive.Contiguous as I+import qualified Data.Concatenation as C++-- The key array is twice as long as the value array since+-- everything is stored as a range. Also, figure out how to+-- unpack these two arguments at some point.+data Map karr varr k v = Map !(karr k) !(varr v)++empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v+empty = Map I.empty I.empty++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)++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++fromListN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v+fromListN = fromListWithN (\_ a -> a)++fromList :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => [(k,k,v)] -> Map karr varr k v+fromList = fromListN 1++fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v+fromListAppendN = fromListWithN (SG.<>)++fromListAppend :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [(k,k,v)] -> Map karr varr k v+fromListAppend = fromListAppendN 1++fromListWithN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Int -> [(k,k,v)] -> Map karr varr k v+fromListWithN combine _ xs =+  concatWith combine (P.map (\(lo,hi,v) -> singleton lo hi v) xs)++concat :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [Map karr varr k v] -> Map karr varr k v+concat = concatWith (SG.<>)++singleton :: forall karr varr k v. (Contiguous karr, Element karr k,Ord k,Contiguous varr, Element varr v) => k -> k -> v -> Map karr varr k v+singleton !lo !hi !v = if lo <= hi+  then Map+    ( runST $ do+        !(arr :: Mutable karr s k) <- I.new 2+        I.write arr 0 lo+        I.write arr 1 hi+        I.unsafeFreeze arr+    )+    ( runST $ do+        !(arr :: Mutable varr s v) <- I.new 1+        I.write arr 0 v+        I.unsafeFreeze arr+    )+  else empty++lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> Maybe v+lookup a (Map keys vals) = go 0 (I.size vals - 1) where+  go :: Int -> Int -> Maybe v+  go !start !end = if end <= start+    then if end == start+      then +        let !valLo = I.index keys (2 * start)+            !valHi = I.index keys (2 * start + 1)+         in if a >= valLo && a <= valHi+              then case I.index# vals start of+                (# v #) -> Just v+              else Nothing+      else Nothing+    else+      let !mid = div (end + start + 1) 2+          !valLo = I.index keys (2 * mid)+       in case P.compare a valLo of+            LT -> go start (mid - 1)+            EQ -> case I.index# vals mid of+              (# v #) -> Just v+            GT -> go mid end+{-# INLINEABLE lookup #-}+++append :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v+append (Map ksA vsA) (Map ksB vsB) =+  case unionArrWith (SG.<>) ksA vsA ksB vsB of+    (k,v) -> Map k v++appendWith :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v+appendWith combine (Map ksA vsA) (Map ksB vsB) =+  case unionArrWith combine ksA vsA ksB vsB of+    (k,v) -> Map k v+  +  +unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)+  => (v -> v -> v)+  -> karr k -- keys a+  -> varr v -- values a+  -> karr k -- keys b+  -> varr v -- values b+  -> (karr k, varr v)+unionArrWith combine keysA valsA keysB valsB+  | I.size valsA < 1 = (keysB,valsB)+  | I.size valsB < 1 = (keysA,valsA)+  | otherwise = runST action+  where+  action :: forall s. ST s (karr k, varr v)+  action = do+    let !szA = I.size valsA+        !szB = I.size valsB+    !(keysDst :: Mutable karr s k) <- I.new (max szA szB * 8)+    !(valsDst :: Mutable varr s v) <- I.new (max szA szB * 4)+    let writeKeyRange :: Int -> k -> k -> ST s ()+        writeKeyRange !ix !lo !hi = do+          I.write keysDst (2 * ix) lo+          I.write keysDst (2 * ix + 1) hi+        writeDstHiKey :: Int -> k -> ST s ()+        writeDstHiKey !ix !hi = I.write keysDst (2 * ix + 1) hi+        writeDstValue :: Int -> v -> ST s ()+        writeDstValue !ix !v = I.write valsDst ix v+        readDstHiKey :: Int -> ST s k+        readDstHiKey !ix = I.read keysDst (2 * ix + 1)+        readDstVal :: Int -> ST s v+        readDstVal !ix = I.read valsDst ix+        indexLoKeyA :: Int -> k+        indexLoKeyA !ix = I.index keysA (ix * 2)+        indexLoKeyB :: Int -> k+        indexLoKeyB !ix = I.index keysB (ix * 2)+        indexHiKeyA :: Int -> k+        indexHiKeyA !ix = I.index keysA (ix * 2 + 1)+        indexHiKeyB :: Int -> k+        indexHiKeyB !ix = I.index keysB (ix * 2 + 1)+        indexValueA :: Int -> v+        indexValueA !ix = I.index valsA ix+        indexValueB :: Int -> v+        indexValueB !ix = I.index valsB ix+    -- In the go functon, ixDst is always at least one. Similarly,+    -- all key arguments are always greater than minBound.+    let go :: Int -> k -> k -> v -> Int -> k -> k -> v -> Int -> ST s Int+        go !ixA !loA !hiA !valA !ixB !loB !hiB !valB !ixDst = do+          prevHi <- readDstHiKey (ixDst - 1) +          prevVal <- readDstVal (ixDst - 1) +          case compare loA loB of+            LT -> do+              let (upper,ixA') = if hiA < loB+                    then (hiA,ixA + 1)+                    else (pred loB,ixA)+              ixDst' <- if pred loA == prevHi && valA == prevVal+                then do+                  writeDstHiKey (ixDst - 1) upper+                  return ixDst+                else do+                  writeKeyRange ixDst loA upper+                  writeDstValue ixDst valA+                  return (ixDst + 1)+              if ixA' < szA+                then do+                  let (loA',hiA') = if hiA < loB+                        then (indexLoKeyA ixA',indexHiKeyA ixA')+                        else (loB,hiA)+                  go ixA' loA' hiA' (indexValueA ixA') ixB loB hiB valB ixDst'+                else copyB ixB loB hiB valB ixDst'+            GT -> do+              let (upper,ixB') = if hiB < loA+                    then (hiB,ixB + 1)+                    else (pred loA,ixB)+              ixDst' <- if pred loB == prevHi && valB == prevVal+                then do+                  writeDstHiKey (ixDst - 1) upper+                  return ixDst+                else do+                  writeKeyRange ixDst loB upper+                  writeDstValue ixDst valB+                  return (ixDst + 1)+              if ixB' < szB+                then do+                  let (loB',hiB') = if hiB < loA+                        then (indexLoKeyB ixB',indexHiKeyB ixB')+                        else (loA,hiB)+                  go ixA loA hiA valA ixB' loB' hiB' (indexValueB ixB') ixDst'+                else copyA ixA loA hiA valA ixDst'+            EQ -> do+              let valCombination = combine valA valB+              case compare hiA hiB of+                LT -> do+                  ixDst' <- if pred loA == prevHi && valCombination == prevVal+                    then do+                      writeDstHiKey (ixDst - 1) hiA+                      return ixDst+                    else do+                      writeKeyRange ixDst loA hiA+                      writeDstValue ixDst valCombination+                      return (ixDst + 1)+                  let ixA' = ixA + 1+                      loB' = succ hiA+                  if ixA' < szA+                    then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixB loB' hiB valB ixDst'+                    else copyB ixB loB' hiB valB ixDst'+                GT -> do+                  ixDst' <- if pred loB == prevHi && valCombination == prevVal+                    then do+                      writeDstHiKey (ixDst - 1) hiB+                      return ixDst+                    else do+                      writeKeyRange ixDst loB hiB+                      writeDstValue ixDst valCombination+                      return (ixDst + 1)+                  let ixB' = ixB + 1+                      loA' = succ hiB+                  if ixB' < szB+                    then go ixA loA' hiA valA ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'+                    else copyA ixA loA' hiA valA ixDst'+                EQ -> do+                  ixDst' <- if pred loB == prevHi && valCombination == prevVal+                    then do+                      writeDstHiKey (ixDst - 1) hiB+                      return ixDst+                    else do+                      writeKeyRange ixDst loB hiB+                      writeDstValue ixDst valCombination+                      return (ixDst + 1)+                  let ixA' = ixA + 1+                      ixB' = ixB + 1+                  if ixA' < szA+                    then if ixB' < szB+                      then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'+                      else copyA ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixDst'+                    else if ixB' < szB+                      then copyB ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'+                      else return ixDst'+        copyB :: Int -> k -> k -> v -> Int -> ST s Int+        copyB !ixB !loB !hiB !valB !ixDst = do+          prevHi <- readDstHiKey (ixDst - 1) +          prevVal <- readDstVal (ixDst - 1) +          ixDst' <- if pred loB == prevHi && valB == prevVal+            then do+              writeDstHiKey (ixDst - 1) hiB+              return ixDst+            else do+              writeKeyRange ixDst loB hiB+              writeDstValue ixDst valB+              return (ixDst + 1)+          let ixB' = ixB + 1+              remaining = szB - ixB'+          I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2)+          I.copy valsDst ixDst' valsB ixB' remaining+          return (ixDst' + remaining)+        copyA :: Int -> k -> k -> v -> Int -> ST s Int+        copyA !ixA !loA !hiA !valA !ixDst = do+          prevHi <- readDstHiKey (ixDst - 1) +          prevVal <- readDstVal (ixDst - 1) +          ixDst' <- if pred loA == prevHi && valA == prevVal+            then do+              writeDstHiKey (ixDst - 1) hiA+              return ixDst+            else do+              writeKeyRange ixDst loA hiA+              writeDstValue ixDst valA+              return (ixDst + 1)+          let ixA' = ixA + 1+              remaining = szA - ixA'+          I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2)+          I.copy valsDst ixDst' valsA ixA' remaining+          return (ixDst' + remaining)+    let !loA0 = indexLoKeyA 0+        !loB0 = indexLoKeyB 0+        !hiA0 = indexHiKeyA 0+        !hiB0 = indexHiKeyB 0+        !valA0 = indexValueA 0+        !valB0 = indexValueB 0+    total <- case compare loA0 loB0 of+      LT -> if hiA0 < loB0+        then do+          writeKeyRange 0 loA0 hiA0+          writeDstValue 0 valA0+          if 1 < szA+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 0 loB0 hiB0 valB0 1+            else copyB 0 loB0 hiB0 valB0 1+        else do+          -- here we know that hiA > loA+          let !upperA = pred loB0+          writeKeyRange 0 loA0 upperA+          writeDstValue 0 valA0+          go 0 loB0 hiA0 valA0 0 loB0 hiB0 valB0 1+      EQ -> case compare hiA0 hiB0 of+        LT -> do+          writeKeyRange 0 loA0 hiA0+          writeDstValue 0 (combine valA0 valB0)+          if 1 < szA+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 0 (succ hiA0) hiB0 valB0 1+            else copyB 0 (succ hiA0) hiB0 valB0 1+        GT -> do+          writeKeyRange 0 loB0 hiB0+          writeDstValue 0 (combine valA0 valB0)+          if 1 < szB+            then go 0 (succ hiB0) hiA0 valA0 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1+            else copyA 0 (succ hiB0) hiA0 valA0 1+        EQ -> do+          writeKeyRange 0 loA0 hiA0+          writeDstValue 0 (combine valA0 valB0)+          if 1 < szA+            then if 1 < szB+              then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1+              else copyA 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 1+            else if 1 < szB+              then copyB 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1+              else return 1+      GT -> if hiB0 < loA0+        then do+          writeKeyRange 0 loB0 hiB0+          writeDstValue 0 valB0+          if 1 < szB+            then go 0 loA0 hiA0 valA0 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1+            else copyA 0 loA0 hiA0 valA0 1+        else do+          let !upperB = pred loA0+          writeKeyRange 0 loB0 upperB+          writeDstValue 0 valB0+          go 0 loA0 hiA0 valA0 0 loA0 hiB0 valB0 1+    !keysFinal <- I.resize keysDst (total * 2)+    !valsFinal <- I.resize valsDst total+    liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal)++concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)+  => (v -> v -> v)+  -> [Map karr varr k v]+  -> Map karr varr k v+concatWith combine = C.concatSized size empty (appendWith combine)++size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int+size (Map _ vals) = I.size vals ++toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,k,v)]+toList = foldrWithKey (\lo hi v xs -> (lo,hi,v) : xs) []++foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> k -> v -> b -> b) -> b -> Map karr varr k v -> b+foldrWithKey f z (Map keys vals) =+  let !sz = I.size vals+      go !i+        | i == sz = z+        | otherwise =+            let !lo = I.index keys (i * 2)+                !hi = I.index keys (i * 2 + 1)+                !v = I.index vals i+             in f lo hi v (go (i + 1))+   in go 0++showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS+showsPrec p xs = showParen (p > 10) $+  showString "fromList " . shows (toList xs)++liftShowsPrec2 :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (Int -> k -> ShowS) -> ([k] -> ShowS) -> (Int -> v -> ShowS) -> ([v] -> ShowS) -> Int -> Map karr varr k v -> ShowS+liftShowsPrec2 showsPrecK _ showsPrecV _ p xs = showParen (p > 10) $+  showString "fromList " . showListWith (\(a,b,c) -> show_tuple [showsPrecK 0 a, showsPrecK 0 b, showsPrecV 0 c])  (toList xs)++-- implementation copied from GHC.Show+show_tuple :: [ShowS] -> ShowS+show_tuple ss = id+  . showChar '('+  . foldr1 (\s r -> s . showChar ',' . r) ss+  . showChar ')'++
+ src/Data/Diet/Map/Lifted/Lifted.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Map.Lifted.Lifted+  ( Map+  , singleton+  , lookup+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  ) where++import Prelude hiding (lookup,map)++import Data.Semigroup (Semigroup)+import Data.Functor.Classes (Show2(..))+import Data.Primitive (Array)+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Diet.Map.Internal as I++newtype Map k v = Map (I.Map Array Array k v)++-- | /O(1)/ Create a diet map with a single element.+singleton :: Ord k+  => k -- ^ inclusive lower bound+  -> k -- ^ inclusive upper bound+  -> v -- ^ value+  -> Map k v+singleton lo hi v = Map (I.singleton lo hi v)++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: Ord k => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++instance (Show k, Show v) => Show (Map k v) where+  showsPrec p (Map m) = I.showsPrec p m++instance (Eq k, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (Ord k, Enum k, Eq v) => E.IsList (Map k v) where+  type Item (Map k v) = (k,k,v)+  fromListN n = Map . I.fromListN n+  fromList = Map . I.fromList+  toList (Map s) = I.toList s++fromList :: (Ord k, Enum k, Eq v) => [(k,k,v)] -> Map k v+fromList = Map . I.fromList++fromListN :: (Ord k, Enum k, Eq v)+  => Int -- ^ expected size of resulting 'Map'+  -> [(k,k,v)] -- ^ key-value pairs+  -> Map k v+fromListN n = Map . I.fromListN n++fromListAppend :: (Ord k, Enum k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++fromListAppendN :: (Ord k, Enum k, Semigroup v, Eq v)+  => Int -- ^ expected size of resulting 'Map'+  -> [(k,k,v)] -- ^ key-value pairs+  -> Map k v+fromListAppendN n = Map . I.fromListAppendN n
+ src/Data/Diet/Map/Unboxed/Lifted.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Map.Unboxed.Lifted+  ( Map+  , singleton+  , lookup+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  ) where++import Prelude hiding (lookup,map)++import Data.Semigroup (Semigroup)+import Data.Primitive.Types (Prim)+import Data.Functor.Classes (Show2(..))+import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive.Array (Array)+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Diet.Map.Internal as I++newtype Map k v = Map (I.Map PrimArray Array k v)++-- | /O(1)/ Create a diet map with a single element.+singleton :: (Prim k,Ord k)+  => k -- ^ inclusive lower bound+  -> k -- ^ inclusive upper bound+  -> v -- ^ value+  -> Map k v+singleton lo hi v = Map (I.singleton lo hi v)++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: (Prim k, Ord k) => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++instance (Prim k, Show k, Show v) => Show (Map k v) where+  showsPrec p (Map m) = I.showsPrec p m++instance (Prim k, Eq k, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Prim k, Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Prim k, Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (Prim k, Ord k, Enum k, Eq v) => E.IsList (Map k v) where+  type Item (Map k v) = (k,k,v)+  fromListN n = Map . I.fromListN n+  fromList = Map . I.fromList+  toList (Map s) = I.toList s++fromList :: (Ord k, Enum k, Prim k, Eq v) => [(k,k,v)] -> Map k v+fromList = Map . I.fromList++fromListN :: (Ord k, Enum k, Prim k, Eq v)+  => Int -- ^ expected size of resulting 'Map'+  -> [(k,k,v)] -- ^ key-value pairs+  -> Map k v+fromListN n = Map . I.fromListN n++fromListAppend :: (Ord k, Enum k, Prim k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++fromListAppendN :: (Ord k, Enum k, Prim k, Semigroup v, Eq v)+  => Int -- ^ expected size of resulting 'Map'+  -> [(k,k,v)] -- ^ key-value pairs+  -> Map k v+fromListAppendN n = Map . I.fromListAppendN n
+ src/Data/Diet/Set.hs view
@@ -0,0 +1,27 @@+{-|++The modules in this hierarchy implement sets of nonoverlapping,+nonadjacent intervals. In the literature, one such implementation of+these is known as+<http://web.engr.oregonstate.edu/~erwig/diet/ Discrete Interval Encoding Trees>+(DIETs). This implementation is discussed in+<http://web.engr.oregonstate.edu/~erwig/papers/Diet_JFP98.pdf Diets for Fat Sets>,+Martin Erwig. Journal of Functional Programming, Vol. 8, No. 6, 627-632, 1998.+In this package, we use the term diet set to refer to not just that one+implementation but to any set of nonoverlapping, nonadjacent intervals.++These are not the same as interval sets. An interval set preserves+the original intervals that the user inserted into the set. A diet set+will coalesce adjacent or overlapping ranges. For example:++>>> ⦃[2,6]⦄ ⋄ ⦃[1,3]⦄ ⋄ ⦃[8,11]⦄ ⋄ ⦃[12,12]⦄ +⦃[1,6],[8,12]⦄++The implementation in this packages is optimized for reads. Building+a diet set is expensive since the array-backed implementation cannot+do any sharing when it creates a new data structure. However, testing+for membership is @O(log n)@. ++-}++module Data.Diet.Set () where
+ src/Data/Diet/Set/Internal.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Diet.Set.Internal+  ( Set+  , empty+  , singleton+  , append+  , member+  , concat+  , equals+  , showsPrec+  , difference+  , foldr+  , size+    -- unsafe indexing+  , locate+  , slice+  , indexLower+  , indexUpper+    -- splitting+  , aboveExclusive+  , aboveInclusive+  , belowInclusive+  , belowExclusive+  , betweenInclusive+    -- list conversion+  , fromListN+  , fromList+  , toList+  ) where++import Prelude hiding (lookup,showsPrec,concat,map,foldr)++import Control.Monad.ST (ST,runST)+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)+import qualified Data.Foldable as F+import qualified Prelude as P+import qualified Data.Primitive.Contiguous as I+import qualified Data.Concatenation as C++newtype Set arr a = Set (arr a)++empty :: Contiguous arr => Set arr a+empty = Set I.empty++equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool+equals (Set x) (Set y) = I.equals x y++fromListN :: (Contiguous arr, Element arr a, Ord a, Enum a) => Int -> [(a,a)] -> Set arr a+fromListN _ xs = concat (P.map (uncurry singleton) xs)++fromList :: (Contiguous arr, Element arr a, Ord a, Enum a) => [(a,a)] -> Set arr a+fromList = fromListN 1++concat :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => [Set arr a]+  -> Set arr a+concat = C.concatSized size empty append++singleton :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a -- ^ lower inclusive bound+  -> a -- ^ upper inclusive bound+  -> Set arr a+singleton !lo !hi = if lo <= hi+  then uncheckedSingleton lo hi+  else empty++-- precondition: lo must be less than or equal to hi+uncheckedSingleton :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a -- ^ lower inclusive bound+  -> a -- ^ upper inclusive bound+  -> Set arr a+uncheckedSingleton lo hi = runST $ do+  !(arr :: Mutable arr s a) <- I.new 2+  I.write arr 0 lo+  I.write arr 1 hi+  r <- I.unsafeFreeze arr+  return (Set r)++member :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a+  -> Set arr a+  -> Bool+member a (Set arr) = go 0 ((div (I.size arr) 2) - 1) where+  go :: Int -> Int -> Bool+  go !start !end = if end <= start+    then if end == start+      then +        let !valLo = I.index arr (2 * start)+            !valHi = I.index arr (2 * start + 1)+         in a >= valLo && a <= valHi+      else False+    else+      let !mid = div (end + start + 1) 2+          !valLo = I.index arr (2 * mid)+       in case P.compare a valLo of+            LT -> go start (mid - 1)+            EQ -> True+            GT -> go mid end+{-# INLINEABLE member #-}++-- This may segfault if given something out of bounds+indexLower :: (Contiguous arr, Element arr a)+  => Int+  -> Set arr a+  -> a +indexLower ix (Set arr) = I.index arr (ix * 2)++-- This may segfault if given something out of bounds+indexUpper :: (Contiguous arr, Element arr a)+  => Int+  -> Set arr a+  -> a +indexUpper ix (Set arr) = I.index arr (ix * 2 + 1)++-- This may segfault if given bad indices. You are allow to give+-- a high index that is one less than the low index though.+slice :: (Contiguous arr, Element arr a)+  => Int -- inclusive low index+  -> Int -- inclusive high index+  -> Set arr a+  -> Set arr a+slice loIx hiIx (Set arr) = Set (I.clone arr (loIx * 2) ((hiIx - loIx + 1) * 2))++-- This is exported for use in Unbounded Diet Sets, but it should+-- be considered an internal function since it provided an index+-- into the set.+-- Right means that the needle was found. The index provided is the+-- index of the range that contains it [0,n). Left means that the needle+-- was not contained by any of the ranges. The index provided is+-- the index of the range to its right [0,n]+locate :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a+  -> Set arr a+  -> Either Int Int+locate a (Set arr) = go 0 ((div (I.size arr) 2) - 1) where+  go :: Int -> Int -> Either Int Int+  go !start !end = if end <= start+    then if end == start+      then +        let !valLo = I.index arr (2 * start)+            !valHi = I.index arr (2 * start + 1)+         in if (a >= valLo)+              then if a <= valHi+                then Right start+                else Left (start + 1)+              else Left start +      else Left 0+    else+      let !mid = div (end + start + 1) 2+          !valLo = I.index arr (2 * mid)+       in case P.compare a valLo of+            LT -> go start (mid - 1)+            EQ -> Right mid+            GT -> go mid end++betweenInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a -- ^ inclusive lower bound+  -> a -- ^ inclusive upper bound+  -> Set arr a+  -> Set arr a+betweenInclusive lo hi (Set arr)+  | hi < lo = empty+  | I.size arr > 0 && I.index arr 0 >= lo && I.index arr (I.size arr - 1) <= hi = Set arr+  | otherwise = case locate lo (Set arr) of+      Left ixLo -> case locate hi (Set arr) of+        Left ixHi -> Set (I.clone arr (ixLo * 2) ((ixHi - ixLo) * 2))+        Right ixHi -> runST $ do+          let len = ixHi - ixLo + 1+          res <- I.new (len * 2)+          rightLo <- I.indexM arr (ixHi * 2)+          I.copy res 0 arr (ixLo * 2) (len * 2 - 2)+          I.write res (len * 2 - 2) rightLo+          I.write res (len * 2 - 1) hi+          r <- I.unsafeFreeze res+          return (Set r)+      Right ixLo -> case locate hi (Set arr) of+        Left ixHi -> runST $ do+          let len = ixHi - ixLo+          (res :: Mutable arr s a) <- I.new (len * 2)+          leftHi <- I.indexM arr (ixLo * 2 + 1)+          I.write res 0 lo+          I.write res 1 leftHi+          I.copy res 2 arr (ixLo * 2 + 2) (len * 2 - 2)+          r <- I.unsafeFreeze res+          return (Set r)+        Right ixHi -> if ixLo == ixHi+          then uncheckedSingleton lo hi+          else runST $ do+            let len = ixHi - ixLo + 1+            (res :: Mutable arr s a) <- I.new (len * 2)+            leftHi <- I.indexM arr (ixLo * 2 + 1)+            I.write res 0 lo+            I.write res 1 leftHi+            I.copy res 2 arr (ixLo * 2 + 2) (len * 2 - 4)+            rightLo <- I.indexM arr (ixHi * 2)+            I.write res (len * 2 - 2) rightLo+            I.write res (len * 2 - 1) hi+            r <- I.unsafeFreeze res+            return (Set r)+           ++aboveInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a -- ^ inclusive lower bound+  -> Set arr a+  -> Set arr a+aboveInclusive x (Set arr) = case locate x (Set arr) of+  Left ix -> if ix == 0+    then Set arr+    else Set (I.clone arr (ix * 2) (I.size arr - ix * 2))+  Right ix ->+    let lo = I.index arr (ix * 2)+        hi = I.index arr (ix * 2 + 1)+     in if lo == x+          then if ix == 0+            then Set arr+            else Set (I.clone arr (ix * 2) (I.size arr - ix * 2))+          else runST $ do+            (result :: Mutable arr s a) <- I.new (I.size arr - ix * 2)+            I.write result 0 x+            I.write result 1 hi+            I.copy result 2 arr ((ix + 1) * 2) (I.size arr - ix * 2 - 2)+            r <- I.unsafeFreeze result+            return (Set r)++aboveExclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- ^ exclusive lower bound+  -> Set arr a+  -> Set arr a+aboveExclusive x (Set arr) = case locate x (Set arr) of+  Left ix -> if ix == 0+    then Set arr+    else Set (I.clone arr (ix * 2) (I.size arr - ix * 2))+  Right ix ->+    let hi = I.index arr (ix * 2 + 1)+     in if hi == x+          then Set (I.clone arr ((ix + 1) * 2) (I.size arr - (ix + 1) * 2))+          else runST $ do+            (result :: Mutable arr s a) <- I.new (I.size arr - ix * 2)+            I.write result 0 (succ x)+            I.write result 1 hi+            I.copy result 2 arr ((ix + 1) * 2) (I.size arr - ix * 2 - 2)+            r <- I.unsafeFreeze result+            return (Set r)+++belowInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a -- ^ inclusive upper bound+  -> Set arr a+  -> Set arr a+belowInclusive x (Set arr) = case locate x (Set arr) of+  Left ix -> if ix * 2 == I.size arr+    then Set arr+    else Set (I.clone arr 0 (ix * 2))+  Right ix ->+    let lo = I.index arr (ix * 2)+        hi = I.index arr (ix * 2 + 1)+     in if hi == x+          then if ix * 2 == I.size arr - 2+            then Set arr+            else Set (I.clone arr 0 ((ix + 1) * 2))+          else runST $ do+            result <- I.new ((ix + 1) * 2)+            I.copy result 0 arr 0 (ix * 2)+            I.write result (ix * 2) lo+            I.write result (ix * 2 + 1) x+            r <- I.unsafeFreeze result+            return (Set r)++belowExclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- ^ exclusive upper bound+  -> Set arr a+  -> Set arr a+belowExclusive x (Set arr) = case locate x (Set arr) of+  Left ix -> if ix * 2 == I.size arr+    then Set arr+    else Set (I.clone arr 0 (ix * 2))+  Right ix ->+    let lo = I.index arr (ix * 2)+     in if lo == x+          then Set (I.clone arr 0 (ix * 2))+          else runST $ do+            result <- I.new ((ix + 1) * 2)+            I.copy result 0 arr 0 (ix * 2)+            I.write result (ix * 2) lo+            I.write result (ix * 2 + 1) (pred x)+            r <- I.unsafeFreeze result+            return (Set r)++append :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => Set arr a+  -> Set arr a+  -> Set arr a+append (Set keysA) (Set keysB)+  | szA < 1 = Set keysB+  | szB < 1 = Set keysA+  | otherwise = runST action+  where+  !szA = div (I.size keysA) 2+  !szB = div (I.size keysB) 2+  action :: forall s. ST s (Set arr a)+  action = do+    !(keysDst :: Mutable arr s a) <- I.new (max szA szB * 8)+    let writeKeyRange :: Int -> a -> a -> ST s ()+        writeKeyRange !ix !lo !hi = do+          I.write keysDst (2 * ix) lo+          I.write keysDst (2 * ix + 1) hi+        writeDstHiKey :: Int -> a -> ST s ()+        writeDstHiKey !ix !hi = I.write keysDst (2 * ix + 1) hi+        readDstHiKey :: Int -> ST s a+        readDstHiKey !ix = I.read keysDst (2 * ix + 1)+        indexLoKeyA :: Int -> a+        indexLoKeyA !ix = I.index keysA (ix * 2)+        indexLoKeyB :: Int -> a+        indexLoKeyB !ix = I.index keysB (ix * 2)+        indexHiKeyA :: Int -> a+        indexHiKeyA !ix = I.index keysA (ix * 2 + 1)+        indexHiKeyB :: Int -> a+        indexHiKeyB !ix = I.index keysB (ix * 2 + 1)+    -- In the go functon, ixDst is always at least one. Similarly,+    -- all key arguments are always greater than minBound.+    let go :: Int -> a -> a -> Int -> a -> a -> Int -> ST s Int+        go !ixA !loA !hiA !ixB !loB !hiB !ixDst = do+          prevHi <- readDstHiKey (ixDst - 1) +          case compare loA loB of+            LT -> do+              let (upper,ixA') = if hiA < loB+                    then (hiA,ixA + 1)+                    else (pred loB,ixA)+              ixDst' <- if pred loA == prevHi+                then do+                  writeDstHiKey (ixDst - 1) upper+                  return ixDst+                else do+                  writeKeyRange ixDst loA upper+                  return (ixDst + 1)+              if ixA' < szA+                then do+                  let (loA',hiA') = if hiA < loB+                        then (indexLoKeyA ixA',indexHiKeyA ixA')+                        else (loB,hiA)+                  go ixA' loA' hiA' ixB loB hiB ixDst'+                else copyB ixB loB hiB ixDst'+            GT -> do+              let (upper,ixB') = if hiB < loA+                    then (hiB,ixB + 1)+                    else (pred loA,ixB)+              ixDst' <- if pred loB == prevHi+                then do+                  writeDstHiKey (ixDst - 1) upper+                  return ixDst+                else do+                  writeKeyRange ixDst loB upper+                  return (ixDst + 1)+              if ixB' < szB+                then do+                  let (loB',hiB') = if hiB < loA+                        then (indexLoKeyB ixB',indexHiKeyB ixB')+                        else (loA,hiB)+                  go ixA loA hiA ixB' loB' hiB' ixDst'+                else copyA ixA loA hiA ixDst'+            EQ -> do+              case compare hiA hiB of+                LT -> do+                  ixDst' <- if pred loA == prevHi+                    then do+                      writeDstHiKey (ixDst - 1) hiA+                      return ixDst+                    else do+                      writeKeyRange ixDst loA hiA+                      return (ixDst + 1)+                  let ixA' = ixA + 1+                      loB' = succ hiA+                  if ixA' < szA+                    then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixB loB' hiB ixDst'+                    else copyB ixB loB' hiB ixDst'+                GT -> do+                  ixDst' <- if pred loB == prevHi+                    then do+                      writeDstHiKey (ixDst - 1) hiB+                      return ixDst+                    else do+                      writeKeyRange ixDst loB hiB+                      return (ixDst + 1)+                  let ixB' = ixB + 1+                      loA' = succ hiB+                  if ixB' < szB+                    then go ixA loA' hiA ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst'+                    else copyA ixA loA' hiA ixDst'+                EQ -> do+                  ixDst' <- if pred loB == prevHi+                    then do+                      writeDstHiKey (ixDst - 1) hiB+                      return ixDst+                    else do+                      writeKeyRange ixDst loB hiB+                      return (ixDst + 1)+                  let ixA' = ixA + 1+                      ixB' = ixB + 1+                  if ixA' < szA+                    then if ixB' < szB+                      then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst'+                      else copyA ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixDst'+                    else if ixB' < szB+                      then copyB ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst'+                      else return ixDst'+        copyB :: Int -> a -> a -> Int -> ST s Int+        copyB !ixB !loB !hiB !ixDst = do+          prevHi <- readDstHiKey (ixDst - 1) +          ixDst' <- if pred loB == prevHi+            then do+              writeDstHiKey (ixDst - 1) hiB+              return ixDst+            else do+              writeKeyRange ixDst loB hiB+              return (ixDst + 1)+          let ixB' = ixB + 1+              remaining = szB - ixB'+          I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2)+          return (ixDst' + remaining)+        copyA :: Int -> a -> a -> Int -> ST s Int+        copyA !ixA !loA !hiA !ixDst = do+          prevHi <- readDstHiKey (ixDst - 1) +          ixDst' <- if pred loA == prevHi+            then do+              writeDstHiKey (ixDst - 1) hiA+              return ixDst+            else do+              writeKeyRange ixDst loA hiA+              return (ixDst + 1)+          let ixA' = ixA + 1+              remaining = szA - ixA'+          I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2)+          return (ixDst' + remaining)+    let !loA0 = indexLoKeyA 0+        !loB0 = indexLoKeyB 0+        !hiA0 = indexHiKeyA 0+        !hiB0 = indexHiKeyB 0+    total <- case compare loA0 loB0 of+      LT -> if hiA0 < loB0+        then do+          writeKeyRange 0 loA0 hiA0+          if 1 < szA+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 0 loB0 hiB0 1+            else copyB 0 loB0 hiB0 1+        else do+          -- here we know that hiA > loA+          let !upperA = pred loB0+          writeKeyRange 0 loA0 upperA+          go 0 loB0 hiA0 0 loB0 hiB0 1+      EQ -> case compare hiA0 hiB0 of+        LT -> do+          writeKeyRange 0 loA0 hiA0+          if 1 < szA+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 0 (succ hiA0) hiB0 1+            else copyB 0 (succ hiA0) hiB0 1+        GT -> do+          writeKeyRange 0 loB0 hiB0+          if 1 < szB+            then go 0 (succ hiB0) hiA0 1 (indexLoKeyB 1) (indexHiKeyB 1) 1+            else copyA 0 (succ hiB0) hiA0 1+        EQ -> do+          writeKeyRange 0 loA0 hiA0+          if 1 < szA+            then if 1 < szB+              then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 1 (indexLoKeyB 1) (indexHiKeyB 1) 1+              else copyA 1 (indexLoKeyA 1) (indexHiKeyA 1) 1+            else if 1 < szB+              then copyB 1 (indexLoKeyB 1) (indexHiKeyB 1) 1+              else return 1+      GT -> if hiB0 < loA0+        then do+          writeKeyRange 0 loB0 hiB0+          if 1 < szB+            then go 0 loA0 hiA0 1 (indexLoKeyB 1) (indexHiKeyB 1) 1+            else copyA 0 loA0 hiA0 1+        else do+          let !upperB = pred loA0+          writeKeyRange 0 loB0 upperB+          go 0 loA0 hiA0 0 loA0 hiB0 1+    !keysFinal <- I.resize keysDst (total * 2)+    fmap Set (I.unsafeFreeze keysFinal)++difference :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a)+  => Set arr a+  -> Set arr a+  -> Set arr a+difference setA@(Set arrA) setB@(Set arrB)+  | szA == 0 = empty+  | szB == 0 = setA+  | otherwise =+      let inners :: Int -> [Set arr a]+          inners !ix = if ix < szB - 1+            then+              let inner = betweenInclusive+                    (succ (I.index arrB (2 * ix + 1)))+                    (pred (I.index arrB (2 * ix + 2)))+                    (Set arrA)+               in inner : inners (ix + 1) +            else []+          lowestA = I.index arrA 0+          highestA = I.index arrA (szA * 2 - 1)+          lowestB = I.index arrB 0+          highestB = I.index arrB (szB * 2 - 1)+          -- TODO: if we ever add exclusive variants of below+          -- and above, we should switch to using them here.+          lowFragment = if lowestA < lowestB+            then [belowInclusive (pred lowestB) (Set arrA)]+            else []+          highFragment = if highestA > highestB+            then [aboveInclusive (succ highestB) (Set arrA)]+            else []+          -- we should use a more efficient concat since+          -- we know everything is ordered.+       in concat (lowFragment ++ inners 0 ++ highFragment)+  where+    !szA = size setA+    !szB = size setB++size :: (Contiguous arr, Element arr a) => Set arr a -> Int+size (Set arr) = quot (I.size arr) 2++toList :: (Contiguous arr, Element arr a) => Set arr a -> [(a,a)]+toList = foldr (\lo hi xs -> (lo,hi) : xs) []++foldr :: (Contiguous arr, Element arr a) => (a -> a -> b -> b) -> b -> Set arr a -> b+foldr f z (Set arr) =+  let !sz = div (I.size arr) 2+      go !i+        | i == sz = z+        | otherwise =+            let !lo = I.index arr (i * 2)+                !hi = I.index arr (i * 2 + 1)+             in f lo hi (go (i + 1))+   in go 0+{-# INLINABLE foldr #-}++showsPrec :: (Contiguous arr, Element arr a, Show a)+  => Int+  -> Set arr a+  -> ShowS+showsPrec p xs = showParen (p > 10) $+  showString "fromList " . shows (toList xs)+
+ src/Data/Diet/Set/Lifted.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Set.Lifted+  ( Set+  , singleton+  , member+  , difference+    -- * Split+  , aboveInclusive+  , belowInclusive+  , betweenInclusive+    -- * Folds+  , foldr+    -- * List Conversion+  , fromList+  , fromListN+  ) where++import Prelude hiding (lookup,map,foldr)++import Data.Semigroup (Semigroup)+import Data.Primitive (Array)+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Diet.Set.Internal as I++newtype Set a = Set (I.Set Array a)++-- | /O(1)/ Create a diet set with a single element.+singleton :: Ord a+  => a -- ^ inclusive lower bound+  -> a -- ^ inclusive upper bound+  -> Set a+singleton lo hi = Set (I.singleton lo hi)++-- | /O(log n)/ Returns @True@ if the element is a member of the diet set.+member :: Ord a => a -> Set a -> Bool+member a (Set s) = I.member a s++instance Show a => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++instance Eq a => Eq (Set a) where+  Set x == Set y = I.equals x y++instance Ord a => Ord (Set a) where+  compare (Set xs) (Set ys) = compare (I.toList xs) (I.toList ys)++instance (Ord a, Enum a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)++instance (Ord a, Enum a) => Monoid (Set a) where+  mempty = Set I.empty+  mappend = (SG.<>)+  mconcat = Set . I.concat . E.coerce++instance (Ord a, Enum a) => E.IsList (Set a) where+  type Item (Set a) = (a,a)+  fromListN n = Set . I.fromListN n+  fromList = Set . I.fromList+  toList (Set s) = I.toList s++fromList :: (Ord a, Enum a) => [(a,a)] -> Set a+fromList = Set . I.fromList++fromListN :: (Ord a, Enum a)+  => Int -- ^ expected size of resulting diet 'Set'+  -> [(a,a)] -- ^ key-value pairs+  -> Set a+fromListN n = Set . I.fromListN n++-- | /O(n + m*log n)/ Subtract the subtrahend of size @m@ from the+-- minuend of size @n@. It should be possible to improve the improve+-- the performance of this to /O(n + m)/. Anyone interested in doing+-- this should open a PR.+difference :: (Ord a, Enum a)+  => Set a -- ^ minuend+  -> Set a -- ^ subtrahend+  -> Set a+difference (Set x) (Set y) = Set (I.difference x y)++foldr :: (a -> a -> b -> b) -> b -> Set a -> b+foldr f z (Set arr) = I.foldr f z arr++-- | /O(n)/ The subset where all elements are greater than+-- or equal to the given value. +aboveInclusive :: (Ord a)+  => a -- ^ inclusive lower bound+  -> Set a+  -> Set a+aboveInclusive x (Set s) = Set (I.aboveInclusive x s)++-- | /O(n)/ The subset where all elements are less than+-- or equal to the given value. +belowInclusive :: (Ord a)+  => a -- ^ inclusive upper bound+  -> Set a+  -> Set a+belowInclusive x (Set s) = Set (I.belowInclusive x s)++-- | /O(n)/ The subset where all elements are greater than+-- or equal to the lower bound and less than or equal to+-- the upper bound.+betweenInclusive :: (Ord a)+  => a -- ^ inclusive lower bound+  -> a -- ^ inclusive upper bound+  -> Set a+  -> Set a+betweenInclusive x y (Set s) = Set (I.betweenInclusive x y s)+
+ src/Data/Diet/Set/Unboxed.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Set.Unboxed+  ( Set+  , singleton+  , member+  , difference+    -- * Split+  , aboveInclusive+  , belowInclusive+  , betweenInclusive+    -- * Folds+  , foldr+    -- * List Conversion+  , toList+  , fromList+  , fromListN+  ) where++import Prelude hiding (lookup,map,foldr)++import Data.Semigroup (Semigroup)+import Data.Functor.Classes (Show2(..))+import Data.Primitive.Types (Prim)+import Data.Primitive.PrimArray (PrimArray)+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Diet.Set.Internal as I++newtype Set a = Set (I.Set PrimArray a)++-- | /O(1)/ Create a diet set with a single element.+singleton :: (Ord a, Prim a)+  => a -- ^ inclusive lower bound+  -> a -- ^ inclusive upper bound+  -> Set a+singleton lo hi = Set (I.singleton lo hi)++-- | /O(log n)/ Lookup the value at a key in the map.+member :: (Ord a, Prim a) => a -> Set a -> Bool+member a (Set s) = I.member a s++instance (Show a, Prim a) => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++instance (Eq a, Prim a) => Eq (Set a) where+  Set x == Set y = I.equals x y++instance (Ord a, Prim a) => Ord (Set a) where+  compare (Set xs) (Set ys) = compare (I.toList xs) (I.toList ys)++instance (Ord a, Enum a, Prim a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)++instance (Ord a, Enum a, Prim a) => Monoid (Set a) where+  mempty = Set I.empty+  mappend = (SG.<>)+  mconcat = Set . I.concat . E.coerce++instance (Ord a, Enum a, Prim a) => E.IsList (Set a) where+  type Item (Set a) = (a,a)+  fromListN n = Set . I.fromListN n+  fromList = Set . I.fromList+  toList (Set s) = I.toList s++toList :: Prim a => Set a -> [(a,a)]+toList (Set x) = I.toList x++fromList :: (Ord a, Enum a, Prim a) => [(a,a)] -> Set a+fromList = Set . I.fromList++fromListN :: (Ord a, Enum a, Prim a)+  => Int -- ^ expected size of resulting diet 'Set'+  -> [(a,a)] -- ^ key-value pairs+  -> Set a+fromListN n = Set . I.fromListN n++-- | /O(n + m*log n)/ Subtract the subtrahend of size @m@ from the+-- minuend of size @n@. It should be possible to improve the improve+-- the performance of this to /O(n + m)/. Anyone interested in doing+-- this should open a PR.+difference :: (Ord a, Enum a, Prim a)+  => Set a -- ^ minuend+  -> Set a -- ^ subtrahend+  -> Set a+difference (Set x) (Set y) = Set (I.difference x y)++foldr :: Prim a => (a -> a -> b -> b) -> b -> Set a -> b+foldr f z (Set arr) = I.foldr f z arr++-- | /O(n)/ The subset where all elements are greater than+-- or equal to the given value. +aboveInclusive :: (Ord a, Prim a)+  => a -- ^ inclusive lower bound+  -> Set a+  -> Set a+aboveInclusive x (Set s) = Set (I.aboveInclusive x s)++-- | /O(n)/ The subset where all elements are less than+-- or equal to the given value. +belowInclusive :: (Ord a, Prim a)+  => a -- ^ inclusive upper bound+  -> Set a+  -> Set a+belowInclusive x (Set s) = Set (I.belowInclusive x s)++-- | /O(n)/ The subset where all elements are greater than+-- or equal to the lower bound and less than or equal to+-- the upper bound.+betweenInclusive :: (Ord a, Prim a)+  => a -- ^ inclusive lower bound+  -> a -- ^ inclusive upper bound+  -> Set a+  -> Set a+betweenInclusive x y (Set s) = Set (I.betweenInclusive x y s)+
+ src/Data/Diet/Unbounded/Set/Internal.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++module Data.Diet.Unbounded.Set.Internal+  ( Set+  , empty+  , singleton+  , append+  , member+  , equals+  , showsPrec+  ) where++import Prelude hiding (showsPrec)++import Data.Primitive.Contiguous (Contiguous,Element,Mutable)++import qualified Data.Diet.Set.Internal as S+import qualified Data.Primitive.Contiguous as I++-- todo: switch to using an unboxed sum instead of+-- Maybe once GHC 8.4.3 becomes prevalent.+--+-- If the first Maybe is Just, then everything from negative+-- infinity (whatever that may mean for the type at hand) up+-- to the value is included in the set. It works similarly+-- for the second Maybe and positive infinity. Internally,+-- we must uphold the invariant that the range up from negative+-- infinity and the one up to positive infinity do not overlap+-- with the diet set in the middle and that they are not+-- adjacent to it (according to the Enum instance).+--+-- The second data constructor, SetAll, means that all values+-- of type @a@ are included in the Set. We do actually need+-- a separate data constructor for this since there is no+-- way to communicate it with the first one.+data Set arr a+  = SetSome !(Maybe a) !(S.Set arr a) !(Maybe a)+  | SetAll++empty :: Contiguous arr => Set arr a+empty = SetSome Nothing S.empty Nothing++equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool+equals SetAll SetAll = True+equals SetAll (SetSome _ _ _) = False+equals (SetSome _ _ _) SetAll = False+equals (SetSome a b c) (SetSome x y z) = a == x && c == z && S.equals b y++singleton :: (Contiguous arr, Element arr a, Ord a)+  => Maybe a -- ^ lower inclusive bound, @Nothing@ means @-∞@+  -> Maybe a -- ^ upper inclusive bound, @Nothing@ means @+∞@+  -> Set arr a+singleton Nothing Nothing = SetAll+singleton Nothing (Just hi) = SetSome (Just hi) S.empty Nothing+singleton (Just lo) Nothing = SetSome Nothing S.empty (Just lo)+singleton (Just lo) (Just hi) = SetSome Nothing (S.singleton lo hi) Nothing++append :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => Set arr a+  -> Set arr a+  -> Set arr a+append SetAll _ = SetAll+append (SetSome _ _ _) SetAll = SetAll+append (SetSome Nothing a Nothing) (SetSome Nothing b Nothing) =+  SetSome Nothing (S.append a b) Nothing+append (SetSome (Just infHiA) a Nothing) (SetSome Nothing b Nothing) =+  let (infHi, trimmedB) = establishInfinityHi infHiA b+   in SetSome (Just infHi) (S.append a trimmedB) Nothing+append (SetSome Nothing a Nothing) (SetSome (Just infHiB) b Nothing) =+  let (infHi, trimmedA) = establishInfinityHi infHiB a+   in SetSome (Just infHi) (S.append trimmedA b) Nothing+append (SetSome (Just infHiA) a Nothing) (SetSome (Just infHiB) b Nothing) =+  case compare infHiA infHiB of+    EQ -> SetSome (Just infHiA) (S.append a b) Nothing+    LT -> +      let (infHi, trimmedA) = establishInfinityHi infHiB a+       in SetSome (Just infHi) (S.append trimmedA b) Nothing+    GT -> +      let (infHi, trimmedB) = establishInfinityHi infHiA b+       in SetSome (Just infHi) (S.append a trimmedB) Nothing+append (SetSome Nothing a (Just infLoA)) (SetSome Nothing b Nothing) =+  let (infLo, trimmedB) = establishInfinityLo infLoA b+   in SetSome Nothing (S.append a trimmedB) (Just infLo)+append (SetSome Nothing a Nothing) (SetSome Nothing b (Just infLoB)) =+  let (infLo, trimmedA) = establishInfinityLo infLoB a+   in SetSome Nothing (S.append trimmedA b) (Just infLo)+append (SetSome Nothing a (Just infLoA)) (SetSome Nothing b (Just infLoB)) =+  case compare infLoA infLoB of+    EQ -> SetSome Nothing (S.append a b) (Just infLoB)+    LT -> +      let (infLo, trimmedB) = establishInfinityLo infLoA b+       in SetSome Nothing (S.append a trimmedB) (Just infLo)+    GT -> +      let (infLo, trimmedA) = establishInfinityLo infLoB a+       in SetSome Nothing (S.append trimmedA b) (Just infLo)+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome Nothing b Nothing) =+  case establishInfinityBoth infHiA infLoA b of+    Nothing -> SetAll+    Just (infHi,infLo,trimmedB) -> SetSome (Just infHi) (S.append a trimmedB) (Just infLo)+append (SetSome Nothing a Nothing) (SetSome (Just infHiB) b (Just infLoB)) =+  case establishInfinityBoth infHiB infLoB a of+    Nothing -> SetAll+    Just (infHi,infLo,trimmedA) -> SetSome (Just infHi) (S.append trimmedA b) (Just infLo)+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome (Just infHiB) b (Just infLoB)) =+  generalAppend (max infHiA infHiB) (min infLoA infLoB) a b+append (SetSome Nothing a (Just infLoA)) (SetSome (Just infHiB) b (Just infLoB)) =+  generalAppend infHiB (min infLoA infLoB) a b+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome Nothing b (Just infLoB)) =+  generalAppend infHiA (min infLoA infLoB) a b+append (SetSome (Just infHiA) a Nothing) (SetSome (Just infHiB) b (Just infLoB)) =+  generalAppend (max infHiA infHiB) infLoB a b+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome (Just infHiB) b Nothing) =+  generalAppend (max infHiA infHiB) infLoA a b+append (SetSome Nothing a (Just infLoA)) (SetSome (Just infHiB) b Nothing) =+  generalAppend infHiB infLoA a b+append (SetSome (Just infHiA) a Nothing) (SetSome Nothing b (Just infLoB)) =+  generalAppend infHiA infLoB a b++generalAppend :: (Contiguous arr, Ord a, Enum a, Element arr a)+  => a -> a -> S.Set arr a -> S.Set arr a -> Set arr a+generalAppend infHiX infLoX a b =+  case establishInfinityBoth infHiX infLoX (S.append a b) of+    Nothing -> SetAll+    Just (infHi,infLo,trimmed) -> SetSome (Just infHi) trimmed (Just infLo)++-- This takes an value @a@ which is the upper bound of (-∞,a] range.+-- It also takes a diet set. It removes everything from the set+-- that is contained by the up-from-negative-infinity range, and+-- it also removes a range adjacent to @a@. If a range adjacent to+-- @a@ was removed, then the returned value will be the upper bound+-- of the removed adjacent range.+establishInfinityHi :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- upper bound from negative infinity+  -> S.Set arr a -- diet set+  -> (a, S.Set arr a) -- new upper bound, trimmed diet set+establishInfinityHi a s = case locateAdjacentAbove a s of+  Right ix ->+    let upper = S.indexUpper ix s+     in (upper,S.slice (ix + 1) (S.size s - 1) s)+  Left ix -> (a,S.slice ix (S.size s - 1) s)++establishInfinityLo :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- lower bound from positive infinity+  -> S.Set arr a -- diet set+  -> (a, S.Set arr a) -- new lower bound, trimmed diet set+establishInfinityLo a s = case locateAdjacentBelow a s of+  Right ix ->+    let lower = S.indexLower ix s+     in (lower,S.slice 0 (ix - 1) s)+  Left ix -> (a, S.slice 0 ix s)++-- this is a tweaked version of locate. If the element+-- isn't found in the diet set, it looks at its predecessor+-- to see if it is present so that we can collapse a maximal+-- number of ranges. Left gives the index of the range to+-- the left of (meaning: less than) the element.+--+-- Right: [0,n-1]+-- Left: [-1,n-1]+locateAdjacentBelow :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- lower bound from positive infinity+  -> S.Set arr a -- diet set+  -> Either Int Int+locateAdjacentBelow a s = case S.locate a s of+  Right ix -> Right ix+  Left ix -> if ix == 0+    then Left (-1)+    else if S.indexUpper (ix - 1) s == pred a+      then Right (ix - 1)+      else Left (ix - 1)++-- this is a tweaked version of locate. If the element+-- isn't found in the diet set, it looks at its successor+-- to see if it is present so that we can collapse a maximal+-- number of ranges. Left gives the index of the range to+-- the right of (meaning: greater than) the element.+--+-- Right: [0,n-1]+-- Left: [0,n]+locateAdjacentAbove :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- upper bound from negative infinity+  -> S.Set arr a -- diet set+  -> Either Int Int+locateAdjacentAbove a s = case S.locate a s of+  Right ix -> Right ix+  Left ix -> if ix == S.size s+    then Left ix+    else if S.indexLower ix s == succ a+      then Right ix+      else Left ix++establishInfinityBoth :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)+  => a -- upper bound from negative infinity+  -> a -- lower bound from positive infinity+  -> S.Set arr a -- diet set+  -> Maybe (a, a, S.Set arr a) -- new upper bound, new lower bound, trimmed diet set+establishInfinityBoth negInfHi posInfLo s = if posInfLo <= negInfHi+  then Nothing+  else case locateAdjacentAbove negInfHi s of+    Left loIx -> case locateAdjacentBelow posInfLo s of+      Left hiIx -> Just (negInfHi,posInfLo,S.slice loIx hiIx s)+      Right hiIx -> Just (negInfHi,S.indexLower hiIx s,S.slice loIx (hiIx - 1) s)+    Right loIx -> case locateAdjacentBelow posInfLo s of+      Left hiIx -> Just (S.indexUpper loIx s,posInfLo,S.slice (loIx + 1) hiIx s)+      Right hiIx -> if hiIx <= loIx+        then Nothing+        else Just (S.indexUpper loIx s, S.indexLower hiIx s, S.slice (loIx + 1) (hiIx - 1) s)+  +member :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a+  -> Set arr a+  -> Bool+member _ SetAll = True+member x (SetSome negInfHi s posInfLo) =+     maybe False (\hi -> hi >= x) negInfHi+  || maybe False (\lo -> lo <= x) posInfLo+  || S.member x s+{-# INLINEABLE member #-}++showsPrec :: (Contiguous arr, Element arr a, Show a)+  => Int+  -> Set arr a+  -> ShowS+showsPrec _ SetAll = showString "[(-∞,+∞)]"+showsPrec p (SetSome negInfHi s posInfLo) = showParen (p > 10) $+  showString "fromList " . showListInf shows negInfHi (S.toList s) posInfLo++showListInf :: (a -> ShowS) -> Maybe a -> [(a,a)] -> Maybe a -> ShowS+showListInf showx mnegInfHi [] mposInfLo s = case mnegInfHi of+  Nothing -> case mposInfLo of+    Nothing -> "[]" ++ s+    Just posInfLo -> '[' : showPosInfLo showx posInfLo (']' : s)+  Just negInfHi -> case mposInfLo of+    Nothing -> '[' : showNegInfHi showx negInfHi (']' : s)+    Just posInfLo -> '[' : showNegInfHi showx negInfHi (',' : showPosInfLo showx posInfLo (']' : s))+showListInf showx mnegInfHi ((a0,b0):xs) mposInfLo s =+  '[' : maybe id (\negInfHi s' -> showNegInfHi showx negInfHi (',' : s')) mnegInfHi ('(' : showx a0 (',' : showx b0 (')' : showl xs)))+  where+    showl [] = maybe id (\posInfLo -> showChar ',' . showPosInfLo showx posInfLo) mposInfLo (']' : s)+    showl ((a,b):ys) = ',' : '(' : showx a (',' : showx b (')' : showl ys))++showNegInfHi :: (a -> ShowS) -> a -> ShowS+showNegInfHi showx x s = "(-∞," ++ showx x (")" ++ s)++showPosInfLo :: (a -> ShowS) -> a -> ShowS+showPosInfLo showx x s = '(' : (showx x (",+∞)" ++ s))+
+ src/Data/Diet/Unbounded/Set/Lifted.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Unbounded.Set.Lifted+  ( Set+  , singleton+  , member+  ) where++import Data.Semigroup (Semigroup)+import Data.Primitive (Array)+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Diet.Unbounded.Set.Internal as I++newtype Set a = Set (I.Set Array a)++instance Eq a => Eq (Set a) where+  Set x == Set y = I.equals x y++instance (Ord a, Enum a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)++instance (Ord a, Enum a) => Monoid (Set a) where+  mempty = Set (I.empty)+  mappend = (SG.<>)++instance Show a => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++-- | /O(1)/ Create an unbounded diet set with a single element.+singleton :: Ord a+  => Maybe a -- ^ lower inclusive bound, @Nothing@ means @-∞@+  -> Maybe a -- ^ upper inclusive bound, @Nothing@ means @+∞@+  -> Set a+singleton lo hi = Set (I.singleton lo hi)++-- | /O(log n)/ Returns @True@ if the element is a member of the diet set.+member :: Ord a => a -> Set a -> Bool+member a (Set s) = I.member a s+++
+ src/Data/Map/Internal.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Map.Internal+  ( Map+  , empty+  , singleton+  , map+  , mapMaybe+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * Functions+  , append+  , lookup+  , showsPrec+  , equals+  , compare+  , toList+  , concat+  , size+    -- * List Conversion+  , fromListN+  , fromList+  , fromListAppend+  , fromListAppendN+    -- * Array Conversion+  , unsafeFreezeZip+  ) where++import Prelude hiding (compare,showsPrec,lookup,map,concat)++import Control.Applicative (liftA2)+import Control.Monad.ST (ST,runST)+import Data.Semigroup (Semigroup)+import Data.Foldable (foldl')+import Data.Primitive.Contiguous (Contiguous,Mutable,Element)+import Data.Primitive.Sort (sortUniqueTaggedMutable)+import qualified Data.List as L+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)++empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v+empty = Map I.empty I.empty++singleton :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => k -> v -> Map karr varr k v+singleton k v = Map+  ( runST $ do+      arr <- I.new 1+      I.write arr 0 k+      I.unsafeFreeze arr+  )+  ( runST $ do+      arr <- I.new 1+      I.write arr 0 v+      I.unsafeFreeze arr+  )++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++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 -> Ordering+compare m1 m2 = P.compare (toList m1) (toList m2)++fromListWithN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => (v -> v -> v) -> Int -> [(k,v)] -> Map karr varr k v+fromListWithN combine n xs =+  case xs of+    [] -> empty+    (k,v) : ys ->+      let (leftovers, result) = fromAscListWith combine (max 1 n) k v ys+       in concatWith combine (result : P.map (uncurry singleton) leftovers)++fromListN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => Int -> [(k,v)] -> Map karr varr k v+fromListN = fromListWithN (\_ a -> a)++fromList :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => [(k,v)] -> Map karr varr k v+fromList = fromListN 1++fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => Int -> [(k,v)] -> Map karr varr k v+fromListAppendN = fromListWithN (SG.<>)++fromListAppend :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => [(k,v)] -> Map karr varr k v+fromListAppend = fromListAppendN 1++fromAscListWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)+  => (v -> v -> v)+  -> Int -- initial size of buffer, must be 1 or higher+  -> k -- first key+  -> v -- first value+  -> [(k,v)] -- elements+  -> ([(k,v)], Map karr varr k v)+fromAscListWith combine !n !k0 !v0 xs0 = runST $ do+  keys0 <- I.new n+  vals0 <- I.new n+  I.write keys0 0 k0+  I.write vals0 0 v0+  let go :: forall s. Int -> k -> Int -> Mutable karr s k -> Mutable varr s v -> [(k,v)] -> ST s ([(k,v)], Map karr varr k v)+      go !ix !_ !sz !keys !vals [] = if ix == sz+        then do+          arrKeys <- I.unsafeFreeze keys+          arrVals <- I.unsafeFreeze vals+          return ([],Map arrKeys arrVals)+        else do+          keys' <- I.resize keys ix+          arrKeys <- I.unsafeFreeze keys'+          vals' <- I.resize vals ix+          arrVals <- I.unsafeFreeze vals'+          return ([],Map arrKeys arrVals)+      go !ix !old !sz !keys !vals ((k,v) : xs) = if ix < sz+        then case P.compare k old of+          GT -> do+            I.write keys ix k+            I.write vals ix v+            go (ix + 1) k sz keys vals xs+          EQ -> do+            !oldVal <- I.read vals (ix - 1)+            let !newVal = combine oldVal v+            I.write vals (ix - 1) newVal+            go ix k sz keys vals xs+          LT -> do+            keys' <- I.resize keys ix+            arrKeys <- I.unsafeFreeze keys'+            vals' <- I.resize vals ix+            arrVals <- I.unsafeFreeze vals'+            return ((k,v) : xs,Map arrKeys arrVals)+        else do+          let sz' = sz * 2+          keys' <- I.resize keys sz'+          vals' <- I.resize vals sz'+          go ix old sz' keys' vals' ((k,v) : xs)+  go 1 k0 n keys0 vals0 xs0+++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'.+mapMaybe :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)+  => (v -> Maybe w)+  -> Map karr varr k v+  -> Map karr varr k w+mapMaybe f (Map ks vs) = runST $ do+  let !sz = I.size vs+  !(karr :: Mutable karr s k) <- I.new sz+  !(varr :: Mutable varr s w) <- I.new sz+  let go !ixSrc !ixDst = if ixSrc < sz+        then do+          a <- I.indexM vs ixSrc+          case f a of+            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)++showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS+showsPrec p xs = showParen (p > 10) $+  showString "fromList " . shows (toList xs)++toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,v)]+toList = foldrWithKey (\k v xs -> (k,v) : xs) []++foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> v -> b -> b) -> b -> Map karr varr k v -> b+foldrWithKey f z (Map keys vals) =+  let !sz = I.size vals+      go !i+        | i == sz = z+        | otherwise =+            let !k = I.index keys i+                !v = I.index vals i+             in f k v (go (i + 1))+   in go 0++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.<>)++concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)+  => (v -> v -> v)+  -> [Map karr varr k v]+  -> Map karr varr k v+concatWith combine = C.concatSized size empty (appendWith combine)++appendWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v+appendWith combine (Map ksA vsA) (Map ksB vsB) =+  case unionArrWith combine ksA vsA ksB vsB of+    (k,v) -> Map k v+  +append :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k, Semigroup v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v+append (Map ksA vsA) (Map ksB vsB) =+  case unionArrWith (SG.<>) ksA vsA ksB vsB of+    (k,v) -> Map k v+  +unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)+  => (v -> v -> v)+  -> karr k -- keys a+  -> varr v -- values a+  -> karr k -- keys b+  -> varr v -- values b+  -> (karr k, varr v)+unionArrWith combine keysA valsA keysB valsB+  | I.size valsA < 1 = (keysB,valsB)+  | I.size valsB < 1 = (keysA,valsA)+  | otherwise = runST $ do+      let !szA = I.size valsA+          !szB = I.size valsB+      !(keysDst :: Mutable karr s k) <- I.new (szA + szB)+      !(valsDst :: Mutable varr s v) <- I.new (szA + szB)+      let go !ixA !ixB !ixDst = if ixA < szA+            then if ixB < szB+              then do+                let !keyA = I.index keysA ixA+                    !keyB = I.index keysB ixB+                    !valA = I.index valsA ixA+                    !valB = I.index valsB ixB+                case P.compare keyA keyB of+                  EQ -> do+                    I.write keysDst ixDst keyA+                    let !r = combine valA valB+                    I.write valsDst ixDst r+                    go (ixA + 1) (ixB + 1) (ixDst + 1)+                  LT -> do+                    I.write keysDst ixDst keyA+                    I.write valsDst ixDst valA+                    go (ixA + 1) ixB (ixDst + 1)+                  GT -> do+                    I.write keysDst ixDst keyB+                    I.write valsDst ixDst valB+                    go ixA (ixB + 1) (ixDst + 1)+              else do+                I.copy keysDst ixDst keysA ixA (szA - ixA)+                I.copy valsDst ixDst valsA ixA (szA - ixA)+                return (ixDst + (szA - ixA))+            else if ixB < szB+              then do+                I.copy keysDst ixDst keysB ixB (szB - ixB)+                I.copy valsDst ixDst valsB ixB (szB - ixB)+                return (ixDst + (szB - ixB))+              else return ixDst+      !total <- go 0 0 0+      !keysFinal <- I.resize keysDst total+      !valsFinal <- I.resize valsDst total+      liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal)+ +lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> Maybe v+lookup a (Map arr vals) = go 0 (I.size vals - 1) where+  go :: Int -> Int -> Maybe v+  go !start !end = if end < start+    then Nothing+    else+      let !mid = div (end + start) 2+          !(# v #) = I.index# arr mid+       in case P.compare a v of+            LT -> go start (mid - 1)+            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++-- | 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.+unsafeFreezeZip :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)+  => Mutable karr s k+  -> Mutable varr s v+  -> ST s (Map karr varr k v)+unsafeFreezeZip keys0 vals0 = do+  (keys1,vals1) <- sortUniqueTaggedMutable keys0 vals0+  keys2 <- I.unsafeFreeze keys1+  vals2 <- I.unsafeFreeze vals1+  return (Map keys2 vals2)+{-# INLINEABLE unsafeFreezeZip #-}++foldlWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (b -> k -> v -> m b)+  -> b+  -> Map karr varr k v+  -> m b+foldlWithKeyM' f b0 (Map ks vs) = go 0 b0+  where+  !len = I.size vs+  go :: Int -> b -> m b+  go !ix !acc = if ix < len+    then+      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in f acc k v >>= go (ix + 1)+    else return acc+{-# INLINEABLE foldlWithKeyM' #-}++foldrWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (k -> v -> b -> m b)+  -> b+  -> Map karr varr k v+  -> m b+foldrWithKeyM' f b0 (Map ks vs) = go (I.size vs - 1) b0+  where+  go :: Int -> b -> m b+  go !ix !acc = if ix >= 0+    then+      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in f k v acc >>= go (ix - 1)+    else return acc+{-# INLINEABLE foldrWithKeyM' #-}++foldlMapWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b)+  => (k -> v -> m b)+  -> Map karr varr k v+  -> m b+foldlMapWithKeyM' f (Map ks vs) = go 0 mempty+  where+  !len = I.size vs+  go :: Int -> b -> m b+  go !ix !accl = if ix < len+    then+      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in do+         accr <- f k v+         go (ix + 1) (mappend accl accr)+    else return accl+{-# INLINEABLE foldlMapWithKeyM' #-}++foldrMapWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b)+  => (k -> v -> m b)+  -> Map karr varr k v+  -> m b+foldrMapWithKeyM' f (Map ks vs) = go (I.size vs - 1) mempty+  where+  go :: Int -> b -> m b+  go !ix !accr = if ix >= 0+    then+      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in do+         accl <- f k v+         go (ix + 1) (mappend accl accr)+    else return accr+{-# INLINEABLE foldrMapWithKeyM' #-}++foldMapWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b)+  => (k -> v -> b)+  -> Map karr varr k v+  -> b+foldMapWithKey' f (Map ks vs) = go 0 mempty+  where+  !len = I.size vs+  go :: Int -> b -> b+  go !ix !accl = if ix < len+    then +      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in go (ix + 1) (mappend accl (f k v))+    else accl+{-# INLINEABLE foldMapWithKey' #-}++foldlWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (b -> k -> v -> b) +  -> b+  -> Map karr varr k v+  -> b+foldlWithKey' f b0 (Map ks vs) = go 0 b0+  where+  !len = I.size vs+  go :: Int -> b -> b+  go !ix !acc = if ix < len+    then +      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in go (ix + 1) (f acc k v)+    else acc+{-# INLINEABLE foldlWithKey' #-}++foldrWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (k -> v -> b -> b)+  -> b+  -> Map karr varr k v+  -> b+foldrWithKey' f b0 (Map ks vs) = go (I.size vs - 1) b0+  where+  go :: Int -> b -> b+  go !ix !acc = if ix >= 0+    then+      let (# k #) = I.index# ks ix+          (# v #) = I.index# vs ix+       in go (ix - 1) (f k v acc)+    else acc+{-# INLINEABLE foldrWithKey' #-}+
+ src/Data/Map/Lifted/Lifted.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Map.Lifted.Lifted+  ( Map+  , singleton+  , lookup+  , size+  , map+  , mapMaybe+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  ) where++import Prelude hiding (lookup,map)++import Data.Semigroup (Semigroup)+import Data.Primitive.Array (Array)+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@. The key type and the value+--   type must both have 'Prim' instances.+newtype Map k v = Map (I.Map Array Array k v)++instance (Ord k, Semigroup v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Ord k, Semigroup v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++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 => 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) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: Ord k => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++-- | /O(1)/ Create a map with a single element.+singleton :: k -> v -> Map k v+singleton k v = Map (I.singleton k v)++-- | /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 => [(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+  => 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) => [(k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++-- | /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)+  => 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.size m++-- | /O(n)/ Map over the values in the map.+map ::+     (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 ::+     (v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++-- | /O(n)/ Left monadic fold over the keys and values of the map. This fold+-- is strict in the accumulator.+foldlWithKeyM' :: Monad m+  => (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+  => (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)+  => (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)+  => (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+  => (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' ::+     (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' ::+     (k -> v -> b -> b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> b+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
+ src/Data/Map/Subset/Internal.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Subset.Internal+  ( Map+  , lookup+  , empty+  , singleton+  , toList+  , fromList+  ) where++import Prelude hiding (lookup,concat)++import Data.Primitive.Contiguous (Contiguous,Element)+import Data.Set.Internal (Set(..))+import Data.Bifunctor (first)+import Data.Semigroup (Semigroup,(<>),First(..))++import qualified Data.Primitive.Contiguous as A+import qualified Data.Set.Internal as S+import qualified Data.Set.Lifted.Internal as SL+import qualified Data.Semigroup as SG+import qualified Prelude as P+import qualified Data.Foldable as F++-- There are two invariants for Map.+--+-- 1. The children of any Map may only contain keys that are+--    greater than the key in their parent.+-- 2. A parent's two children must not be equal.+--+-- This type cannot be a Functor since it needs to uses+-- an Eq instance for a kind of simple compression.+data Map k v+  = MapElement !k !(Map k v) !(Map k v)+  | MapValue !v+  | MapEmpty+  deriving (Eq,Ord)++instance (Semigroup v, Eq v, Ord k) => Semigroup (Map k v) where+  (<>) = append++instance (Semigroup v, Eq v, Ord k) => Monoid (Map k v) where+  mempty = empty+  mappend = (SG.<>)+  -- mconcat = concat ++instance (Show k, Show v) => Show (Map k v) where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (P.map (first SL.Set) (toList xs))++-- the functon f must satisfy the following:+-- a == b <=> f a == f b+unsafeMapValues :: (v -> w) -> Map k v -> Map k w+unsafeMapValues f = go where+  go MapEmpty = MapEmpty+  go (MapValue x) = MapValue (f x)+  go (MapElement k present absent) =+    MapElement k (go present) (go absent)++toList :: (Contiguous arr, Element arr k)+  => Map k v+  -> [(Set arr k,v)]+toList = foldrWithKey (\k v xs -> (k,v) : xs) []++fromList :: (Contiguous arr, Element arr k, Ord k, Eq v)+  => [(Set arr k,v)]+  -> Map k v+fromList = unsafeMapValues getFirst . concat . P.map (\(s,v) -> singleton s (First v))++concat :: (Ord k,Semigroup v,Eq v)+  => [Map k v]+  -> Map k v+concat = F.foldl' (\r x -> append r x) empty++foldrWithKey :: (Contiguous arr, Element arr k)+  => (Set arr k -> v -> b -> b)+  -> b+  -> Map k v+  -> b+foldrWithKey f b0 = go 0 [] b0 where+  go !_ !_ b MapEmpty = b+  go !n !xs b (MapValue v) = f (Set (A.unsafeFromListReverseN n xs)) v b+  go !n !xs b (MapElement k present absent) =+    go (n + 1) (k : xs) (go n xs b absent) present++empty :: Map k v+empty = MapEmpty++singleton :: (Eq v, Contiguous arr, Element arr k)+  => Set arr k+  -> v+  -> Map k v+singleton s v = S.foldr (\k m -> MapElement k m empty) (MapValue v) s+  +lookup :: forall arr k v. (Ord k, Contiguous arr, Element arr k)+  => Set arr k+  -> Map k v+  -> Maybe v+{-# INLINABLE lookup #-}+lookup (Set arr) = go 0 where+  !sz = A.size arr+  go :: Int -> Map k v -> Maybe v+  go !_ MapEmpty = Nothing+  go !_ (MapValue v) = Just v+  go !ix (MapElement element present absent) =+    choose ix element present absent+  choose :: Int -> k -> Map k v -> Map k v -> Maybe v+  choose !ix element present absent = if ix < sz+    then +      let (# k #) = A.index# arr ix+       in case compare k element of+            EQ -> go (ix + 1) present+            LT -> choose (ix + 1) element present absent+            GT -> go ix absent+    else followAbsent absent++followAbsent :: Map k v -> Maybe v+followAbsent (MapElement _ _ x) = followAbsent x+followAbsent (MapValue v) = Just v+followAbsent MapEmpty = Nothing++augment :: (Eq k, Eq v) => (v -> v) -> v -> Map k v -> Map k v+augment _ v MapEmpty = MapValue v+augment f _ (MapValue x) = MapValue (f x)+augment f v (MapElement k present absent) =+  let present' = augment f v present+      absent' = augment f v absent+   in if present' == absent'+        then present' +        else MapElement k present' absent'++append :: forall k v. (Semigroup v, Eq v, Ord k) => Map k v -> Map k v -> Map k v+append = go where+  go :: Map k v -> Map k v -> Map k v+  go MapEmpty m = m+  go (MapValue x) (MapValue y) = MapValue (x <> y)+  go (MapValue x) MapEmpty = MapValue x+  go (MapValue x) (MapElement elemY presentY absentY) =+    augment (x SG.<>) x (MapElement elemY presentY absentY)+  go (MapElement elemX presentX absentX) MapEmpty =+    MapElement elemX presentX absentX+  go (MapElement elemX presentX absentX) (MapValue y) =+    augment (SG.<> y) y (MapElement elemX presentX absentX)+  go (MapElement elemX presentX absentX) (MapElement elemY presentY absentY) = case compare elemX elemY of+    EQ -> +      let present = go presentX presentY+          absent = go absentX absentY+       in if present == absent+            then present+            else MapElement elemX present absent+    LT ->+      let present = go presentX (MapElement elemY presentY absentY)+          absent = go absentX (MapElement elemY presentY absentY)+       in if present == absent+            then present+            else MapElement elemX present absent+    GT ->+      let present = go (MapElement elemX presentX absentX) presentY+          absent = go (MapElement elemX presentX absentX) absentY+       in if present == absent+            then present+            else MapElement elemY present absent+
+ src/Data/Map/Subset/Lifted.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Subset.Lifted+  ( I.Map+  , singleton+  , lookup+  , toList+  , fromList+  ) where++import Prelude hiding (lookup)++import Data.Map.Subset.Internal (Map)+import Data.Set.Lifted.Internal (Set(..))+import Data.Bifunctor (first)+import Data.Semigroup (Semigroup)++import qualified Data.Map.Subset.Internal as I++singleton :: (Monoid v, Eq v)+  => Set k+  -> v+  -> Map k v+singleton (Set s) v = I.singleton s v++lookup :: Ord k => Set k -> Map k v -> Maybe v+lookup (Set s) m = I.lookup s m++toList :: Map k v -> [(Set k,v)]+toList = map (first Set) . I.toList++fromList :: (Ord k, Eq v, Semigroup v) => [(Set k,v)] -> Map k v+fromList = I.fromList . map (first getSet)
+ src/Data/Map/Unboxed/Lifted.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Map.Unboxed.Lifted+  ( Map+  , singleton+  , lookup+  , size+  , map+  , mapMaybe+    -- * Folds+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+    -- * Array Conversion+  , unsafeFreezeZip+  ) where++import Prelude hiding (lookup,map)++import Control.Monad.ST (ST)+import Data.Semigroup (Semigroup)+import Data.Primitive.Types (Prim)+import Data.Primitive (PrimArray,Array,MutablePrimArray,MutableArray)+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@. The key type must have a+--   'Prim' instance and the value type is unconstrained.+newtype Map k v = Map (I.Map PrimArray Array k v)++-- | This fails the functor laws since fmap is strict.+instance Prim k => Functor (Map k) where+  fmap = map++instance (Prim k, Ord k, Semigroup v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Prim k, Ord k, Semigroup v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (Prim k, Eq k, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Prim k, Ord k, Ord v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (Prim k, Ord k) => 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 (Prim k, Show k, Show v) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: (Prim k, Ord k) => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++-- | /O(1)/ Create a map with a single element.+singleton :: (Prim k) => k -> v -> Map k v+singleton k v = Map (I.singleton k v)++-- | /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 :: (Prim k, Ord k) => [(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 :: (Prim k, Ord k)+  => 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 :: (Prim k, Ord k, Semigroup v) => [(k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++-- | /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 :: (Prim k, Ord k, Semigroup 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.size m++-- | /O(n)/ Map over the values in the map.+map :: Prim k+  => (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 :: Prim k+  => (v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++-- | /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)+  => (b -> k -> v -> m b)+  -> b+  -> Map k v+  -> 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, Prim k)+  => (k -> v -> b -> m b)+  -> b+  -> Map k v+  -> 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, Prim k)+  => (k -> v -> m b)+  -> Map k v+  -> 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, Prim k)+  => (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, Prim k)+  => (k -> v -> b)+  -> Map k v+  -> b+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m++-- | /O(n*log n)/ Zip an array of keys with an array of values. If they are+-- not the same length, the longer one will be truncated to match the shorter+-- one. This function sorts and deduplicates the array of keys, preserving the+-- last value associated with each key. The argument arrays may not be+-- reused after being passed to this function.+--+-- This is by far the fastest way to create a map, since the functions backing it+-- are aggressively specialized. It internally uses a hybrid of mergesort and+-- insertion sort provided by the @primitive-sort@ package. It generates much+-- less garbage than any of the @fromList@ variants. +unsafeFreezeZip :: (Ord k, Prim k)+  => MutablePrimArray s k+  -> MutableArray s v+  -> ST s (Map k v)+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
+ src/Data/Map/Unboxed/Unboxed.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Map.Unboxed.Unboxed+  ( Map+  , singleton+  , lookup+  , size+  , map+  , mapMaybe+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+    -- * Array Conversion+  , unsafeFreezeZip+  ) where++import Prelude hiding (lookup,map)++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 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.+newtype Map k v = Map (I.Map PrimArray PrimArray k v)++instance (Prim k, Ord k, Prim v, Semigroup v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Prim k, Ord k, Prim v, Semigroup v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (Prim k, Eq k, Prim v, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Prim k, Ord k, Prim v, Ord v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (Prim k, Ord k, Prim 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 (Prim k, Show k, Prim v, Show v) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: (Prim k, Ord k, Prim 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 :: (Prim k, Prim v) => k -> v -> Map k v+singleton k v = Map (I.singleton k v)++-- | /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 :: (Prim k, Ord k, Prim 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 :: (Prim k, Ord k, Prim 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 :: (Prim k, Ord k, Prim v, Semigroup v) => [(k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++-- | /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 :: (Prim k, Ord k, Prim v, Semigroup 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 :: Prim v => Map k v -> Int+size (Map m) = I.size m++-- | /O(n)/ Map over the values in the map.+map :: (Prim k, Prim v, Prim 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 :: (Prim k, Prim v, Prim w)+  => (v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++-- | /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, Prim 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, Prim k, Prim 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, Prim k, Prim 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, Prim k, Prim 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, Prim k, Prim 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' :: (Prim k, Prim 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' :: (Prim k, Prim 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*log n)/ Zip an array of keys with an array of values. If they are+-- not the same length, the longer one will be truncated to match the shorter+-- one. This function sorts and deduplicates the array of keys, preserving the+-- last value associated with each key. The argument arrays may not be+-- reused after being passed to this function.+--+-- This is by far the fastest way to create a map, since the functions backing it+-- are aggressively specialized. It internally uses a hybrid of mergesort and+-- insertion sort provided by the @primitive-sort@ package. It generates much+-- less garbage than any of the @fromList@ variants. +unsafeFreezeZip :: (Ord k, Prim k, Prim v)+  => MutablePrimArray s k+  -> MutablePrimArray s v+  -> ST s (Map k v)+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)+
+ src/Data/Map/Unboxed/Unlifted.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Map.Unboxed.Unlifted+  ( Map+  , singleton+  , lookup+  , size+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  ) where++import Prelude hiding (lookup)++import Data.Semigroup (Semigroup)+import Data.Primitive.Types (Prim)+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray)+import Data.Primitive (PrimArray)+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@. The key type and the value+--   type must both have 'Prim' instances.+newtype Map k v = Map (I.Map PrimArray UnliftedArray k v)++instance (Prim k, Ord k, PrimUnlifted v, Semigroup v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Prim k, Ord k, PrimUnlifted v, Semigroup v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (Prim k, Eq k, PrimUnlifted v, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Prim k, Ord k, PrimUnlifted v, Ord v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (Prim k, 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 (Prim k, Show k, PrimUnlifted v, Show v) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++-- | /O(log n)/ Lookup the value at a key in the map.+lookup :: (Prim k, 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 :: (Prim k, PrimUnlifted v) => k -> v -> Map k v+singleton k v = Map (I.singleton k v)++-- | /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 :: (Prim k, 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 :: (Prim k, 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 :: (Prim k, Ord k, PrimUnlifted v, Semigroup v) => [(k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++-- | /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 :: (Prim k, Ord k, PrimUnlifted v, Semigroup 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 :: PrimUnlifted v => Map k v -> Int+size (Map m) = I.size m++
+ src/Data/Set/Internal.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall #-}+module Data.Set.Internal+  ( Set(..)+  , empty+  , singleton+  , difference+  , append+  , member+  , showsPrec+  , equals+  , compare+  , fromListN+  , fromList+  , toList+  , size+  , concat+    -- * Folds+  , foldr+  , foldl'+  , foldr'+  , foldMap'+  , foldlM'+  ) where++import Prelude hiding (compare,showsPrec,concat,foldr)+import qualified Prelude as P++import Control.Monad.ST (ST,runST)+import Data.Primitive.UnliftedArray (PrimUnlifted(..))+import Data.Primitive.Contiguous (Contiguous,Mutable,Element)+import qualified Data.Primitive.Contiguous as A+import qualified Data.Concatenation as C++newtype Set arr a = Set (arr a)++instance Contiguous arr => PrimUnlifted (Set arr a) where+  toArrayArray# (Set a) = A.unlift a+  fromArrayArray# a = Set (A.lift a)++append :: (Contiguous arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Set arr a+append (Set x) (Set y) = Set (unionArr x y)+  +empty :: Contiguous arr => Set arr a+empty = Set A.empty++equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool+equals (Set x) (Set y) = A.equals x y++compare :: (Contiguous arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Ordering+compare (Set x) (Set y) = compareArr x y++fromListN :: (Contiguous arr, Element arr a, Ord a) => Int -> [a] -> Set arr a+fromListN n xs = -- fromList xs+  case xs of+    [] -> empty+    y : ys ->+      let (leftovers, result) = fromAscList (max 1 n) y ys+       in concat (result : P.map singleton leftovers)++fromList :: (Contiguous arr, Element arr a, Ord a) => [a] -> Set arr a+fromList = fromListN 1++difference :: forall a arr. (Contiguous arr, Element arr a, Ord a)+  => Set arr a+  -> Set arr a+  -> Set arr a+difference s1@(Set arr1) s2@(Set arr2)+  | sz1 == 0 = empty+  | sz2 == 0 = s1+  | otherwise = runST $ do+      dst <- A.new sz1+      let go !ix1 !ix2 !dstIx = if ix2 < sz2+            then if ix1 < sz1+              then do+                v1 <- A.indexM arr1 ix1+                v2 <- A.indexM arr2 ix2+                case P.compare v1 v2 of+                  EQ -> go (ix1 + 1) (ix2 + 1) dstIx+                  LT -> do+                    A.write dst dstIx v1+                    go (ix1 + 1) ix2 (dstIx + 1)+                  GT -> go ix1 (ix2 + 1) dstIx+              else return dstIx+            else do+              let !remaining = sz1 - ix1+              A.copy dst dstIx arr1 ix1 remaining+              return (dstIx + remaining)+      dstSz <- go 0 0 0+      dstFrozen <- A.resize dst dstSz >>= A.unsafeFreeze+      return (Set dstFrozen)+  where+    !sz1 = size s1+    !sz2 = size s2++fromAscList :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => Int -- initial size of buffer, must be 1 or higher+  -> a -- first element+  -> [a] -- elements+  -> ([a], Set arr a)+fromAscList !n x0 xs0 = runST $ do+  marr0 <- A.new n+  A.write marr0 0 x0+  let go :: forall s. Int -> a -> Int -> Mutable arr s a -> [a] -> ST s ([a], Set arr a)+      go !ix !_ !sz !marr [] = if ix == sz+        then do+          arr <- A.unsafeFreeze marr+          return ([],Set arr)+        else do+          marr' <- A.resize marr ix+          arr <- A.unsafeFreeze marr'+          return ([],Set arr)+      go !ix !old !sz !marr (x : xs) = if ix < sz+        then case P.compare x old of+          GT -> do+            A.write marr ix x+            go (ix + 1) x sz marr xs+          EQ -> go ix x sz marr xs+          LT -> do+            marr' <- A.resize marr ix+            arr <- A.unsafeFreeze marr'+            return (x : xs,Set arr)+        else do+          let sz' = sz * 2+          marr' <- A.resize marr sz'+          go ix old sz' marr' (x : xs)+  go 1 x0 n marr0 xs0++showsPrec :: (Contiguous arr, Element arr a, Show a) => Int -> Set arr a -> ShowS+showsPrec p xs = showParen (p > 10) $+  showString "fromList " . shows (toList xs)++toList :: (Contiguous arr, Element arr a) => Set arr a -> [a]+toList = foldr (:) []++member :: forall arr a. (Contiguous arr, Element arr a, Ord a) => a -> Set arr a -> Bool+member a (Set arr) = go 0 (A.size arr - 1) where+  go :: Int -> Int -> Bool+  go !start !end = if end < start+    then False+    else+      let !mid = div (end + start) 2+          !v = A.index arr mid+       in case P.compare a v of+            LT -> go start (mid - 1)+            EQ -> True+            GT -> go (mid + 1) end+{-# INLINEABLE member #-}++concat :: forall arr a. (Contiguous arr, Element arr a, Ord a) => [Set arr a] -> Set arr a+concat = C.concatSized size empty append++compareArr :: (Contiguous arr, Element arr a, Ord a)+  => arr a+  -> arr a+  -> Ordering+compareArr arrA arrB = go 0 where+  go :: Int -> Ordering+  go !ix = if ix < A.size arrA+    then if ix < A.size arrB+      then mappend (P.compare (A.index arrA ix) (A.index arrB ix)) (go (ix + 1))+      else GT+    else if ix < A.size arrB+      then LT+      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++unionArr :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => arr a -- array x+  -> arr a -- array y+  -> arr a+unionArr arrA arrB+  | szA < 1 = arrB+  | szB < 1 = arrA+  | otherwise = runST $ do+      !(arrDst :: Mutable arr s a)  <- A.new (szA + szB)+      let go !ixA !ixB !ixDst = if ixA < szA+            then if ixB < szB+              then do+                let !a = A.index arrA ixA+                    !b = A.index arrB ixB+                case P.compare a b of+                  EQ -> do+                    A.write arrDst ixDst a+                    go (ixA + 1) (ixB + 1) (ixDst + 1)+                  LT -> do+                    A.write arrDst ixDst a+                    go (ixA + 1) ixB (ixDst + 1)+                  GT -> do+                    A.write arrDst ixDst b+                    go ixA (ixB + 1) (ixDst + 1)+              else do+                A.copy arrDst ixDst arrA ixA (szA - ixA)+                return (ixDst + (szA - ixA))+            else if ixB < szB+              then do+                A.copy arrDst ixDst arrB ixB (szB - ixB)+                return (ixDst + (szB - ixB))+              else return ixDst+      total <- go 0 0 0+      arrFinal <- A.resize arrDst total+      A.unsafeFreeze arrFinal+  where+  !szA = A.size arrA+  !szB = A.size arrB++size :: (Contiguous arr, Element arr a) => Set arr a -> Int+size (Set arr) = A.size arr++foldr :: (Contiguous arr, Element arr a)+  => (a -> b -> b)+  -> b+  -> Set arr a+  -> b+foldr f b0 (Set arr) = A.foldr f b0 arr+{-# INLINEABLE foldr #-}++foldl' :: (Contiguous arr, Element arr a)+  => (b -> a -> b)+  -> b+  -> Set arr a+  -> b+foldl' f b0 (Set arr) = A.foldl' f b0 arr+{-# INLINEABLE foldl' #-}++foldr' :: (Contiguous arr, Element arr a)+  => (a -> b -> b)+  -> b+  -> Set arr a+  -> b+foldr' f b0 (Set arr) = A.foldr' f b0 arr+{-# INLINEABLE foldr' #-}++foldMap' :: (Contiguous arr, Element arr a, Monoid m)+  => (a -> m)+  -> Set arr a+  -> m+foldMap' f (Set arr) = A.foldMap' f arr+{-# INLINEABLE foldMap' #-}++foldlM' :: (Contiguous arr, Element arr a, Monad m)+  => (b -> a -> m b)+  -> b+  -> Set arr a+  -> m b+foldlM' f b0 (Set arr) = A.foldlM' f b0 arr+{-# INLINEABLE foldlM' #-}
+ src/Data/Set/Lifted.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Set.Lifted+  ( Set+  , singleton+  , member+  , size+  , difference+  , (\\)+    -- * List Conversion+  , LI.toList+  , LI.fromList+    -- * Folds+  , LI.foldr+  , LI.foldl'+  , LI.foldr'+  , foldMap'+  ) where++import Prelude hiding (foldr)+import Data.Semigroup (Semigroup)+import Data.Set.Lifted.Internal (Set(..))+import qualified Data.Set.Internal as I+import qualified Data.Set.Lifted.Internal as LI++-- | The difference of two sets.+difference :: Ord a => Set a -> Set a -> Set a+difference (Set x) (Set y) = Set (I.difference x y)++-- | Infix operator for 'difference'.+(\\) :: Ord a => Set a -> Set a -> Set a+(\\) (Set x) (Set y) = Set (I.difference x y)++-- | Test whether or not an element is present in a set.+member :: Ord a => a -> Set a -> Bool+member a (Set s) = I.member a s++-- | Construct a set with a single element.+singleton :: a -> Set a+singleton = Set . I.singleton++-- | The number of elements in the set.+size :: Set a -> Int+size (Set s) = I.size s++-- | Strict monoidal fold over the elements in the set.+foldMap' :: Monoid m+  => (a -> m)+  -> Set a+  -> m+foldMap' f (Set arr) = I.foldMap' f arr+
+ src/Data/Set/Lifted/Internal.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Set.Lifted.Internal+  ( Set(..)+  , toList+  , fromList+  , foldr+  , foldl'+  , foldr'+  ) where++import Prelude hiding (foldr)++import Data.Primitive.UnliftedArray (PrimUnlifted(..))+import Data.Functor.Classes (Eq1(liftEq),Show1(liftShowsPrec))+import Data.Primitive (Array)+import Data.Semigroup (Semigroup)+import Text.Show (showListWith)++import qualified Data.Foldable as F+import qualified Data.Semigroup as SG+import qualified Data.Set.Internal as I+import qualified GHC.Exts as E++newtype Set a = Set { getSet :: I.Set Array a }++instance F.Foldable Set where+  foldr = foldr+  foldl' = foldl'+  foldr' = foldr'++instance PrimUnlifted (Set a) where+  toArrayArray# (Set x) = toArrayArray# x+  fromArrayArray# y = Set (fromArrayArray# y)++instance Ord a => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)+  stimes = SG.stimesIdempotentMonoid+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))++instance Ord a => Monoid (Set a) where+  mempty = Set I.empty+  mappend = (SG.<>)+  mconcat xs = Set (I.concat (E.coerce xs))++instance Eq a => Eq (Set a) where+  Set x == Set y = I.equals x y++instance Eq1 Set where+  liftEq f a b = liftEq f (toList a) (toList b)++instance Ord a => Ord (Set a) where+  compare (Set x) (Set y) = I.compare x y++instance Ord a => E.IsList (Set a) where+  type Item (Set a) = a+  fromListN n = Set . I.fromListN n+  fromList = Set . I.fromList+  toList = toList++instance Show a => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++instance Show1 Set where+  liftShowsPrec f _ p s = showParen (p > 10) $+   showString "fromList " . showListWith (f 0) (toList s)++-- | Convert a set to a list. The elements are given in ascending order.+toList :: Set a -> [a]+toList (Set s) = I.toList s++-- | Convert a list to a set.+fromList :: Ord a => [a] -> Set a+fromList = Set . I.fromList++-- | Right fold over the elements in the set. This is lazy in the accumulator.+foldr :: +     (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr f b0 (Set s) = I.foldr f b0 s++-- | Strict left fold over the elements in the set.+foldl' :: +     (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' :: +     (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr' f b0 (Set s) = I.foldr' f b0 s
+ src/Data/Set/Unboxed.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wall #-}+module Data.Set.Unboxed+  ( Set+  , singleton+  , member+  , size+  , difference+  , (\\)+    -- * List Conversion+  , toList+  , fromList+    -- * Folds+  , foldr+  , foldl'+  , foldr'+  , foldMap'+  ) where++import Prelude hiding (foldr)+import Data.Primitive.Types (Prim)+import Data.Primitive.UnliftedArray (PrimUnlifted(..))+import Data.Primitive.PrimArray (PrimArray)+import Data.Semigroup (Semigroup)+import qualified Data.Foldable as F+import qualified Data.Semigroup as SG+import qualified GHC.Exts as E+import qualified Data.Set.Internal as I++-- | A set of elements.+newtype Set a = Set (I.Set PrimArray a)++instance PrimUnlifted (Set a) where+  toArrayArray# (Set x) = toArrayArray# x+  fromArrayArray# y = Set (fromArrayArray# y)++instance (Prim a, Ord a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)+  stimes = SG.stimesIdempotentMonoid+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))++instance (Prim a, Ord a) => Monoid (Set a) where+  mempty = Set I.empty+  mappend = (SG.<>)+  mconcat xs = Set (I.concat (E.coerce xs))++instance (Prim a, Eq a) => Eq (Set a) where+  Set x == Set y = I.equals x y++instance (Prim a, Ord a) => Ord (Set a) where+  compare (Set x) (Set y) = I.compare x y++-- | The functions that convert a list to a 'Set' are asymptotically+-- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/+-- rather than /O(n^2)/. If the input list is sorted, even if duplicate+-- elements are present, the algorithm further improves to /O(n)/. The+-- fastest option available is calling 'fromListN' on a presorted list+-- and passing the correct size size of the resulting 'Set'. However, even+-- if an incorrect size is given to this function,+-- it will still correctly convert the list into a 'Set'.+instance (Prim a, Ord a) => E.IsList (Set a) where+  type Item (Set a) = a+  fromListN n = Set . I.fromListN n+  fromList = Set . I.fromList+  toList = toList++instance (Prim a, Show a) => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++-- | The difference of two sets.+difference :: (Ord a, Prim a) => Set a -> Set a -> Set a+difference (Set x) (Set y) = Set (I.difference x y)++-- | Infix operator for 'difference'.+(\\) :: (Ord a, Prim a) => Set a -> Set a -> Set a+(\\) (Set x) (Set y) = Set (I.difference x y)+-- | 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++-- | Construct a set with a single element.+singleton :: Prim a => a -> Set a+singleton = Set . I.singleton++-- | Convert a set to a list. The elements are given in ascending order.+toList :: Prim a => Set a -> [a]+toList (Set s) = I.toList s++-- | Convert a list to a set.+fromList :: (Ord a, Prim a) => [a] -> Set a+fromList xs = Set (I.fromList xs)++-- | The number of elements in the set.+size :: Prim a => Set a -> Int+size (Set s) = I.size s++-- | Right fold over the elements in the set. This is lazy in the accumulator.+foldr :: Prim a+  => (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr f b0 (Set s) = I.foldr f b0 s++-- | Strict left fold over the elements in the set.+foldl' :: Prim 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' :: Prim 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' :: (Monoid m, Prim a)+  => (a -> m)+  -> Set a+  -> m+foldMap' f (Set arr) = I.foldMap' f arr+++
+ src/Data/Set/Unlifted.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Set.Unlifted+  ( Set+  , singleton+  , member+  , size+  ) where++import Data.Primitive.UnliftedArray (UnliftedArray, PrimUnlifted(..))+import Data.Semigroup (Semigroup)+import qualified Data.Foldable as F+import qualified Data.Semigroup as SG+import qualified GHC.Exts as E+import qualified Data.Set.Internal as I++-- | A set of elements.+newtype Set a = Set (I.Set UnliftedArray a)++instance PrimUnlifted (Set a) where+  toArrayArray# (Set x) = toArrayArray# x+  fromArrayArray# y = Set (fromArrayArray# y)++instance (PrimUnlifted a, Ord a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)+  stimes = SG.stimesIdempotentMonoid+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))++instance (PrimUnlifted a, Ord a) => Monoid (Set a) where+  mempty = Set I.empty+  mappend = (SG.<>)+  mconcat xs = Set (I.concat (E.coerce xs))++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++-- | The functions that convert a list to a 'Set' are asymptotically+-- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/+-- rather than /O(n^2)/. If the input list is sorted, even if duplicate+-- elements are present, the algorithm further improves to /O(n)/. The+-- fastest option available is calling 'fromListN' on a presorted list+-- and passing the correct size size of the resulting 'Set'. However, even+-- if an incorrect size is given to this function,+-- it will still correctly convert the list into a 'Set'.+instance (PrimUnlifted a, Ord a) => E.IsList (Set a) where+  type Item (Set a) = a+  fromListN n = Set . I.fromListN n+  fromList = Set . I.fromList+  toList (Set s) = I.toList s++instance (PrimUnlifted a, Show a) => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++-- | 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++
+ test/Main.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++import Data.Primitive+import Data.Primitive.UnliftedArray (PrimUnlifted)+import Data.Word+import Data.Proxy (Proxy(..))+import Data.Int++import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.QuickCheck (Arbitrary,Gen,(===),(==>))+import Data.List.NonEmpty (NonEmpty((:|)))+import Control.Monad (forM)+import qualified Test.Tasty.QuickCheck as TQC+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Classes as QCC+import qualified Data.Semigroup as SG+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Foldable as F+import qualified GHC.Exts as E+import qualified Test.QuickCheck.Classes.IsList as QCCL++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.Unboxed.Unboxed as MUU+import qualified Data.Diet.Map.Unboxed.Lifted as DMUL+import qualified Data.Diet.Map.Lifted.Lifted as DMLL+import qualified Data.Diet.Set.Lifted as DSL+import qualified Data.Diet.Unbounded.Set.Lifted as DUSL+import qualified Data.Map.Subset.Lifted as MSL++main :: IO ()+main = defaultMain $ testGroup "Data"+  [ testGroup "Set"+    [ testGroup "Unboxed"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SU.Set Int16)))+      , lawsToTest (QCC.ordLaws (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)+      ]+    , testGroup "Lifted"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SL.Set Integer)))+      , lawsToTest (QCC.ordLaws (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 "foldr" (QCCL.foldrProp int32 SL.foldr)+      , TQC.testProperty "foldl'" (QCCL.foldlProp int16 SL.foldl')+      , TQC.testProperty "foldr'" (QCCL.foldrProp int32 SL.foldr')+      , TQC.testProperty "difference" differenceProp+      ]+    , testGroup "Unlifted"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))+      , lawsToTest (QCC.ordLaws (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)+      ]+    ]+  , testGroup "Map"+    [ testGroup "Unboxed"+      [ testGroup "Unboxed"+        [ 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.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)+        , TQC.testProperty "foldlWithKey'" (mapFoldAgreement MUU.foldlWithKey' M.foldlWithKey)+        , TQC.testProperty "foldrWithKey'" (mapFoldAgreement MUU.foldrWithKey' M.foldrWithKey)+        , TQC.testProperty "foldMapWithKey'" (mapFoldMonoidAgreement MUU.foldMapWithKey' M.foldMapWithKey)+        ]+      ]+    ]+  , testGroup "Diet"+    [ testGroup "Unbounded"+      [ testGroup "Set"+        [ testGroup "Lifted"+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DUSL.Set Word8)))+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DUSL.Set Word8)))+          ]+        ]+      ]+    , testGroup "Set"+      [ testGroup "Lifted"+        [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DSL.Set Word16)))+        , lawsToTest (QCC.ordLaws (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)+        , TQC.testProperty "difference" dietSetDifferenceProp+        , TQC.testProperty "aboveInclusive" dietSetAboveProp+        , testGroup "belowInclusive"+          [ TQC.testProperty "basic" dietSetBelowProp+          , TQC.testProperty "lowest" dietSetBelowLowestProp+          , TQC.testProperty "highest" dietSetBelowHighestProp+          ]+        , testGroup "betweenInclusive"+          [ TQC.testProperty "basic" dietSetBetweenProp+          , TQC.testProperty "border" dietSetBetweenBorderProp+          , TQC.testProperty "inside" dietSetBetweenBorderNearProp+          ]+        ]+      ]+    , testGroup "Map"+      [ testGroup "Subset"+        [ 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.commutativeMonoidLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer))))+          , TQC.testProperty "lookup" subsetMapLookupProp+          ]+        ]+      , testGroup "Lifted"+        [ testGroup "Lifted"+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DMLL.Map Word8 Integer)))+          , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DMLL.Map Word8 Word)))+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DMLL.Map Word8 Int)))+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DMLL.Map Word8 Integer)))+          , TQC.testProperty "lookup" (dietLookupPropA @Word8 @Int E.fromList DMLL.lookup)+          , TQC.testProperty "doubleton" dietDoubletonProp+          , TQC.testProperty "valid" dietValidProp+          ]+        ]+      , testGroup "Unboxed"+        [ testGroup "Lifted"+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DMUL.Map Word8 Integer)))+          , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DMUL.Map Word8 Word)))+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DMUL.Map Word8 Int)))+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DMUL.Map Word8 Integer)))+          , TQC.testProperty "lookup" (dietLookupPropA @Word32 @Int E.fromList DMUL.lookup)+          ]+        ]+      ]+    ]+  ]++int16 :: Proxy Int16+int16 = Proxy++int32 :: Proxy Int32+int32 = Proxy++subsetMapLookupProp :: QC.Property+subsetMapLookupProp = QC.property $ \(xs :: MSL.Map Integer Integer) ->+  let xs' = MSL.toList xs+   in all (\(k,v) -> MSL.lookup k xs == Just v) xs' === True++dietSetDifferenceProp :: QC.Property+dietSetDifferenceProp = QC.property $ \(xs :: DSL.Set Word8) (ys :: DSL.Set Word8) ->+  let xs' = dietSetToSet xs+      ys' = dietSetToSet ys+   in DSL.difference xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.difference xs' ys')))++dietSetAboveProp :: QC.Property+dietSetAboveProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) ->+  let ys' = dietSetToSet ys+      (_,isMember,c) = S.splitMember y ys'+      r = if isMember then S.insert y c else c+   in DSL.aboveInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))++dietSetBelowProp :: QC.Property+dietSetBelowProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) ->+  let ys' = dietSetToSet ys+      (c,isMember,_) = S.splitMember y ys'+      r = if isMember then S.insert y c else c+   in DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))++dietSetBelowLowestProp :: QC.Property+dietSetBelowLowestProp = QC.property $ \(ys :: DSL.Set Word8) ->+  let ys' = dietSetToSet ys+   in case S.lookupMin ys' of+        Nothing -> QC.property QC.Discard+        Just y -> +          let (c,isMember,_) = S.splitMember y ys'+              r = if isMember then S.insert y c else c+           in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)))++dietSetBelowHighestProp :: QC.Property+dietSetBelowHighestProp = QC.property $ \(ys :: DSL.Set Word8) ->+  let ys' = dietSetToSet ys+   in case S.lookupMax ys' of+        Nothing -> QC.property QC.Discard+        Just y -> +          let (c,isMember,_) = S.splitMember y ys'+              r = if isMember then S.insert y c else c+           in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)))++dietSetBetweenProp :: QC.Property+dietSetBetweenProp = QC.property $ \(x :: Word8) (y :: Word8) (ys :: DSL.Set Word8) ->+  (x <= y)+  ==> +  ( let ys' = dietSetToSet ys+        r = S.filter (\e -> e >= x && e <= y) ys'+     in DSL.betweenInclusive x y ys === DSL.fromList (map (\z -> (z,z)) (S.toList r))+  )++dietSetBetweenBorderProp :: QC.Property+dietSetBetweenBorderProp = QC.property $ \(ys :: DSL.Set Word8) ->+  let ys' = dietSetToSet ys+   in case S.lookupMax ys' of+        Nothing -> QC.property QC.Discard+        Just hi -> case S.lookupMin ys' of+          Nothing -> QC.property QC.Discard+          Just lo -> +            let r = S.filter (\e -> e >= lo && e <= hi) ys'+             in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r))++dietSetBetweenBorderNearProp :: QC.Property+dietSetBetweenBorderNearProp = QC.property $ \(ys :: DSL.Set Word8) ->+  let ys' = dietSetToSet ys+   in ( S.size ys' > 1+        ==>+        ( let hi = pred (S.findMax ys')+              lo = succ (S.findMin ys')+              r = S.filter (\e -> e >= lo && e <= hi) ys'+           in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r))+        )+      )++-- This enumerates all of the element contained by all ranges+-- in the diet set.+dietSetToSet :: (Enum a, Ord a) => DSL.Set a -> S.Set a+dietSetToSet = DSL.foldr+  (\lo hi s -> S.fromList (enumFromTo lo hi) <> s)+  mempty++differenceProp :: QC.Property+differenceProp = QC.property $ \(xs :: S.Set Word8) (ys :: S.Set Word8) ->+  let xs' = SL.fromList (S.toList xs)+      ys' = SL.fromList (S.toList ys)+   in SL.toList (SL.difference xs' ys') === S.toList (S.difference xs ys)++mapFoldMonoidAgreement ::+     ((Int -> Int -> [Int]) -> MUU.Map Int Int -> [Int])+  -> ((Int -> Int -> [Int]) -> M.Map Int Int -> [Int])+  -> QC.Property+mapFoldMonoidAgreement foldPrim foldContainer = QC.property $ \(xs :: [(Int,Int)]) ->+  let p = E.fromList xs+      c = E.fromList xs+      func x y = [x + y]+   in foldPrim func p === foldContainer func c++mapFoldAgreement ::+     ((Int -> Int -> Int -> Int) -> Int -> MUU.Map Int Int -> Int)+  -> ((Int -> Int -> Int -> Int) -> Int -> M.Map Int Int -> Int)+  -> QC.Property+mapFoldAgreement foldPrim foldContainer = QC.property $ \(xs :: [(Int,Int)]) ->+  let p = E.fromList xs+      c = E.fromList xs+      -- we just need the function to be non-commutative+      func x y z = y - (2 * x) - (3 * z)+   in foldPrim func 42 p === foldContainer func 42 c++memberProp :: forall a t. (Arbitrary a, Show a) => ([a] -> t a) -> (a -> t a -> Bool) -> QC.Property+memberProp containerFromList containerMember = QC.property $ \(xs :: [a]) ->+  let c = containerFromList xs+   in all (\x -> containerMember x c) xs === True++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++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)+   in QC.counterexample ("original list: " ++ show xs ++ "; diet set: " ++ show c) (all (\x -> containerLookup x c == True) xs === True)++dietLookupPropA :: forall k v t. (Arbitrary k, Show k, Ord k, Arbitrary v, Show v, Eq v, Show (t k v)) => ([(k,k,v)] -> t k v) -> (k -> t k v -> Maybe v) -> QC.Property+dietLookupPropA containerFromList containerLookup = QC.property $ \(xs :: [(k,v)]) ->+  let ys = M.fromList xs+      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)++dietDoubletonProp :: QC.Property+dietDoubletonProp = QC.property $ \(loA :: Word8) (hiA :: Word8) (valA :: Int) (loB :: Word8) (hiB :: Word8) (valB :: Int) ->+  (hiA >= loA && hiB >= loB)+  ==>+  (simpleDoubletonToList loA hiA valA loB hiB valB === E.toList (DMLL.singleton loA hiA valA <> DMLL.singleton loB hiB valB))++dietValidProp :: QC.Property+dietValidProp = QC.property $ \(xs :: DMLL.Map Word8 Int) ->+  True === validDietTriples (E.toList xs)++simpleDoubletonToList :: (Ord k, Enum k, Semigroup v, Eq v) => k -> k -> v -> k -> k -> v -> [(k,k,v)]+simpleDoubletonToList key1A key2A valA key1B key2B valB =+  let loA = min key1A key2A+      hiA = max key1A key2A+      loB = min key1B key2B+      hiB = max key1B key2B+   in deduplicate $ case compare loA loB of+        LT -> case compare hiA loB of+          LT -> [(loA,hiA,valA),(loB,hiB,valB)]+          EQ -> case compare hiA hiB of+            LT -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB),(succ hiA,hiB,valB)]+            EQ -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB)]+            GT -> error "simpleDoubletonToList: invariant violated"+          GT -> case compare hiA hiB of+            LT -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB),(succ hiA,hiB,valB)]+            EQ -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB)]+            GT -> [(loA,pred loB,valA),(loB,hiB,valA SG.<> valB),(succ hiB,hiA,valA)]+        EQ -> case compare hiA hiB of+          LT -> [(loA,hiA,valA SG.<> valB),(succ hiA, hiB, valB)]+          GT -> [(loB,hiB,valA SG.<> valB),(succ hiB, hiA, valA)]+          EQ -> [(loA,hiA,valA SG.<> valB)]+        GT -> case compare hiB loA of+          LT -> [(loB,hiB,valB),(loA,hiA,valA)]+          EQ -> case compare hiB hiA of+            LT -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB),(succ hiB,hiA,valA)]+            EQ -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB)]+            GT -> error "simpleDoubletonToList: invariant violated"+          GT -> case compare hiB hiA of+            LT -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB),(succ hiB,hiA,valA)]+            EQ -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB)]+            GT -> [(loB,pred loA,valB),(loA,hiA,valA SG.<> valB),(succ hiA,hiB,valB)]++validDietTriples :: (Enum k,Eq k,Eq v) => [(k,k,v)] -> Bool+validDietTriples xs = deduplicate xs == xs++deduplicate :: (Enum k,Eq k, Eq v) => [(k,k,v)] -> [(k,k,v)]+deduplicate [] = []+deduplicate (x : xs) = F.toList (deduplicateNonEmpty (x :| xs))++deduplicateNonEmpty :: (Enum k, Eq k, Eq v) => NonEmpty (k,k,v) -> NonEmpty (k,k,v)+deduplicateNonEmpty ((lo,hi,v) :| xs) = case xs of+  y : ys -> case deduplicateNonEmpty (y :| ys) of+    (lo',hi',v') :| xs' -> if v == v' && pred lo' == hi+      then (lo,hi',v) :| xs'+      else (lo,hi,v) :| ((lo',hi',v') : xs')+  [] -> (lo,hi,v) :| []++lawsToTest :: QCC.Laws -> TestTree+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)++instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where+  arbitrary = fmap E.fromList QC.arbitrary++instance (Arbitrary a, Prim a, Ord a) => Arbitrary (SU.Set a) where+  arbitrary = fmap E.fromList QC.arbitrary++instance (Arbitrary a, PrimUnlifted a, Ord a) => Arbitrary (SUL.Set a) where+  arbitrary = fmap E.fromList QC.arbitrary++instance (Arbitrary a, Ord a) => Arbitrary (SL.Set a) where+  arbitrary = fmap E.fromList QC.arbitrary++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, 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 (Arbitrary k, Ord k, Arbitrary v, Eq v, Semigroup v) => Arbitrary (MSL.Map k v) where+  arbitrary = do+    len <- QC.choose (0,4)+    xs <- QC.vectorOf len $ do+      n <- QC.choose (0,3)+      ys <- QC.vector n+      v <- QC.arbitrary+      return (SL.fromList ys, v)+    return (MSL.fromList xs)+  shrink x =+    [ MSL.fromList (drop 1 y)+    ]+    where y = MSL.toList x++instance (Arbitrary k, Prim k, Ord k, Enum k, Bounded k, Arbitrary v, Semigroup v, Eq v) => Arbitrary (DMUL.Map k v) where+  arbitrary = do+    sz <- QC.choose (0,10)+    k <- QC.arbitrary+    xs <- increasingOrderedPairsHelper sz k+    ys <- forM xs $ \(lo,hi) -> do+      v <- QC.arbitrary+      return (lo,hi,v)+    return (DMUL.fromListAppend ys)+  shrink x = map E.fromList (QC.shrink (E.toList x))+    +instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (DSL.Set a) where+  arbitrary = DSL.fromList <$> QC.vectorOf 7 arbitraryOrderedPair+  shrink x = map E.fromList (QC.shrink (E.toList x))++instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (DUSL.Set a) where+  arbitrary = do+    sz <- QC.choose (0,7)+    k <- QC.arbitrary+    foldMap (\(lo,hi) -> DUSL.singleton (Just lo) (Just hi)) <$> increasingOrderedPairsHelper sz k+    +increasingOrderedPairsHelper :: (Ord k, Enum k, Bounded k) => Int -> k -> Gen [(k,k)]+increasingOrderedPairsHelper n k = if n > 0+  then case atLeastTwoGreaterThan k of+    Nothing -> return []+    Just vals -> do+      lo <- QC.elements vals+      hi <- QC.elements (equalToOrGreaterThan lo)+      xs <- increasingOrderedPairsHelper (n - 1) hi+      return ((lo,hi) : xs)+  else return []++equalToOrGreaterThan :: (Ord a, Bounded a, Enum a) => a -> [a]+equalToOrGreaterThan a0 =+  let a1 = if a0 < maxBound then succ a0 else a0+      a2 = if a1 < maxBound then succ a1 else a1+      a3 = if a2 < maxBound then succ a2 else a2+   in [a0,a1,a2,a3]++atLeastTwoGreaterThan :: (Enum a, Bounded a, Ord a) => a -> Maybe [a]+atLeastTwoGreaterThan a0 = do+  if a0 < maxBound+    then+      let a1 = succ a0+       in if a1 < maxBound+            then+              let a2 = succ a1+                  a3 = if a2 < maxBound then succ a2 else a2+                  a4 = if a3 < maxBound then succ a3 else a3+               in Just [a2,a3,a4]+            else Nothing+    else Nothing++arbitraryOrderedPair :: (Ord k, Enum k, Bounded k, Arbitrary k) => Gen (k,k)+arbitraryOrderedPair = do+  a0 <- QC.arbitrary+  let a1 = if a0 < maxBound then succ a0 else a0+      a2 = if a1 < maxBound then succ a1 else a1+      a3 = if a2 < maxBound then succ a2 else a2+  a' <- QC.elements [a0,a1,a2,a3]+  return (a0,a')++arbitraryOrderedPairValue :: (Ord k, Enum k, Bounded k, Arbitrary k, Arbitrary v) => Gen (k,k,v)+arbitraryOrderedPairValue = do+  (lo,hi) <- arbitraryOrderedPair+  v <- QC.arbitrary+  return (lo,hi,v)++instance SG.Semigroup Word where+  w <> _ = w++instance SG.Semigroup Int where+  (<>) = (+)++instance Monoid Int where+  mempty = 0+  mappend = (SG.<>)+  +instance SG.Semigroup Integer where+  (<>) = (+)++instance Monoid Integer where+  mempty = 0+  mappend = (SG.<>)++deriving instance Arbitrary a => Arbitrary (SG.First a)+