packages feed

primitive-containers 0.2.0 → 0.3.0

raw patch · 41 files changed

+4557/−944 lines, 41 filesdep +HUnitdep +aesondep +deepseqdep ~containersdep ~contiguous

Dependencies added: HUnit, aeson, deepseq, hashable, quantification, tasty-hunit, text, unordered-containers, vector

Dependency ranges changed: containers, contiguous

Files

benchmark-gauge/Main.hs view
@@ -29,6 +29,13 @@       , bench "primitive-lifted-lifted" $ whnf (DMLL.foldlWithKey' reduction 0) bigLiftedMap       , bench "containers-map" $ whnf (M.foldlWithKey' reduction 0) bigContainersMap       ]+    , bgroup "fromList"+      [ bgroup "primitive-unboxed-unboxed" +        [ bench "20" $ whnf DMUU.fromList randomKeyValue20+        , bench "200" $ whnf DMUU.fromList randomKeyValue200+        , bench "2000" $ whnf DMUU.fromList randomKeyValue2000+        ]+      ]     ]   , bgroup "Set"     [ bgroup "lookup" @@ -124,6 +131,22 @@  ascArray2000 :: [Word] ascArray2000 = take 2000 (enumFrom 0)++randomKeyValue20 :: [(Word,Word)]+randomKeyValue20 = take 20 $ zip+  (randoms (mkStdGen 75843))+  (randoms (mkStdGen 4632465))++randomKeyValue200 :: [(Word,Word)]+randomKeyValue200 = take 200 $ zip+  (randoms (mkStdGen 75843))+  (randoms (mkStdGen 4632465))++randomKeyValue2000 :: [(Word,Word)]+randomKeyValue2000 = take 2000 $ zip+  (randoms (mkStdGen 75843))+  (randoms (mkStdGen 4632465))+  randomArray20 :: [Word] randomArray20 = take 20 (randoms (mkStdGen 75843))
primitive-containers.cabal view
@@ -1,6 +1,10 @@+cabal-version: 2.0 name: primitive-containers-version: 0.2.0-description: Please see the README on Github at <https://github.com/andrewthad/primitive-containers>+version: 0.3.0+synopsis: containers backed by arrays+description:+  Containers backed by flat arrays. Updates require rebuilding the+  entire structure, but lookups are cache coherent. homepage: https://github.com/andrewthad/primitive-containers bug-reports: https://github.com/andrewthad/primitive-containers/issues author: Andrew Martin@@ -9,7 +13,6 @@ license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 2.0  extra-source-files:     ChangeLog.md@@ -26,10 +29,19 @@       base >=4.9 && <5     , primitive >= 0.6.4     , primitive-sort >= 0.1 && < 0.2-    , contiguous >= 0.2 && < 0.3+    , contiguous >= 0.3 && < 0.4+    , hashable >= 1.2.5+    , deepseq >= 1.4+      -- move these five out when we kick out dependent maps +    , quantification >= 0.5.0 && < 0.6+    , aeson >= 1.0 && < 1.5+    , unordered-containers >= 0.2.8.0+    , vector >= 0.11 && < 0.13+    , text >= 1.2 && < 1.3   exposed-modules:-    Data.Diet.Map.Lifted.Lifted-    Data.Diet.Map.Unboxed.Lifted+    Data.Continuous.Set.Lifted+    Data.Diet.Map.Strict.Lifted.Lifted+    Data.Diet.Map.Strict.Unboxed.Lifted     Data.Diet.Set     Data.Diet.Set.Lifted     Data.Diet.Set.Unboxed@@ -38,19 +50,33 @@     Data.Map.Unboxed.Lifted     Data.Map.Unboxed.Unboxed     Data.Map.Unboxed.Unlifted+    Data.Map.Unlifted.Unboxed+    Data.Map.Unlifted.Lifted     Data.Set.Lifted     Data.Set.Unboxed     Data.Set.Unlifted-    Data.Map.Subset.Lifted+    Data.Map.Subset.Strict.Lifted+    Data.Map.Subset.Strict.Unlifted+    Data.Map.Subset.Lazy.Lifted+    Data.Map.Subset.Lazy.Unlifted+    Data.Dependent.Map.Class+    Data.Dependent.Map.Internal+    Data.Dependent.Map.Lifted.Lifted+    Data.Dependent.Map.Unlifted.Lifted+    Data.Dependent.Map.Unboxed.Lifted   other-modules:     Data.Concatenation-    Data.Diet.Map.Internal+    Data.Diet.Map.Strict.Internal     Data.Diet.Set.Internal+    Data.Continuous.Set.Internal     Data.Diet.Unbounded.Set.Internal     Data.Map.Internal-    Data.Map.Subset.Internal+    Data.Map.Subset.Strict.Internal+    Data.Map.Subset.Lazy.Internal     Data.Set.Internal     Data.Set.Lifted.Internal+    Data.Set.Unboxed.Internal+    Data.Set.Unlifted.Internal   ghc-options: -O2 -Wall   default-language: Haskell2010 @@ -60,13 +86,18 @@   main-is: Main.hs   build-depends:       base+    , HUnit     , QuickCheck-    , containers+    , aeson+    , containers >= 0.5.10     , primitive     , primitive-containers+    , quantification >= 0.4     , quickcheck-classes >= 0.4.12     , tasty+    , tasty-hunit     , tasty-quickcheck+    , text   ghc-options: -Wall -O2   default-language: Haskell2010
+ src/Data/Continuous/Set/Internal.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+module Data.Continuous.Set.Internal+  ( Set(..)+  , Inclusivity(..)+  , empty+  , universe+  , null+  , universal+  , singleton+  , append+  , member+  , equals+  , showsPrec+  ) where++import Prelude hiding (lookup,showsPrec,concat,map,foldr,negate,null)++import Control.Monad.ST (ST,runST)+import Data.Bool (bool)+import Data.Word (Word8)+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)+import Data.Primitive (PrimArray,MutablePrimArray)+import Data.Bits (unsafeShiftL,unsafeShiftR,(.|.),(.&.))+import qualified Data.Foldable as F+import qualified Prelude as P+import qualified Data.Primitive.Contiguous as I+import qualified Data.Concatenation as C++-- Although the data constructor for this type is exported,+-- it isn't needed by anything in the continuous Set modules. It is needed+-- by the continuous Map modules to implement conversion functions.+--+-- All ranges in the set must be in order. Also, the set containing+-- everything must be represented with SetAll.+data Set arr a = Set+  -- (Maybe (Inclusivity,a)) -- negative infinity upper bound+  !(arr a) -- pairs of keys, last two keys are neg-inf upper and pos-inf lower, in that order+  !(PrimArray Word8) -- pairs of inclusive/exclusive, last element is edge information+  -- (Maybe (Inclusivity,a)) -- positive infinite lower bound++-- note: do not reorder these data constructors. Functions in+-- this module rely on the generated Ord instance.+data Inclusivity = Exclusive | Inclusive+  deriving (Eq,Ord,Show,Read)++data Edge+  = EdgeInclusive+  | EdgeExclusive+  | EdgeAbsent+  | EdgeUniversal++equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool+equals (Set keys1 incs1) (Set keys2 incs2) =+  I.equals keys1 keys2 && incs1 == incs2++empty :: Contiguous arr => Set arr a+empty = Set I.empty $ runST $ do+  marr <- I.new 1+  I.write marr 0 (edgePairToWord8 EdgeAbsent EdgeAbsent)+  I.unsafeFreeze marr++universe :: Contiguous arr => Set arr a+universe = Set I.empty $ runST $ do+  marr <- I.new 1+  I.write marr 0 (edgePairToWord8 EdgeUniversal EdgeUniversal)+  I.unsafeFreeze marr++-- If the keys are null, then we know that there is only one+-- element in the inclusivity array.+null :: Contiguous arr => Set arr a -> Bool+null (Set keys incs) = I.null keys+  && I.index incs 0 == edgePairToWord8 EdgeAbsent EdgeAbsent++universal :: Contiguous arr => Set arr a -> Bool+universal (Set keys incs) = I.null keys+  && I.index incs 0 == edgePairToWord8 EdgeUniversal EdgeUniversal++singleton :: (Contiguous arr, Element arr a, Ord a)+  => Maybe (Inclusivity,a) -- ^ lower bound, @Nothing@ means @-∞@+  -> Maybe (Inclusivity,a) -- ^ upper bound, @Nothing@ means @+∞@+  -> Set arr a+singleton Nothing Nothing = universe+singleton Nothing (Just (incHi,hi)) = runST $ do+  keys <- I.replicateM 1 hi >>= I.unsafeFreeze+  incs <- I.replicateM 1 (edgePairToWord8 (inclusivityToEdge incHi) EdgeAbsent) >>= I.unsafeFreeze+  return (Set keys incs)+singleton (Just (incLo,lo)) Nothing = runST $ do+  keys <- I.replicateM 1 lo >>= I.unsafeFreeze+  incs <- I.replicateM 1 (edgePairToWord8 EdgeAbsent (inclusivityToEdge incLo)) >>= I.unsafeFreeze+  return (Set keys incs)+singleton (Just (incLo,lo)) (Just (incHi,hi)) = case compare lo hi of+  GT -> empty+  EQ -> if incLo == Inclusive && incHi == Inclusive+    then runST $ do+      keys <- I.replicateM 2 lo >>= I.unsafeFreeze+      incsMut <- I.new 2+      I.write incsMut 0 (inclusivityPairToWord8 Inclusive Inclusive)+      I.write incsMut 1 (edgePairToWord8 EdgeAbsent EdgeAbsent)+      incs <- I.unsafeFreeze incsMut+      return (Set keys incs)+    else empty+  LT -> unsafeSingleton incLo lo incHi hi++-- the caller must ensure that lo is less than hi+unsafeSingleton :: (Contiguous arr, Element arr a) => Inclusivity -> a -> Inclusivity -> a -> Set arr a+unsafeSingleton incLo lo incHi hi = runST $ do+  keysMut <- I.replicateM 2 lo+  I.write keysMut 1 hi+  keys <- I.unsafeFreeze keysMut+  incsMut <- I.new 2+  I.write incsMut 0 (inclusivityPairToWord8 incLo incHi)+  I.write incsMut 1 (edgePairToWord8 EdgeAbsent EdgeAbsent)+  incs <- I.unsafeFreeze incsMut+  return (Set keys incs)++except :: (Contiguous arr, Element arr a) => a -> Set arr a+except x = Set keys incs where+  keys = runST $ I.replicateM 2 x >>= I.unsafeFreeze+  incs = runST $ do+    m <- I.new 1+    I.write m 0 (edgePairToWord8 EdgeExclusive EdgeExclusive)+    I.unsafeFreeze m++infinities :: (Contiguous arr, Element arr a, Ord a)+  => Inclusivity+  -> a -- ^ upper bound for negative infinity+  -> Inclusivity+  -> a -- ^ lower bound for positive infinite+  -> Set arr a+infinities negInfHiInc negInfHi posInfLoInc posInfLo =+  case compare negInfHi posInfLo of+    GT -> universe+    EQ -> if negInfHiInc == Exclusive && posInfLoInc == Exclusive+      then except negInfHi+      else universe+    LT -> unsafeInfinities negInfHiInc negInfHi posInfLoInc posInfLo++-- the caller must ensure that the upper bound for neg-inf is+-- less than the lower bound for pos inf+unsafeInfinities :: (Contiguous arr, Element arr a) => Inclusivity -> a -> Inclusivity -> a -> Set arr a+unsafeInfinities negInfHiInc negInfHi posInfLoInc posInfLo = runST $ do+  keysMut <- I.replicateM 2 negInfHi+  I.write keysMut 1 posInfLo+  keys <- I.unsafeFreeze keysMut+  incsMut <- I.new 1+  I.write incsMut 0 (edgePairToWord8 (inclusivityToEdge negInfHiInc) (inclusivityToEdge posInfLoInc))+  incs <- I.unsafeFreeze incsMut+  return (Set keys incs)++append :: forall arr a. (Ord a, Contiguous arr, Element arr a) => Set arr a -> Set arr a -> Set arr a+append s1@(Set keys1 incs1) s2@(Set keys2 incs2)+  | null s1 = s2+  | null s2 = s1+  | universal s1 = s1+  | universal s2 = s2+  | pairsCount1 == 0 && pairsCount2 == 0 = case lowerPair1 of+      Nothing -> case upperPair1 of+        Nothing -> error (errMsg 9)+        Just (posInfLoInc1,posInfLo1) -> case lowerPair2 of+          Nothing -> case upperPair2 of+            Just (posInfLoInc2,posInfLo2) -> case compare posInfLo1 posInfLo2 of+              EQ -> if posInfLoInc1 > posInfLoInc2 then s1 else s2+              GT -> s2+              LT -> s1+      Just (negInfHiInc1,negInfHi1) -> case upperPair1 of+        Nothing -> case lowerPair2 of+          Nothing -> case upperPair2 of+            Nothing -> error (errMsg 1)+            Just (posInfLoInc2,posInfLo2) ->+              case compare negInfHi1 posInfLo2 of+                GT -> universe+                EQ -> if negInfHiInc1 == Inclusive || posInfLoInc2 == Inclusive+                  then universe+                  else except negInfHi1+                LT -> unsafeInfinities negInfHiInc1 negInfHi1 posInfLoInc2 posInfLo2+          Just (negInfHiInc2,negInfHi2) -> case upperPair2 of+            Nothing -> case compare negInfHi1 negInfHi2 of+              EQ -> if negInfHiInc1 > negInfHiInc2 then s1 else s2+              GT -> s1+              LT -> s2+            Just (posInfLoInc2,posInfLo2) -> case compare negInfHi1 negInfHi2 of+              LT -> s2+              EQ -> if negInfHiInc1 > negInfHiInc2+                then infinities negInfHiInc1 negInfHi1 posInfLoInc2 posInfLo2+                else s2+              GT -> infinities negInfHiInc1 negInfHi1 posInfLoInc2 posInfLo2+  | otherwise = runST $ do+      let maxSz = pairsCount1 + pairsCount2 + 1+      keysMut <- I.new (maxSz * 2)+      incsMut <- I.new maxSz+      case lowerPairRes of+        Just (negInfHiIncOriginal,negInfHiOriginal) -> do+          let (negInfHiIncFinal,negInfHiFinal,ixInit1,ixInit2) = eatFromNegativeInfinity negInfHiIncOriginal negInfHiOriginal keys1 incs1 pairsCount1 keys2 incs2 pairsCount2+          case upperPairRes of+            Just (posInfLoIncOriginal,posInfLoOriginal) -> do+              let (posInfLoIncFinal,posInfLoFinal,ixLast1,ixLast2) = eatFromPositiveInfinity posInfLoIncOriginal posInfLoOriginal keys1 incs1 pairsCount1 keys2 incs2 pairsCount2+              finalIx <- go keysMut incsMut ixInit1 ixLast1 ixInit2 ixLast2 0 negInfHiIncFinal negInfHiFinal+              I.write incsMut finalIx (edgePairToWord8 (inclusivityToEdge negInfHiIncFinal) (inclusivityToEdge posInfLoIncFinal))+              I.write keysMut (finalIx * 2) negInfHiFinal+              I.write keysMut (finalIx * 2 + 1) posInfLoFinal+              keysFrozen <- I.resize keysMut (finalIx * 2 + 2) >>= I.unsafeFreeze+              incsFrozen <- I.resize incsMut (finalIx * 1) >>= I.unsafeFreeze+              return (Set keysFrozen incsFrozen)+            Nothing -> error (errMsg 102)+        Nothing -> error (errMsg 101)+  where+  -- do not make these patterns strict+  (lowerPair1,upperPair1,pairsCount1) = edges keys1 incs1+  (lowerPair2,upperPair2,pairsCount2) = edges keys2 incs2+  lowerPairRes = combineNegativeInfinities lowerPair1 lowerPair2+  upperPairRes = combineNegativeInfinities upperPair1 upperPair2+  go :: forall s.+        Mutable arr s a+     -> MutablePrimArray s Word8+     -> Int -- index 1+     -> Int -- index 1 last+     -> Int -- index 2+     -> Int -- index 2 last+     -> Int -- destination index+     -> Inclusivity -- previous inclusivity+     -> a -- previous destination value+     -> ST s Int -- returns size+  go !keysMut !incsMut !ix1 !ixLast1 !ix2 !ixLast2 !ixDst inc a = if ix1 <= ixLast1+    then error (errMsg 103)+    else if ix2 <= ixLast2+      then error (errMsg 104)+      else case upperPair1 of+        Just _ -> error (errMsg 105)+        Nothing -> case upperPair2 of+          Nothing -> return ixDst++combineNegativeInfinities :: Ord a => Maybe (Inclusivity,a) -> Maybe (Inclusivity,a) -> Maybe (Inclusivity,a)+combineNegativeInfinities Nothing Nothing = Nothing+combineNegativeInfinities Nothing x@(Just _) = x+combineNegativeInfinities x@(Just _) Nothing = x+combineNegativeInfinities (Just (xinc,x)) (Just (yinc,y)) = case compare x y of+  GT -> Just (xinc,x)+  LT -> Just (yinc,y)+  EQ -> Just (max xinc yinc,y)+      +eatFromPositiveInfinity ::+     Inclusivity -- inclusivity for positive infinity+  -> a -- lower bound for positive infinity+  -> arr a -- set 1+  -> PrimArray Word8+  -> Int -- pairs in set 1 +  -> arr a -- set 2+  -> PrimArray Word8+  -> Int -- pairs in set 2+  -> (Inclusivity,a,Int,Int) -- index for set 1 and set2, lower bound for positive infinity+eatFromPositiveInfinity = error (errMsg 110)++eatFromNegativeInfinity :: (Contiguous arr, Element arr a, Ord a)+  => Inclusivity -- inclusivity for negative infinity+  -> a -- upper bound for negative infinity+  -> arr a -- set 1+  -> PrimArray Word8+  -> Int -- pairs in set 1 +  -> arr a -- set 2+  -> PrimArray Word8+  -> Int -- pairs in set 2+  -> (Inclusivity,a,Int,Int) -- index for set 1 and set2, upper bound for negative infinity+eatFromNegativeInfinity negInfInc0 negInfHi0 keys1 incs1 sz1 keys2 incs2 sz2 = go negInfInc0 negInfHi0 0 0+  where+  go negInfHiInc negInfHi !ix1 !ix2 = if ix1 < sz1+    then error (errMsg 111)+    else if ix2 < sz2+      then let (# lo #) = I.index# keys2 (ix2 * 2)+               (# hi #) = I.index# keys2 (ix2 * 2 + 1)+               (loInc,hiInc) = indexInclusivityPair incs2 ix2+            in case compare negInfHi lo of+                 LT -> (negInfHiInc,negInfHi,ix1,ix2)+                 GT -> case compare negInfHi hi of+                   LT -> go hiInc hi ix1 (ix2 + 1)+                   GT -> go negInfHiInc negInfHi ix1 (ix2 + 1)+                   EQ -> go (max hiInc negInfHiInc) hi ix1 (ix2 + 1)+                 EQ -> if negInfHiInc == Exclusive && loInc == Exclusive+                   then (Exclusive,negInfHi,ix1,ix2)+                   else case compare negInfHi hi of+                     LT -> go hiInc hi ix1 (ix2 + 1)+                     GT -> go negInfHiInc negInfHi ix1 (ix2 + 1)+                     EQ -> go (max hiInc negInfHiInc) hi ix1 (ix2 + 1)+      else (negInfHiInc,negInfHi,ix1,ix2)++inclusivityToEdge :: Inclusivity -> Edge+inclusivityToEdge Inclusive = EdgeInclusive+inclusivityToEdge Exclusive = EdgeExclusive++inclusivityToWord8 :: Inclusivity -> Word8+inclusivityToWord8 Inclusive = 0+inclusivityToWord8 Exclusive = 1++inclusivityPairToWord8 :: Inclusivity -> Inclusivity -> Word8+inclusivityPairToWord8 a b =+      unsafeShiftL (inclusivityToWord8 a) 1+  .|. inclusivityToWord8 b++word8ToInclusivity :: Word8 -> Inclusivity+word8ToInclusivity 0 = Inclusive+word8ToInclusivity _ = Exclusive++indexInclusivityPair :: PrimArray Word8 -> Int -> (Inclusivity,Inclusivity)+indexInclusivityPair xs ix = case I.index xs ix of+  0 -> (Inclusive,Inclusive)+  1 -> (Inclusive,Exclusive)+  2 -> (Exclusive,Inclusive)+  _ -> (Exclusive,Exclusive)++edgeToWord8 :: Edge -> Word8+edgeToWord8 EdgeInclusive = 0+edgeToWord8 EdgeExclusive = 1+edgeToWord8 EdgeAbsent = 2+edgeToWord8 EdgeUniversal = 3++word8ToEdge :: Word8 -> Edge+word8ToEdge x = case x of+  0 -> EdgeInclusive+  1 -> EdgeExclusive+  2 -> EdgeAbsent+  _ -> EdgeUniversal++edgePairToWord8 :: Edge -> Edge -> Word8+edgePairToWord8 a b = unsafeShiftL (edgeToWord8 a) 2 .|. edgeToWord8 b++edgeMetadata :: PrimArray Word8 -> (Edge,Edge)+edgeMetadata xs = (word8ToEdge (unsafeShiftR w 2), word8ToEdge (0b00000011 .&. w))+  where+  w = I.index xs (I.size xs - 1)++-- please check for EdgeUniversal before calling this function. The+-- resulting triple includes the size of the keys array in pairs. The+-- divisions used internally here should always divide two evenly.+edges :: (Contiguous arr, Element arr a)+  => arr a+  -> PrimArray Word8+  -> (Maybe (Inclusivity,a), Maybe (Inclusivity,a),Int)+edges keys incs = case edgeMetadata incs of+  (lower,upper) -> case lower of+    EdgeUniversal -> error (errMsg 2)+    EdgeAbsent -> case upper of+      EdgeInclusive -> (Nothing,Just (Inclusive,I.index keys (sz - 1)),div (sz - 1) 2)+      EdgeExclusive -> (Nothing,Just (Exclusive,I.index keys (sz - 1)),div (sz - 1) 2)+      EdgeAbsent -> (Nothing,Nothing,div sz 2)+      _ -> error (errMsg 3)+    EdgeInclusive -> case upper of+      EdgeInclusive -> (Just (Inclusive,I.index keys (sz - 2)),Just (Inclusive,I.index keys (sz - 1)),div (sz - 2) 2)+      EdgeExclusive -> (Just (Inclusive,I.index keys (sz - 2)),Just (Exclusive,I.index keys (sz - 1)),div (sz - 2) 2)+      EdgeAbsent -> (Just (Inclusive,I.index keys (sz - 1)),Nothing,div (sz - 1) 2)+      EdgeUniversal -> error (errMsg 4)+    EdgeExclusive -> case upper of+      EdgeInclusive -> (Just (Exclusive,I.index keys (sz - 2)),Just (Inclusive,I.index keys (sz - 1)),div (sz - 2) 2)+      EdgeExclusive -> (Just (Exclusive,I.index keys (sz - 2)),Just (Exclusive,I.index keys (sz - 1)),div (sz - 2) 2)+      EdgeAbsent -> (Just (Exclusive,I.index keys (sz - 1)),Nothing,div (sz - 1) 2)+      EdgeUniversal -> error (errMsg 5)+  where+  sz = I.size keys++member :: forall arr a. (Contiguous arr, Element arr a, Ord a)+  => a+  -> Set arr a+  -> Bool+member val (Set keys incs) = case edges keys incs of+  (!mnegInfHi,!mposInfLo,!n) ->+    case mnegInfHi of+      Nothing -> case mposInfLo of+        Nothing -> go 0 (n - 1)+        Just (!posInfLoInc,!posInfLo) -> case compare val posInfLo of+          GT -> True+          LT -> go 0 (n - 1)+          EQ -> posInfLoInc == Inclusive+      Just (!negInfHiInc,!negInfHi) -> case mposInfLo of+        Nothing -> case compare val negInfHi of+          LT -> True+          GT -> go 0 (n - 1)+          EQ -> negInfHiInc == Inclusive+        Just (!posInfLoInc,!posInfLo) -> case compare val posInfLo of+          GT -> True+          LT -> case compare val negInfHi of+            GT -> go 0 (n - 1)+            LT -> True+            EQ -> negInfHiInc == Inclusive+          EQ -> posInfLoInc == Inclusive+  where+  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 case indexInclusivityPair incs start of+              (Exclusive,Exclusive) -> val > valLo && val < valHi+              (Exclusive,Inclusive) -> val > valLo && val <= valHi+              (Inclusive,Exclusive) -> val >= valLo && val < valHi+              (Inclusive,Inclusive) -> val >= valLo && val <= valHi+      else False+    else+      let !mid = div (end + start + 1) 2+          !valLo = I.index keys (2 * mid)+       in case P.compare val valLo of+            LT -> go start (mid - 1)+            EQ -> True+            GT -> go mid end+{-# INLINEABLE member #-}++errMsg :: Int -> String+errMsg n = "Data.Continuous.Set.Internal: invariant " ++ show n ++ " violated"++toPairs :: (Contiguous arr, Element arr a) => Int -> Set arr a -> [(Inclusivity,a,Inclusivity,a)]+toPairs n (Set keys incs) = go 0 where+  go !ix = if ix < n+    then+      let (incLo,incHi) = indexInclusivityPair incs ix+          lo = I.index keys (2 * ix)+          hi = I.index keys (2 * ix + 1)+       in (incLo,lo,incHi,hi) : go (ix + 1)+    else []++showsPrec :: (Contiguous arr, Element arr a, Show a)+  => Int+  -> Set arr a+  -> ShowS+showsPrec _ s@(Set keys incs)+  | null s = showString "{}"+  | universal s = showString "{(-∞,+∞)}"+  | otherwise = showChar '{' . showListInf shows lowerPair (toPairs pairsCount s) upperPair . showChar '}'+  where+  -- do not make these patterns strict+  (lowerPair,upperPair,pairsCount) = edges keys incs++showListInf :: (a -> ShowS) -> Maybe (Inclusivity,a) -> [(Inclusivity,a,Inclusivity,a)] -> Maybe (Inclusivity,a) -> ShowS+showListInf showx mnegInfHi [] mposInfLo s = case mnegInfHi of+  Nothing -> case mposInfLo of+    Nothing -> s+    Just (posInfLoInc,posInfLo) -> showPosInfLo showx posInfLoInc posInfLo s+  Just (negInfHiInc,negInfHi) -> case mposInfLo of+    Nothing -> showNegInfHi showx negInfHiInc negInfHi s+    Just (posInfLoInc,posInfLo) -> showChar '{'+      $ showNegInfHi showx negInfHiInc negInfHi+      $ showChar ','+      $ showPosInfLo showx posInfLoInc posInfLo+      $ showChar '}'+      $ s+showListInf showx mnegInfHi ((ainc0,a0,binc0,b0):xs) mposInfLo s =+  maybe id (\(negInfHiInc,negInfHi) s' -> showNegInfHi showx negInfHiInc negInfHi (',' : s')) mnegInfHi (case ainc0 of {Inclusive -> '[';Exclusive -> '('} : showx a0 (',' : showx b0 (case binc0 of {Inclusive -> ']'; Exclusive -> ')'} : showl xs)))+  where+    showl [] = maybe id (\(posInfLoInc,posInfLo) -> showChar ',' . showPosInfLo showx posInfLoInc posInfLo) mposInfLo (']' : s)+    showl ((ainc,a,binc,b):ys) = ',' : case ainc of {Inclusive -> '[';Exclusive -> '('} : showx a (',' : showx b (case binc of {Inclusive -> ']'; Exclusive -> ')'} : showl ys))++showNegInfHi :: (a -> ShowS) -> Inclusivity -> a -> ShowS+showNegInfHi showx inc x s = "(-∞," ++ showx x ((case inc of { Inclusive -> ']'; Exclusive -> ')'} : s))++showPosInfLo :: (a -> ShowS) -> Inclusivity -> a -> ShowS+showPosInfLo showx inc x s = case inc of { Inclusive -> '['; Exclusive -> '('} : (showx x (",+∞)" ++ s))+
+ src/Data/Continuous/Set/Lifted.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Continuous.Set.Lifted+  ( Set+  , Inclusivity(..)+  , singleton+  , member+  , empty+  , universe+  , null+  , universal+  ) where++import Prelude hiding (lookup,map,foldr,negate,null)++import Data.Semigroup (Semigroup)+import Data.Primitive (Array)+import Data.Continuous.Set.Internal (Inclusivity(..))+import qualified Data.Semigroup as SG+import qualified Data.Continuous.Set.Internal as I++-- | A diet set. Currently, the data constructor for this type is+-- exported. Please do not use it. It will be moved to an internal+-- module at some point.+newtype Set a = Set (I.Set Array a)++-- | /O(1)/ Create a continuous interval set with a single interval.+singleton :: Ord a+  => Maybe (Inclusivity,a) -- ^ lower bound+  -> Maybe (Inclusivity,a) -- ^ 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 continuous+-- interval set.+member :: Ord a => a -> Set a -> Bool+member a (Set s) = I.member a s++empty :: Set a+empty = Set I.empty++universe :: Set a+universe = Set I.universe++null :: Set a -> Bool+null (Set s) = I.null s++universal :: Set a -> Bool+universal (Set s) = I.universal 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) => 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.<>)+
+ src/Data/Dependent/Map/Class.hs view
@@ -0,0 +1,78 @@+{-# language ConstraintKinds #-}+{-# language CPP #-}+{-# language ExistentialQuantification #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MagicHash #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}+{-# language TypeFamilyDependencies #-}+{-# language TypeInType #-}+{-# language UnboxedTuples #-}++-- I really do not like the typeclasses defined in this module.+-- With the QuantifiedConstraints extension (in GHC 8.6), we should+-- be able to get rid of this entire module. But we will want to+-- wait a while before doing that.+module Data.Dependent.Map.Class+  ( Apply(..)+  , Universally(..)+  , ApplyUniversally(..)+  ) where++import Data.Kind (Type,Constraint)+import Data.Proxy (Proxy(..))+import Data.Exists (OrdForall(..),EqForall(..),PrimForall(..))+import Data.Primitive (Prim(..))+import Data.Primitive.Contiguous (Always)+import Data.Primitive.UnliftedArray (PrimUnlifted(..))+import GHC.Exts++newtype Apply f a = Apply (f a)++class ApplyUniversally (f :: k -> Type) (x :: Type -> Constraint) where+  applyUniversallyLifted :: forall a y. Proxy f -> Proxy x -> Proxy a -> (x (f a) => y) -> y+#if MIN_VERSION_base(4,10,0) +  applyUniversallyUnlifted :: forall a (y :: TYPE 'UnliftedRep). Proxy f -> Proxy x -> Proxy a -> (x (f a) => y) -> y+#else+  applyUniversallyUnlifted :: forall a (y :: TYPE 'PtrRepUnlifted). Proxy f -> Proxy x -> Proxy a -> (x (f a) => y) -> y+#endif++class Universally (f :: k -> Type) (x :: Type -> Constraint) where+  universally :: Proxy f -> Proxy x -> Proxy a -> (x (Apply f a) => y) -> y++instance ApplyUniversally f PrimUnlifted => PrimUnlifted (Apply f a) where+  toArrayArray# (Apply v) = applyUniversallyUnlifted (Proxy :: Proxy f) (Proxy :: Proxy PrimUnlifted) (Proxy :: Proxy a) (toArrayArray# v)+  fromArrayArray# a = applyUniversallyLifted (Proxy :: Proxy f) (Proxy :: Proxy PrimUnlifted) (Proxy :: Proxy a) (fromArrayArray# a)++instance EqForall f => Eq (Apply f a) where+  Apply x == Apply y = eqForall x y++instance OrdForall f => Ord (Apply f a) where+  compare (Apply x) (Apply y) = compareForall x y++instance PrimForall f => Prim (Apply f a) where+  sizeOf# _ = sizeOfForall# (proxy# :: Proxy# f)+  alignment# _ = alignmentForall# (proxy# :: Proxy# f)+  indexByteArray# = coerce (indexByteArrayForall# :: ByteArray# -> Int# -> f a)+  readByteArray# = coerce (readByteArrayForall# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, f a #) )+  writeByteArray# = coerce (writeByteArrayForall# :: MutableByteArray# s -> Int# -> f a -> State# s -> State# s )+  setByteArray# = coerce (setByteArrayForall# :: MutableByteArray# s -> Int# -> Int# -> f a -> State# s -> State# s )+  indexOffAddr# = coerce (indexOffAddrForall# :: Addr# -> Int# -> f a)+  readOffAddr# = coerce (readOffAddrForall# :: Addr# -> Int# -> State# s -> (# State# s, f a #) )+  writeOffAddr# = coerce (writeOffAddrForall# :: Addr# -> Int# -> f a -> State# s -> State# s)+  setOffAddr# = coerce (setOffAddrForall# :: Addr# -> Int# -> Int# -> f a -> State# s -> State# s)++instance Universally f Always where+  universally _ _ _ y = y++instance ApplyUniversally f Always where+  applyUniversallyLifted _ _ _ y = y+  applyUniversallyUnlifted _ _ _ y = y++instance ApplyUniversally f PrimUnlifted => Universally f PrimUnlifted where+  universally _ _ _ y = y+
+ src/Data/Dependent/Map/Internal.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Dependent.Map.Internal+  ( Map(..)+  , empty+  , null+  , singleton+  , lookup+  , fromList+  , fromListN+  , map+  , mapWithKey+  , mapMaybe+  , mapMaybeWithKey+  , appendRightBiased+  , append+  , toList+  , showsPrec+  , equals+  , compare+  , unsafeFreezeZip+  , toJSON+  , parseJSON+  , foldrWithKey+  , foldlWithKeyM'+  , foldMapWithKey+  , traverseWithKey_+  , size+  ) where++import Prelude hiding (lookup,showsPrec,compare,null,map)++import Data.Dependent.Map.Class (Universally,Apply,ApplyUniversally)+import Data.Primitive.Contiguous (Contiguous,Mutable,Element)+import Control.Monad.ST (ST,runST)+import Data.Proxy (Proxy(..))+import GHC.Exts (Any,coerce)+import Unsafe.Coerce (unsafeCoerce)+import Data.Exists (OrdForallPoly(..),EqForallPoly(..),DependentPair(..),ShowForall,ToSing)+import Data.Exists (ShowForeach,EqForeach,OrdForeach,ToJSONKeyForall,FromJSONForeach)+import Data.Exists (ToJSONForall,ToJSONKeyFunctionForall,ToJSONForeach)+import Data.Exists (FromJSONKeyExists,SemigroupForeach,Sing)+import Data.Semigroup (Semigroup)+import Data.Primitive.Sort (sortUniqueTaggedMutable)+import Data.Kind (Type)+import Data.Aeson (ToJSON,FromJSON)+import Data.Text (Text)+import qualified Data.Vector as V+import qualified Data.Exists as EX+import qualified Data.Aeson as AE+import qualified Data.Aeson.Types as AET+import qualified Data.HashMap.Strict as HM+import qualified Prelude as P+import qualified Data.Map.Internal as I+import qualified Data.Primitive.Contiguous as I+import qualified Data.Dependent.Map.Class as C+import qualified Data.Map.Internal as M+import qualified Data.Foldable as F++newtype Map karr varr (k :: u -> Type) (v :: u -> Type) = Map (M.Map karr varr (Apply k Any) (v Any))++empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v+empty = Map M.empty++null :: forall karr varr k v. (Contiguous varr) => Map karr varr k v -> Bool+null (Map m) = M.null m++singleton :: forall karr varr k v a.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))+  => k a -> v a -> Map karr varr k v+singleton k v = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.singleton (wrapKey k) (wrapValue (Proxy :: Proxy v) (Proxy :: Proxy a) v))++toJSON :: forall karr varr k v.+     (ToJSONKeyForall k, ToJSONForeach v, ToSing k, Contiguous karr, Contiguous varr,ApplyUniversally v (Element varr),Universally k (Element karr))+  => Map karr varr k v+  -> AE.Value+toJSON (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ case EX.toJSONKeyForall :: ToJSONKeyFunctionForall k of+      EX.ToJSONKeyValueForall toValue _ -> AE.Array $ V.fromListN+        ( M.size m )+        ( M.foldrWithKey+          ( \(C.Apply k) v xs -> AE.toJSON (toValue k,EX.toJSONForeach (EX.toSing k) v) : xs+          ) [] m+        )+      EX.ToJSONKeyTextForall toText _ -> AE.Object+        ( M.foldlWithKey'+          ( \hm (C.Apply k) v -> HM.insert (toText k) (EX.toJSONForeach (EX.toSing k) v) hm+          ) HM.empty m+        )++parseJSON :: forall karr varr k v.+     (FromJSONKeyExists k, ToSing k, OrdForallPoly k, FromJSONForeach v, Contiguous karr, Contiguous varr, ApplyUniversally v (Element varr),Universally k (Element karr),ApplyUniversally k (Element karr))+  => AE.Value+  -> AET.Parser (Map karr varr k v)+parseJSON theValue =+  case EX.fromJSONKeyExists :: AE.FromJSONKeyFunction (EX.Exists k) of+    AE.FromJSONKeyCoerce _ -> error "Data.Dependent.Map.Internal.fromJSON: this cannot happen"+    AE.FromJSONKeyText fromText -> AET.withObject "DependentMap"+      (fmap fromList . HM.foldrWithKey (f1 fromText) (return []))+      theValue+    AE.FromJSONKeyTextParser fromText -> AET.withObject "DependentMap"+      (fmap fromList . HM.foldrWithKey (f2 fromText) (return []))+      theValue+    AE.FromJSONKeyValue fromValue -> AET.withArray "DependentMap"+      (fmap fromList . F.foldlM (f3 fromValue) [])+      theValue+  where+  f1 :: (Text -> EX.Exists k) -> Text -> AE.Value -> AET.Parser [DependentPair k v] -> AET.Parser [DependentPair k v]+  f1 fromText keyText valRaw m = case fromText keyText of+    EX.Exists key -> do+      let keySing = EX.toSing key+      val <- EX.parseJSONForeach keySing valRaw+      dm <- m+      return (DependentPair key val : dm)+  f2 :: (Text -> AET.Parser (EX.Exists k)) -> Text -> AE.Value -> AET.Parser [DependentPair k v] -> AET.Parser [DependentPair k v]+  f2 fromText keyText valRaw m = do+    EX.Exists key <- fromText keyText+    let keySing = EX.toSing key+    val <- EX.parseJSONForeach keySing valRaw+    dm <- m+    return (DependentPair key val : dm)+  f3 :: (AE.Value -> AET.Parser (EX.Exists k)) -> [DependentPair k v] -> AE.Value -> AET.Parser [DependentPair k v]+  f3 fromValue dm pairRaw = do+    (keyRaw :: AE.Value,valRaw :: AE.Value) <- AE.parseJSON pairRaw+    EX.Exists key <- fromValue keyRaw+    let keySing = EX.toSing key+    val <- EX.parseJSONForeach keySing valRaw+    return (DependentPair key val : dm)+++        ++lookup :: forall karr varr k v a.+     (OrdForallPoly k, Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))+  => k a+  -> Map karr varr k v+  -> Maybe (v a)+{-# INLINABLE lookup #-}+lookup k (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ case M.lookup (wrapKey k) m of+      Nothing -> Nothing+      Just v -> Just (unwrapValue (Proxy :: Proxy v) (Proxy :: Proxy a) v)++appendWith :: forall karr varr k v.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, ToSing k)+  => (forall a. Sing a -> v a -> v a -> v a)+  -> Map karr varr k v+  -> Map karr varr k v+  -> Map karr varr k v+appendWith f (Map m1) (Map m2) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.appendKeyWith (\(C.Apply k) v1 v2 -> f (EX.toSing k) v1 v2) m1 m2)++append :: forall karr varr k v.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, SemigroupForeach v, ToSing k)+  => Map karr varr k v+  -> Map karr varr k v+  -> Map karr varr k v+append = appendWith EX.appendForeach++appendRightBiased :: forall karr varr k v.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)+  => Map karr varr k v+  -> Map karr varr k v+  -> Map karr varr k v+appendRightBiased (Map m1) (Map m2) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.appendRightBiased m1 m2)++wrapKeyUnapplied :: f k -> f Any+wrapKeyUnapplied = unsafeCoerce++wrapKey :: f k -> Apply f Any+wrapKey = unsafeCoerce++wrapValue :: Proxy v -> Proxy a -> v a -> v Any+wrapValue _ _ = unsafeCoerce++unwrapValue :: Proxy v -> Proxy a -> v Any -> v a+unwrapValue _ _ = unsafeCoerce++unsafeCoerceMutableKeyArray ::+     Mutable karr s (f Any)+  -> Mutable karr s (Apply f Any)+unsafeCoerceMutableKeyArray = unsafeCoerce++fromList ::+     (Contiguous karr, ApplyUniversally k (Element karr), Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)+  => [DependentPair k v]+  -> Map karr varr k v+fromList = fromListN 1++fromListN ::+     (Contiguous karr, ApplyUniversally k (Element karr), Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)+  => Int+  -> [DependentPair k v]+  -> Map karr varr k v+{-# INLINABLE fromListN #-}+fromListN n xs = runST $ do+  (ks,vs) <- mutableArraysFromPairs (max n 1) xs+  unsafeFreezeZip ks vs++-- | This function is really unsafe. The user needs to use unsafeCoerce to even use it.+unsafeFreezeZip :: forall karr varr k v s.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)+  => Mutable karr s (k Any)+  -> Mutable varr s (v Any)+  -> ST s (Map karr varr k v)+{-# INLINABLE unsafeFreezeZip #-}+unsafeFreezeZip keys0 vals0 = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ fmap Map (M.unsafeFreezeZip (unsafeCoerceMutableKeyArray keys0) vals0)++mutableArraysFromPairs :: forall karr varr k v s.+     (Contiguous karr, ApplyUniversally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)+  => Int -- must be at least one+  -> [DependentPair k v]+  -> ST s (Mutable karr s (k Any), Mutable varr s (v Any))+{-# INLINABLE mutableArraysFromPairs #-}+mutableArraysFromPairs n xs = id+  $ C.applyUniversallyLifted (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ do+    let go :: Int+           -> Int+           -> Mutable karr s (k Any)+           -> Mutable varr s (v Any)+           -> [DependentPair k v]+           -> ST s (Int,Mutable karr s (k Any),Mutable varr s (v Any))+        go !ix !_ !ks !vs [] = return (ix,ks,vs)+        go !ix !len !ks !vs (DependentPair k v : ys) = if ix < len+          then do+            I.write ks ix (wrapKeyUnapplied k)+            I.write vs ix (wrapValue (Proxy :: Proxy v) Proxy v)+            go (ix + 1) len ks vs ys+          else do+            let len' = len * 2+            ks' <- I.new len'+            vs' <- I.new len'+            I.copyMutable ks' 0 ks 0 len+            I.copyMutable vs' 0 vs 0 len+            I.write ks' ix (wrapKeyUnapplied k)+            I.write vs' ix (wrapValue (Proxy :: Proxy v) Proxy v)+            go (ix + 1) len' ks' vs' ys+    ks0 <- I.new n+    vs0 <- I.new n+    (len,ks',vs') <- go 0 n ks0 vs0 xs+    ksFinal <- I.resize ks' len+    vsFinal <- I.resize vs' len+    return (ksFinal,vsFinal)++foldrWithKey :: forall karr varr k v b.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))+  => (forall a. k a -> v a -> b -> b)+  -> b+  -> Map karr varr k v+  -> b+foldrWithKey f z (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ M.foldrWithKey (unsafeCoerceRightFoldFunction f) z m++foldMapWithKey :: forall karr varr k v m.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), Monoid m)+  => (forall a. k a -> v a -> m)+  -> Map karr varr k v+  -> m+foldMapWithKey f (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ M.foldMapWithKey (unsafeCoerceFoldMapFunction f) m++traverseWithKey_ :: forall karr varr k v m b.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), Applicative m)+  => (forall a. k a -> v a -> m b)+  -> Map karr varr k v+  -> m ()+traverseWithKey_ f (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ M.traverseWithKey_ (unsafeCoerceFoldMapFunction f) m++foldlWithKeyM' :: forall karr varr k v m b.+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), Monad m)+  => (forall a. b -> k a -> v a -> m b)+  -> b+  -> Map karr varr k v+  -> m b+foldlWithKeyM' f z (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ M.foldlWithKeyM' (unsafeCoerceLeftFoldFunctionM f) z m++toList :: +     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))+  => Map karr varr k v+  -> [DependentPair k v]+toList = foldrWithKey (\k v xs -> DependentPair k v : xs) []++unsafeCoerceMapMaybeWithKeyFunction ::+     (forall a. k a -> v a -> Maybe (w a))+  -> Apply k Any -> v Any -> Maybe (w Any)+unsafeCoerceMapMaybeWithKeyFunction = unsafeCoerce++unsafeCoerceMapWithKeyFunction ::+     (forall a. k a -> v a -> w a)+  -> Apply k Any -> v Any -> w Any+unsafeCoerceMapWithKeyFunction = unsafeCoerce++unsafeCoerceLeftFoldFunctionM :: +     (forall a. b -> k a -> v a -> m b)+  -> b -> Apply k Any -> v Any -> m b+unsafeCoerceLeftFoldFunctionM = unsafeCoerce++unsafeCoerceRightFoldFunction :: +     (forall a. k a -> v a -> b -> b)+  -> Apply k Any -> v Any -> b -> b+unsafeCoerceRightFoldFunction = unsafeCoerce++unsafeCoerceFoldMapFunction :: +     (forall a. k a -> v a -> m)+  -> Apply k Any -> v Any -> m+unsafeCoerceFoldMapFunction = unsafeCoerce++showsPrec :: (Contiguous karr, Universally k (Element karr), ShowForall k, ShowForeach v, ToSing k, Contiguous varr, ApplyUniversally v (Element varr))+  => Int -> Map karr varr k v -> ShowS+showsPrec p xs = showParen (p > 10) $+  showString "fromList " . shows (toList xs)++equals :: (Contiguous karr, Universally k (Element karr), EqForallPoly k, EqForeach v, ToSing k, Contiguous varr, ApplyUniversally v (Element varr))+  => Map karr varr k v+  -> Map karr varr k v+  -> Bool+equals a b = toList a == toList b++compare :: (Contiguous karr, Universally k (Element karr), OrdForallPoly k, OrdForeach v, ToSing k, Contiguous varr, ApplyUniversally v (Element varr))+  => Map karr varr k v+  -> Map karr varr k v+  -> Ordering+compare a b = P.compare (toList a) (toList b)++size :: forall karr varr k v. (Contiguous varr, ApplyUniversally v (Element varr)) => Map karr varr k v -> Int+size (Map m) = id+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ M.size m++map :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))+  => (forall a. v a -> w a)+  -> Map karr varr k v+  -> Map karr varr k w+map f (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.map f m)++mapMaybe :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))+  => (forall a. v a -> Maybe (w a))+  -> Map karr varr k v+  -> Map karr varr k w+mapMaybe f (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.mapMaybe f m)++mapMaybeWithKey :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))+  => (forall a. k a -> v a -> Maybe (w a))+  -> Map karr varr k v+  -> Map karr varr k w+mapMaybeWithKey f (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.mapMaybeWithKey (unsafeCoerceMapMaybeWithKeyFunction f) m)++mapWithKey :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))+  => (forall a. k a -> v a -> w a)+  -> Map karr varr k v+  -> Map karr varr k w+mapWithKey f (Map m) = id+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)+  $ Map (M.mapWithKey (unsafeCoerceMapWithKeyFunction f) m)
+ src/Data/Dependent/Map/Lifted/Lifted.hs view
@@ -0,0 +1,88 @@+{-# language GeneralizedNewtypeDeriving #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language TypeFamilies #-}++module Data.Dependent.Map.Lifted.Lifted+  ( Map+  , singleton+  , lookup+  , toList+  , fromList+  , mapMaybe+  , mapMaybeWithKey+  ) where++import Prelude hiding (lookup)++import Data.Aeson (FromJSON,ToJSON)+import Data.Primitive (Array)+import Data.Semigroup (Semigroup)+import Data.Exists (EqForallPoly,EqForeach,OrdForeach)+import Data.Exists (OrdForallPoly,DependentPair,ShowForall,ShowForeach,ToSing)+import Data.Exists (ToJSONKeyForall,FromJSONKeyExists,ToJSONForeach,SemigroupForeach)+import Data.Exists (FromJSONForeach)+import GHC.Exts (IsList)++import qualified Data.Aeson as AE+import qualified Data.Dependent.Map.Internal as I+import qualified Data.Semigroup as SG+import qualified GHC.Exts++newtype Map k v = Map (I.Map Array Array k v)++singleton :: k a -> v a -> Map k v+singleton f v = Map (I.singleton f v)++lookup :: OrdForallPoly k => k a -> Map k v -> Maybe (v a)+lookup k (Map x) = I.lookup k x++fromList :: OrdForallPoly k => [DependentPair k v] -> Map k v+fromList xs = Map (I.fromList xs)++fromListN :: OrdForallPoly k => Int -> [DependentPair k v] -> Map k v+fromListN n xs = Map (I.fromListN n xs)++toList :: Map k v -> [DependentPair k v]+toList (Map x) = I.toList x++mapMaybe ::+     (forall a. v a -> Maybe (w a))+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++mapMaybeWithKey ::+     (forall a. k a -> v a -> Maybe (w a))+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)++instance OrdForallPoly k => IsList (Map k v) where+  type Item (Map k v) = DependentPair k v+  fromListN = fromListN+  fromList = fromList+  toList = toList+  +instance (ShowForall k, ToSing k, ShowForeach v) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++instance (EqForallPoly k, ToSing k, EqForeach v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (OrdForallPoly k, ToSing k, OrdForeach v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (ToSing k, OrdForallPoly k, SemigroupForeach v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (ToSing k, OrdForallPoly k, SemigroupForeach v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)++instance (ToSing k, ToJSONKeyForall k, ToJSONForeach v) => ToJSON (Map k v) where+  toJSON (Map m) = I.toJSON m++instance (ToSing k, FromJSONKeyExists k, FromJSONForeach v, OrdForallPoly k) => FromJSON (Map k v) where+  parseJSON v = fmap Map (I.parseJSON v)+
+ src/Data/Dependent/Map/Unboxed/Lifted.hs view
@@ -0,0 +1,189 @@+{-# language FlexibleContexts #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language TypeFamilies #-}++module Data.Dependent.Map.Unboxed.Lifted+  ( Map+  , empty+  , null+  , singleton+  , lookup+  , foldrWithKey+  , foldlWithKeyM'+  , foldMapWithKey+  , traverseWithKey_+  , toList+  , fromList+  , map+  , mapWithKey+  , mapMaybe+  , mapMaybeWithKey+  , size+    -- * Unsafe Functions+  , unsafeFreezeZip+  , unsafeCoerceKeys+  ) where++import Prelude hiding (lookup,null,map)++import Control.Monad.ST (ST)+import Data.Aeson (FromJSON,ToJSON)+import Data.Dependent.Map.Class (Universally,ApplyUniversally)+import Data.Exists (EqForallPoly,EqForeach,OrdForeach)+import Data.Exists (OrdForallPoly,DependentPair,ShowForall,ShowForeach,ToSing)+import Data.Exists (ToJSONKeyForall,FromJSONKeyExists,ToJSONForeach,SemigroupForeach)+import Data.Exists (FromJSONForeach)+import Data.Primitive (Array,PrimArray,Prim,MutablePrimArray,MutableArray)+import Data.Proxy (Proxy)+import Data.Semigroup (Semigroup)+import GHC.Exts (IsList,Any)+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.Aeson as AE+import qualified Data.Semigroup as SG+import qualified Data.Dependent.Map.Internal as I+import qualified GHC.Exts+import qualified Data.Set.Unboxed.Internal as SU+import qualified Data.Map.Internal as M++newtype Map k v = Map (I.Map PrimArray Array k v)++empty :: Map k v+empty = Map I.empty++null :: Map k v -> Bool+null (Map m) = I.null m++singleton :: Universally k Prim => k a -> v a -> Map k v+singleton f v = Map (I.singleton f v)++lookup :: (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => k a -> Map k v -> Maybe (v a)+lookup k (Map x) = I.lookup k x++fromList :: (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => [DependentPair k v] -> Map k v+fromList xs = Map (I.fromList xs)++fromListN :: (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => Int -> [DependentPair k v] -> Map k v+fromListN n xs = Map (I.fromListN n xs)++toList :: Universally k Prim => Map k v -> [DependentPair k v]+toList (Map x) = I.toList x++size :: Map k v -> Int+size (Map x) = I.size x++foldrWithKey :: +     Universally k Prim+  => (forall a. k a -> v a -> b -> b)+  -> b+  -> Map k v+  -> b+foldrWithKey f b (Map m) = I.foldrWithKey f b m++foldlWithKeyM' :: +     (Universally k Prim, Monad m)+  => (forall a. b -> k a -> v a -> m b)+  -> b+  -> Map k v+  -> m b+foldlWithKeyM' f b (Map m) = I.foldlWithKeyM' f b m++foldMapWithKey :: +     (Universally k Prim, Monoid m)+  => (forall a. k a -> v a -> m)+  -> Map k v+  -> m+foldMapWithKey f (Map m) = I.foldMapWithKey f m++traverseWithKey_ :: +     (Universally k Prim, Applicative m)+  => (forall a. k a -> v a -> m b)+  -> Map k v+  -> m ()+traverseWithKey_ f (Map m) = I.traverseWithKey_ f m++map ::+     Universally k Prim+  => (forall a. v a -> w a)+  -> Map k v+  -> Map k w+map f (Map m) = Map (I.map f m)++mapMaybe ::+     Universally k Prim+  => (forall a. v a -> Maybe (w a))+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++mapMaybeWithKey ::+     Universally k Prim+  => (forall a. k a -> v a -> Maybe (w a))+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)++mapWithKey ::+     Universally k Prim+  => (forall a. k a -> v a -> w a)+  -> Map k v+  -> Map k w+mapWithKey f (Map m) = Map (I.mapWithKey f m)++-- | This function is even more unsafe than the @unsafeFreezeZip@ provided by+-- @Data.Map.Unboxed.Lifted@. The user needs to use @unsafeCoerce@ to even use this+-- function.+unsafeFreezeZip :: +     (Universally k Prim, OrdForallPoly k)+  => MutablePrimArray s (k Any)+  -> MutableArray s (v Any)+  -> ST s (Map k v)+{-# INLINABLE unsafeFreezeZip #-}+unsafeFreezeZip keys0 vals0 =+  fmap Map (I.unsafeFreezeZip keys0 vals0)++-- | /O(1)/ This function is highly unsafe. The user is responsible for ensuring+-- that:+--+-- * Both @k'@ and @forall a. k a@ have the same runtime representation.+-- * The @Ord@ instance for @k'@ agrees with the @OrdForallPoly@ instance+--   for @k@.+unsafeCoerceKeys :: Proxy k' -> Map k v -> SU.Set k'+unsafeCoerceKeys p (Map (I.Map m)) =+  -- TODO: Technical debt. Add this function to the Internal module+  -- so that the data constructor does not have to be exported.+  unsafeCoerceSet p (SU.Set (M.keys m))++unsafeCoerceSet :: Proxy k' -> SU.Set (k Any) -> SU.Set k'+unsafeCoerceSet _ = unsafeCoerce++instance (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => IsList (Map k v) where+  type Item (Map k v) = DependentPair k v+  fromListN = fromListN+  fromList = fromList+  toList = toList+  +instance (Universally k Prim, ApplyUniversally k Prim, ShowForall k, ToSing k, ShowForeach v) => Show (Map k v) where+  showsPrec p (Map s) = I.showsPrec p s++instance (Universally k Prim, ApplyUniversally k Prim, EqForallPoly k, ToSing k, EqForeach v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k, ToSing k, OrdForeach v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (Universally k Prim, ToSing k, ToJSONKeyForall k, ToJSONForeach v) => ToJSON (Map k v) where+  toJSON (Map m) = I.toJSON m++instance (Universally k Prim, ApplyUniversally k Prim, ToSing k, FromJSONKeyExists k, FromJSONForeach v, OrdForallPoly k) => FromJSON (Map k v) where+  parseJSON v = fmap Map (I.parseJSON v)++instance (Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+
+ src/Data/Dependent/Map/Unlifted/Lifted.hs view
@@ -0,0 +1,23 @@+{-# language FlexibleContexts #-}++module Data.Dependent.Map.Unlifted.Lifted+  ( Map+  , singleton+  , lookup+  ) where++import Prelude hiding (lookup)++import Data.Primitive (Array,UnliftedArray,PrimUnlifted)+import Data.Dependent.Map.Class+import Data.Exists (OrdForallPoly)+import qualified Data.Dependent.Map.Internal as I++newtype Map k v = Map (I.Map UnliftedArray Array k v)++singleton :: ApplyUniversally k PrimUnlifted => k a -> v a -> Map k v+singleton f v = Map (I.singleton f v)++lookup :: (OrdForallPoly k, ApplyUniversally k PrimUnlifted) => k a -> Map k v -> Maybe (v a)+lookup k (Map x) = I.lookup k x+
− src/Data/Diet/Map/Internal.hs 
@@ -1,395 +0,0 @@-{-# 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 
@@ -1,77 +0,0 @@-{-# 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/Strict/Internal.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}++{-# OPTIONS_GHC -O2 -Wall #-}+module Data.Diet.Map.Strict.Internal+  ( Map+  , empty+  , singleton+  , map+  , append+  , lookup+  , concat+  , equals+  , fromSet+  , 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 Data.Diet.Set.Internal (Set(..))+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++-- Convert a diet set to a diet map. The function takes the+-- low and high keys in a range. This function should probably+-- have a test written for it.+fromSet :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (k -> k -> v) -> Set karr k -> Map karr varr k v+fromSet f (Set keys) = Map keys values+  where+  values = runST $ do+    let !sz = div (I.size keys) 2+    m <- I.new sz+    let go !ix !twiceIx = if ix < sz+          then do+            let !(# lo #) = I.index# keys twiceIx+                !(# hi #) = I.index# keys (twiceIx + 1)+            I.write m ix (f lo hi)+            go (ix + 1) (twiceIx + 2)+          else return ()+    go 0 0+    I.unsafeFreeze m+++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/Strict/Lifted/Lifted.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Map.Strict.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.Strict.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/Strict/Unboxed/Lifted.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -O2 #-}+module Data.Diet.Map.Strict.Unboxed.Lifted+  ( Map+  , empty+  , singleton+  , lookup+  , mapEqualityMorphism+  , fromSet+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  ) where++import Prelude hiding (lookup,map)++import Data.Diet.Set.Unboxed (Set(..))+import Data.Functor.Classes (Show2(..))+import Data.Primitive.Array (Array)+import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive.Types (Prim)+import Data.Semigroup (Semigroup)+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Diet.Map.Strict.Internal as I++newtype Map k v = Map (I.Map PrimArray Array k v)++-- | The empty diet map.+empty :: Map k v+empty = Map I.empty++-- | /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++-- | Map an equality morphism over the values in a diet map. An equality+-- morphism @f@ must satisfy the law:+--+-- > ∀ x y. x == y ↔ f x == f y+--+-- Since this does not actually use the 'Eq' constraint on the new value+-- type, it is lazy in the values.+mapEqualityMorphism :: (Prim k, Ord k)+  => (v -> w) -- ^ equality morphism+  -> Map k v+  -> Map k w+mapEqualityMorphism f (Map m) = Map (I.map f m)++-- | Convert a diet set to a diet map, constructing each value+-- from the low and high key in its corresponding range.+fromSet :: Prim k+  => (k -> k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)
− src/Data/Diet/Map/Unboxed/Lifted.hs 
@@ -1,79 +0,0 @@-{-# 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/Internal.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -O2 -Wall #-}+{-# LANGUAGE UnboxedTuples #-} module Data.Diet.Set.Internal-  ( Set+  ( Set(..)   , empty   , singleton   , append@@ -16,6 +16,8 @@   , equals   , showsPrec   , difference+  , intersection+  , negate   , foldr   , size     -- unsafe indexing@@ -35,15 +37,19 @@   , toList   ) where -import Prelude hiding (lookup,showsPrec,concat,map,foldr)+import Prelude hiding (lookup,showsPrec,concat,map,foldr,negate)  import Control.Monad.ST (ST,runST)+import Data.Bool (bool) 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 +-- Although the data constructor for this type is exported,+-- it isn't needed by anything in the diet Set modules. It is needed+-- by the diet Map modules to implement conversion functions. newtype Set arr a = Set (arr a)  empty :: Contiguous arr => Set arr a@@ -92,8 +98,8 @@   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)+        let !(# valLo #) = I.index# arr (2 * start)+            !(# valHi #) = I.index# arr (2 * start + 1)          in a >= valLo && a <= valHi       else False     else@@ -487,6 +493,61 @@     !keysFinal <- I.resize keysDst (total * 2)     fmap Set (I.unsafeFreeze keysFinal) +-- The element type must have a Bounded instance for+-- this to work.+negate :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a, Bounded a)+  => Set arr a+  -> Set arr a+negate set@(Set arr)+  | sz == 0 = uncheckedSingleton minBound maxBound+  | otherwise = runST action+  where+  action :: forall s. ST s (Set arr a)+  action = do+    let !(# lowest #) = I.index# arr 0+        !(# highest #) = I.index# arr (sz * 2 - 1)+        anyBeneath = lowest /= minBound+        anyAbove = highest /= maxBound+        newSz =+          (bool 0 1 anyBeneath) ++          (bool 0 1 anyAbove) ++          (sz - 1)+    (marr :: Mutable arr s a) <- I.new (newSz * 2)+    startDstIx <- if anyBeneath+      then do+        I.write marr 0 minBound+        I.write marr 1 (pred lowest)+        return 1+      else return 0+    let go !ix !dstIx = if ix < sz - 1+          then do+            hi <- I.indexM arr (2 * ix + 1)+            I.write marr (dstIx * 2) (succ hi)+            lo <- I.indexM arr (2 * ix + 2)+            I.write marr (dstIx * 2 + 1) (pred lo)+            go (ix + 1) (dstIx + 1)+          else return ()+    go 0 startDstIx+    if anyAbove+      then do+        I.write marr (newSz * 2 - 2) (succ highest)+        I.write marr (newSz * 2 - 1) maxBound+      else return ()+    frozen <- I.unsafeFreeze (marr :: Mutable arr s a)+    return (Set frozen)+  sz = size set+  ++-- This is a disappointing implementation, but it's the best I can+-- come up with given that I'm not willing to spend very much time+-- on it. Basically, it builds a list of diet sets where each set is+-- a slice of setA that only contains the elements from a contiguous range+-- of the negation of setB. This is simple to implement and it's easy+-- to see that it is correct. However, it is inefficient. There is a+-- better solution that writes to a output buffer directly without+-- building any intermediate artifacts. Additionally, the better solution+-- should not need an Enum constraint. If anyone can figure out the better+-- way to do this, I would gladly take a PR for it. difference :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a)   => Set arr a   -> Set arr a@@ -508,17 +569,44 @@           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)]+            then [belowExclusive lowestB (Set arrA)]             else []           highFragment = if highestA > highestB-            then [aboveInclusive (succ highestB) (Set arrA)]+            then [aboveExclusive 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++-- This implementation suffers from the same problems as the implementation+-- for difference. Notice that it's a bit simpler since we do not have to+-- negate the diet set. This means we do not have to do the weirdness with+-- treating the first and last elements specially and the weirdness with+-- straddling ranges as we walk the second diet set.+intersection :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a)+  => Set arr a+  -> Set arr a+  -> Set arr a+intersection setA@(Set arrA) setB@(Set arrB)+  | szA == 0 = empty+  | szB == 0 = empty+  | otherwise =+      let inners :: Int -> [Set arr a]+          inners !ix = if ix < szB+            then+              let inner = betweenInclusive+                    (I.index arrB (2 * ix))+                    (I.index arrB (2 * ix + 1))+                    (Set arrA)+               in inner : inners (ix + 1) +            else []+          -- we should use a more efficient concat since+          -- we know everything is ordered.+       in concat (inners 0)   where     !szA = size setA     !szB = size setB
src/Data/Diet/Set/Lifted.hs view
@@ -5,10 +5,12 @@  {-# OPTIONS_GHC -O2 #-} module Data.Diet.Set.Lifted-  ( Set+  ( Set(..)   , singleton   , member   , difference+  , intersection+  , negate     -- * Split   , aboveInclusive   , belowInclusive@@ -20,7 +22,7 @@   , fromListN   ) where -import Prelude hiding (lookup,map,foldr)+import Prelude hiding (lookup,map,foldr,negate)  import Data.Semigroup (Semigroup) import Data.Primitive (Array)@@ -28,6 +30,9 @@ import qualified Data.Semigroup as SG import qualified Data.Diet.Set.Internal as I +-- | A diet set. Currently, the data constructor for this type is+-- exported. Please do not use it. It will be moved to an internal+-- module at some point. newtype Set a = Set (I.Set Array a)  -- | /O(1)/ Create a diet set with a single element.@@ -82,6 +87,21 @@   -> Set a -- ^ subtrahend   -> Set a difference (Set x) (Set y) = Set (I.difference x y)++-- | The intersection of two diet sets.+intersection :: (Ord a, Enum a)+  => Set a -- ^ minuend+  -> Set a -- ^ subtrahend+  -> Set a+intersection (Set x) (Set y) = Set (I.intersection x y)++-- | The negation of a diet set. The resulting set contains+-- all elements that were not contained by the argument set,+-- and it only contains these elements.+negate :: (Ord a, Enum a, Bounded a)+  => Set a+  -> Set a+negate (Set x) = Set (I.negate x)  foldr :: (a -> a -> b -> b) -> b -> Set a -> b foldr f z (Set arr) = I.foldr f z arr
src/Data/Diet/Set/Unboxed.hs view
@@ -5,10 +5,12 @@  {-# OPTIONS_GHC -O2 #-} module Data.Diet.Set.Unboxed-  ( Set+  ( Set(..)   , singleton   , member   , difference+  , intersection+  , negate     -- * Split   , aboveInclusive   , belowInclusive@@ -21,7 +23,7 @@   , fromListN   ) where -import Prelude hiding (lookup,map,foldr)+import Prelude hiding (lookup,map,foldr,negate)  import Data.Semigroup (Semigroup) import Data.Functor.Classes (Show2(..))@@ -31,6 +33,8 @@ import qualified Data.Semigroup as SG import qualified Data.Diet.Set.Internal as I +-- | A diet set. Currently, the data constructor for this type is+-- exported. Please do not use it. newtype Set a = Set (I.Set PrimArray a)  -- | /O(1)/ Create a diet set with a single element.@@ -88,6 +92,21 @@   -> Set a -- ^ subtrahend   -> Set a difference (Set x) (Set y) = Set (I.difference x y)++-- | The intersection of two diet sets.+intersection :: (Ord a, Enum a, Prim a)+  => Set a -- ^ minuend+  -> Set a -- ^ subtrahend+  -> Set a+intersection (Set x) (Set y) = Set (I.intersection x y)++-- | The negation of a diet set. The resulting set contains+-- all elements that were not contained by the argument set,+-- and it only contains these elements.+negate :: (Ord a, Enum a, Prim a, Bounded a)+  => Set a+  -> Set a+negate (Set x) = Set (I.negate x)  foldr :: Prim a => (a -> a -> b -> b) -> b -> Set a -> b foldr f z (Set arr) = I.foldr f z arr
src/Data/Map/Internal.hs view
@@ -11,19 +11,30 @@   ( Map   , empty   , singleton+  , null   , map+  , mapWithKey   , mapMaybe+  , mapMaybeWithKey     -- * Folds+  , foldrWithKey   , foldlWithKey'   , foldrWithKey'+  , foldMapWithKey   , foldMapWithKey'     -- * Monadic Folds   , foldlWithKeyM'   , foldrWithKeyM'   , foldlMapWithKeyM'   , foldrMapWithKeyM'+    -- * Traversals+  , traverseWithKey_     -- * Functions   , append+  , appendWith+  , appendKeyWith+  , appendRightBiased+  , intersectionWith   , lookup   , showsPrec   , equals@@ -31,23 +42,30 @@   , toList   , concat   , size+  , keys+  , elems+  , restrict+  , rnf     -- * List Conversion   , fromListN   , fromList   , fromListAppend   , fromListAppendN+  , fromSet     -- * Array Conversion   , unsafeFreezeZip+  , unsafeZipPresorted   ) where -import Prelude hiding (compare,showsPrec,lookup,map,concat)+import Prelude hiding (compare,showsPrec,lookup,map,concat,null)  import Control.Applicative (liftA2)+import Control.DeepSeq (NFData) 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 Data.Set.Internal (Set(..)) import qualified Data.List as L import qualified Data.Semigroup as SG import qualified Prelude as P@@ -60,6 +78,9 @@ empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v empty = Map I.empty I.empty +null :: Contiguous varr => Map karr varr k v -> Bool+null (Map _ vals) = I.null vals+ singleton :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => k -> v -> Map karr varr k v singleton k v = Map   ( runST $ do@@ -87,11 +108,45 @@       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)+fromListN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)+  => Int+  -> [(k,v)]+  -> Map karr varr k v+{-# INLINABLE fromListN #-}+fromListN n xs = runST $ do+  (ks,vs) <- mutableArraysFromPairs (max n 1) xs+  unsafeFreezeZip ks vs +mutableArraysFromPairs :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)+  => Int -- must be at least one+  -> [(k,v)]+  -> ST s (Mutable karr s k, Mutable varr s v)+{-# INLINABLE mutableArraysFromPairs #-}+mutableArraysFromPairs n xs = do+  let go !ix !_ !ks !vs [] = return (ix,ks,vs)+      go !ix !len !ks !vs ((k,v) : ys) = if ix < len+        then do+          I.write ks ix k+          I.write vs ix v+          go (ix + 1) len ks vs ys+        else do+          let len' = len * 2+          ks' <- I.new len'+          vs' <- I.new len'+          I.copyMutable ks' 0 ks 0 len+          I.copyMutable vs' 0 vs 0 len+          I.write ks' ix k+          I.write vs' ix v+          go (ix + 1) len' ks' vs' ys+  ks0 <- I.new n+  vs0 <- I.new n+  (len,ks',vs') <- go 0 n ks0 vs0 xs+  ksFinal <- I.resize ks' len+  vsFinal <- I.resize vs' len+  return (ksFinal,vsFinal)+ fromList :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => [(k,v)] -> Map karr varr k v-fromList = fromListN 1+fromList = fromListN 8  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.<>)@@ -112,37 +167,37 @@   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+      go !ix !_ !sz !theKeys !vals [] = if ix == sz         then do-          arrKeys <- I.unsafeFreeze keys+          arrKeys <- I.unsafeFreeze theKeys           arrVals <- I.unsafeFreeze vals           return ([],Map arrKeys arrVals)         else do-          keys' <- I.resize keys ix+          keys' <- I.resize theKeys 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+      go !ix !old !sz !theKeys !vals ((k,v) : xs) = if ix < sz         then case P.compare k old of           GT -> do-            I.write keys ix k+            I.write theKeys ix k             I.write vals ix v-            go (ix + 1) k sz keys vals xs+            go (ix + 1) k sz theKeys vals xs           EQ -> do-            !oldVal <- I.read vals (ix - 1)+            oldVal <- I.read vals (ix - 1)             let !newVal = combine oldVal v             I.write vals (ix - 1) newVal-            go ix k sz keys vals xs+            go ix k sz theKeys vals xs           LT -> do-            keys' <- I.resize keys ix+            keys' <- I.resize theKeys 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'+          keys' <- I.resize theKeys sz'           vals' <- I.resize vals sz'           go ix old sz' keys' vals' ((k,v) : xs)   go 1 k0 n keys0 vals0 xs0@@ -152,10 +207,34 @@ map f (Map k v) = Map k (I.map f v)  -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+mapWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)+  => (k -> v -> w)+  -> Map karr varr k v+  -> Map karr varr k w+{-# INLINEABLE mapWithKey #-}+mapWithKey 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 !ix = if ix < sz+        then do+          k <- I.indexM ks ix+          a <- I.indexM vs ix+          I.write varr ix (f k a)+          I.write karr ix k+          go (ix + 1)+        else return ix+  dstLen <- go 0+  ksFinal <- I.resize karr dstLen >>= I.unsafeFreeze+  vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze+  return (Map ksFinal vsFinal)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'. 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+{-# INLINEABLE mapMaybe #-} mapMaybe f (Map ks vs) = runST $ do   let !sz = I.size vs   !(karr :: Mutable karr s k) <- I.new sz@@ -165,7 +244,7 @@           a <- I.indexM vs ixSrc           case f a of             Nothing -> go (ixSrc + 1) ixDst-            Just !b -> do+            Just b -> do               I.write varr ixDst b               I.write karr ixDst =<< I.indexM ks ixSrc               go (ixSrc + 1) (ixDst + 1)@@ -175,6 +254,32 @@   vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze   return (Map ksFinal vsFinal) +-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+mapMaybeWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)+  => (k -> v -> Maybe w)+  -> Map karr varr k v+  -> Map karr varr k w+{-# INLINEABLE mapMaybeWithKey #-}+mapMaybeWithKey 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+          k <- I.indexM ks ixSrc+          a <- I.indexM vs ixSrc+          case f k a of+            Nothing -> go (ixSrc + 1) ixDst+            Just !b -> do+              I.write varr ixDst b+              I.write karr ixDst k+              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)@@ -182,17 +287,35 @@ 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) =+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 theKeys vals) =   let !sz = I.size vals       go !i         | i == sz = z         | otherwise =-            let !k = I.index keys i-                !v = I.index vals i+            let !(# k #) = I.index# theKeys i+                !(# v #) = I.index# vals i              in f k v (go (i + 1))    in go 0 +foldMapWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid m)+  => (k -> v -> m)+  -> Map karr varr k v+  -> m+foldMapWithKey f (Map theKeys vals) =+  let !sz = I.size vals+      go !i+        | i == sz = mempty+        | otherwise =+            let !(# k #) = I.index# theKeys i+                !(# v #) = I.index# vals i+             in mappend (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.<>) @@ -202,18 +325,64 @@   -> 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) =+appendRightBiased :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v+appendRightBiased = appendWith const++appendKeyWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)+  => (k -> v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v+appendKeyWith combine (Map ksA vsA) (Map ksB vsB) =   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+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 (\_ x y -> combine x y) 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+  case unionArrWith (\_ x y -> x SG.<> y) ksA vsA ksB vsB of     (k,v) -> Map k v   +intersectionWith :: forall k v w x karr varr warr xarr.+     (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Contiguous warr, Element warr w, Contiguous xarr, Element xarr x, Ord k)+  => (v -> w -> x)+  -> Map karr varr k v+  -> Map karr warr k w+  -> Map karr xarr k x+intersectionWith f s1@(Map karr1 varr1) s2@(Map karr2 varr2)+  | sz1 == 0 = empty+  | sz2 == 0 = empty+  | otherwise = runST $ do+      let maxSz = min sz1 sz2+      kdst <- I.new maxSz+      vdst <- I.new maxSz+      let go !ix1 !ix2 !dstIx = if ix2 < sz2 && ix1 < sz1+            then do+              k1 <- I.indexM karr1 ix1+              k2 <- I.indexM karr2 ix2+              case P.compare k1 k2 of+                EQ -> do+                  v1 <- I.indexM varr1 ix1+                  v2 <- I.indexM varr2 ix2+                  I.write kdst dstIx k1+                  I.write vdst dstIx (f v1 v2)+                  go (ix1 + 1) (ix2 + 1) (dstIx + 1)+                LT -> go (ix1 + 1) ix2 dstIx+                GT -> go ix1 (ix2 + 1) dstIx+            else return dstIx+      dstSz <- go 0 0 0+      kdstFrozen <- I.resize kdst dstSz >>= I.unsafeFreeze+      vdstFrozen <- I.resize vdst dstSz >>= I.unsafeFreeze+      return (Map kdstFrozen vdstFrozen)+  where+    !sz1 = size s1+    !sz2 = size s2+ unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)-  => (v -> v -> v)+  => (k -> v -> v -> v)   -> karr k -- keys a   -> varr v -- values a   -> karr k -- keys b@@ -232,12 +401,12 @@               then do                 let !keyA = I.index keysA ixA                     !keyB = I.index keysB ixB-                    !valA = I.index valsA ixA-                    !valB = I.index valsB 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+                    let r = combine keyA valA valB                     I.write valsDst ixDst r                     go (ixA + 1) (ixB + 1) (ixDst + 1)                   LT -> do@@ -263,7 +432,11 @@       !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 :: 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@@ -283,7 +456,9 @@  -- | 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.+-- to this function. This function is only unsafe because of the requirement+-- that the arguments not be reused. If the arrays do not match in size, the+-- larger one will be truncated to the length of the shorter one. unsafeFreezeZip :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)   => Mutable karr s k   -> Mutable varr s v@@ -295,6 +470,19 @@   return (Map keys2 vals2) {-# INLINEABLE unsafeFreezeZip #-} +-- | There are two preconditions:+--+-- * The array of keys is sorted+-- * The array of keys and the array of values have the same length.+--+-- If either of these conditions is not met, this function will introduce+-- undefined behavior or segfaults.+unsafeZipPresorted :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => karr k -- array of keys, must already be sorted+  -> varr v -- array of values+  -> Map karr varr k v+unsafeZipPresorted = Map+ 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@@ -306,8 +494,8 @@   go :: Int -> b -> m b   go !ix !acc = if ix < len     then-      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix        in f acc k v >>= go (ix + 1)     else return acc {-# INLINEABLE foldlWithKeyM' #-}@@ -322,8 +510,8 @@   go :: Int -> b -> m b   go !ix !acc = if ix >= 0     then-      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix        in f k v acc >>= go (ix - 1)     else return acc {-# INLINEABLE foldrWithKeyM' #-}@@ -338,14 +526,30 @@   go :: Int -> b -> m b   go !ix !accl = if ix < len     then-      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      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' #-} +traverseWithKey_ :: forall karr varr k v m b. (Applicative m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (k -> v -> m b)+  -> Map karr varr k v+  -> m ()+traverseWithKey_ f (Map ks vs) = go 0+  where+  !len = I.size vs+  go :: Int -> m ()+  go !ix = if ix < len+    then+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix+       in f k v *> go (ix + 1)+    else pure ()+{-# INLINEABLE traverseWithKey_ #-}+ 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@@ -355,26 +559,26 @@   go :: Int -> b -> m b   go !ix !accr = if ix >= 0     then-      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix        in do          accl <- f k v-         go (ix + 1) (mappend accl accr)+         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)+foldMapWithKey' :: forall karr varr k v m. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid m)+  => (k -> v -> m)   -> Map karr varr k v-  -> b+  -> m foldMapWithKey' f (Map ks vs) = go 0 mempty   where   !len = I.size vs-  go :: Int -> b -> b+  go :: Int -> m -> m   go !ix !accl = if ix < len     then -      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix        in go (ix + 1) (mappend accl (f k v))     else accl {-# INLINEABLE foldMapWithKey' #-}@@ -390,8 +594,8 @@   go :: Int -> b -> b   go !ix !acc = if ix < len     then -      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix        in go (ix + 1) (f acc k v)     else acc {-# INLINEABLE foldlWithKey' #-}@@ -406,9 +610,83 @@   go :: Int -> b -> b   go !ix !acc = if ix >= 0     then-      let (# k #) = I.index# ks ix-          (# v #) = I.index# vs ix+      let !(# k #) = I.index# ks ix+          !(# v #) = I.index# vs ix        in go (ix - 1) (f k v acc)     else acc {-# INLINEABLE foldrWithKey' #-}++-- The algorithm used here is good when the subset is small, but+-- when the subset is large, it is worse that just walking the map.+restrict :: forall karr varr k v. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)+  => Map karr varr k v+  -> Set karr k+  -> Map karr varr k v+restrict m@(Map ks vs) (Set rs)+  | I.same ks rs = m+  | otherwise = stage1 0+  where+  szMap = I.size vs+  szSet = I.size rs+  szMin = min szMap szSet+  -- Locate the first difference between the two. This stage is useful+  -- because, in the case that the subset perfectly matches the keys,+  -- we do not need to do any copying.+  stage1 :: Int -> Map karr varr k v+  stage1 !ix = if ix < szMin+    then+      let !(# k #) = I.index# ks ix+          !(# r #) = I.index# rs ix+       in if k == r+            then stage1 (ix + 1)+            else stage2 ix+    else if szMin == szMap+      then m+      else Map rs vs+  -- In stage two, we walk the map and the set with possibly differing+  -- indices, writing each matching key (along with its value) into+  -- the result map.+  stage2 :: Int -> Map karr varr k v+  stage2 !ix = runST $ do+    ksMut <- I.new szMin+    vsMut <- I.new szMin+    I.copy ksMut 0 ks 0 ix+    I.copy vsMut 0 vs 0 ix+    let -- TODO: Turn this into a galloping search. It would+        -- probably be worth trying this out on+        -- Data.Set.Internal.intersection first.+        go !ixRes !ixm !ixs = if ixm < szMin && ixs < szMin+          then do+            k <- I.indexM ks ixm+            r <- I.indexM rs ixs+            case P.compare k r of+              EQ -> do+                I.write ksMut ixRes k+                I.write vsMut ixRes =<< I.indexM vs ixm+                go (ixRes + 1) (ixm + 1) (ixs + 1)+              LT -> go ixRes (ixm + 1) ixs+              GT -> go ixRes ixm (ixs + 1)+          else return ixRes+    total <- go ix ix ix+    ks' <- I.resize ksMut total >>= I.unsafeFreeze+    vs' <- I.resize vsMut total >>= I.unsafeFreeze+    return (Map ks' vs')+{-# INLINEABLE restrict #-}++fromSet :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)+  => (k -> v)+  -> Set karr k+  -> Map karr varr k v+fromSet f (Set arr) = Map arr (I.map f arr)++keys :: Map karr varr k v -> Set karr k+keys (Map k _) = Set k++elems :: Map karr varr k v -> varr v+elems (Map _ v) = v++rnf :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, NFData k, NFData v)+  => Map karr varr k v+  -> ()+rnf (Map k v) = seq (I.rnf k) (seq (I.rnf v) ())
src/Data/Map/Lifted/Lifted.hs view
@@ -5,12 +5,15 @@  {-# OPTIONS_GHC -O2 -Wall #-} module Data.Map.Lifted.Lifted-  ( Map+  ( Map(..)+  , empty   , singleton   , lookup   , size   , map   , mapMaybe+  , mapMaybeWithKey+  , union     -- * Folds   , foldlWithKey'   , foldrWithKey'@@ -25,12 +28,15 @@   , fromListAppend   , fromListN   , fromListAppendN+  , fromSet+  , elems   ) where  import Prelude hiding (lookup,map)  import Data.Semigroup (Semigroup) import Data.Primitive.Array (Array)+import Data.Set.Lifted.Internal (Set(..)) import qualified GHC.Exts as E import qualified Data.Semigroup as SG import qualified Data.Map.Internal as I@@ -39,6 +45,9 @@ --   type must both have 'Prim' instances. newtype Map k v = Map (I.Map Array Array k v) +instance Functor (Map k) where+  fmap = map+ instance (Ord k, Semigroup v) => Semigroup (Map k v) where   Map x <> Map y = Map (I.append x y) @@ -62,6 +71,10 @@ instance (Show k, Show v) => Show (Map k v) where   showsPrec p (Map s) = I.showsPrec p s +-- | The empty diet map.+empty :: Map k v+empty = Map I.empty+ -- | /O(log n)/ Lookup the value at a key in the map. lookup :: Ord k => k -> Map k v -> Maybe v lookup a (Map s) = I.lookup a s@@ -95,6 +108,15 @@ fromListAppend :: (Ord k, Semigroup v) => [(k,v)] -> Map k v fromListAppend = Map . I.fromListAppend +-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key.+fromSet ::+     (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)+ -- | /O(n*log n)/ This function has the same behavior as 'fromListN', -- but it combines values with the 'Semigroup' instances instead of -- choosing the last occurrence.@@ -122,6 +144,14 @@   -> Map k w mapMaybe f (Map m) = Map (I.mapMaybe f m) +-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey ::+     (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey 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@@ -183,3 +213,13 @@   -> Map k v -- ^ map   -> b foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m++-- | /O(n+m)/ The expression (@'union' t1 t2@) takes the left-biased union+-- of @t1@ and @t2@. It prefers @t1@ when duplicate keys are encountered.+union :: Ord k => Map k v -> Map k v -> Map k v+union (Map a) (Map b) = Map (I.appendWith const a b)++-- | /O(1)/ The values in a map. This is a zero-cost operation.+elems :: Map k v -> Array v+elems (Map m) = I.elems m+
− src/Data/Map/Subset/Internal.hs 
@@ -1,170 +0,0 @@-{-# 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/Lazy/Internal.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Subset.Lazy.Internal+  ( Map+  , lookup+  , empty+  , singleton+  , antisingleton+  , fromPolarities+  , toList+  , fromList+  ) where++import Prelude hiding (lookup,concat)++import Data.Bifunctor (first)+import Data.Bool (bool)+import Data.Primitive (Array)+import Data.Primitive.Contiguous (Contiguous,Element)+import Data.Semigroup (Semigroup,(<>),First(..))+import Data.Set.Internal (Set(..))++import qualified Data.Foldable as F+import qualified Data.Map.Internal as M+import qualified Data.Primitive.Contiguous as A+import qualified Data.Semigroup as SG+import qualified Data.Set.Internal as S+import qualified Data.Set.Lifted.Internal as SL+import qualified Prelude as P++-- 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.+--+-- Unlike the strict variant, which imposes an Eq constraint on+-- values, the lazy variant is able to have a Functor instance.+data Map k v+  = MapElement k (Map k v) (Map k v)+  | MapValue v+  | MapEmpty+  deriving (Functor,Eq,Ord)++instance (Semigroup v, Ord k) => Semigroup (Map k v) where+  (<>) = append++instance (Semigroup 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))++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)+  => [(Set arr k,v)]+  -> Map k v+fromList = fmap getFirst . concat . P.map (\(s,v) -> singleton s (First v))++concat :: (Ord k,Semigroup 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 :: (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++antisingleton :: (Contiguous arr, Element arr k)+  => Set arr k+  -> v+  -> Map k v+antisingleton s v = S.foldr (\k m -> MapElement k empty m) (MapValue v) s++fromPolarities :: (Contiguous karr, Element karr k)+  => M.Map karr Array k Bool+  -> v+  -> Map k v+fromPolarities s v = M.foldrWithKey+  (\k p m -> MapElement k (bool empty m p) (bool m empty p))+  (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 => (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 MapElement k present' absent'++append :: forall k v. (Semigroup 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 MapElement elemX present absent+    LT ->+      let present = go presentX (MapElement elemY presentY absentY)+          absent = go absentX (MapElement elemY presentY absentY)+       in MapElement elemX present absent+    GT ->+      let present = go (MapElement elemX presentX absentX) presentY+          absent = go (MapElement elemX presentX absentX) absentY+       in MapElement elemY present absent+      +
+ src/Data/Map/Subset/Lazy/Lifted.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Subset.Lazy.Lifted+  ( I.Map+  , I.empty+    -- * Singleton Subset Maps+  , singleton+  , antisingleton+  , fromPolarities+    -- * Querying+  , lookup+    -- * List Conversion+  , toList+  , fromList+  ) where++import Prelude hiding (lookup)++import Data.Map.Subset.Lazy.Internal (Map)+import Data.Set.Lifted.Internal (Set(..))+import Data.Bifunctor (first)+import Data.Semigroup (Semigroup)++import qualified Data.Map.Lifted.Lifted as M+import qualified Data.Map.Subset.Lazy.Internal as I++-- | A subset map with a single set as its key.+singleton :: +     Set k+  -> v+  -> Map k v+singleton (Set s) v = I.singleton s v++-- | A subset map with a single negative set as its key. That is,+-- a lookup into this map will only succeed if the needle set and the+-- negative set do not overlap.+antisingleton ::+     Set k -- ^ negative set+  -> v -- ^ value+  -> Map k v+antisingleton (Set s) v = I.antisingleton s v++-- | Construct a singleton subset map by interpreting a+-- @Data.Map.Unlifted.Lifted.Map@ as requirements about+-- what must be present and absent.+fromPolarities ::+     M.Map k Bool -- ^ Map of required presences and absences+  -> v -- +  -> Map k v +fromPolarities (M.Map m) v = I.fromPolarities m 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 => [(Set k,v)] -> Map k v+fromList = I.fromList . map (first getSet)+
+ src/Data/Map/Subset/Lazy/Unlifted.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Subset.Lazy.Unlifted+  ( I.Map+  , I.empty+    -- * Singleton Subset Maps+  , singleton+  , antisingleton+  , fromPolarities+    -- * Querying+  , lookup+    -- * List Conversion+  , toList+  , fromList+  ) where++import Prelude hiding (lookup)++import Data.Map.Subset.Lazy.Internal (Map)+import Data.Set.Unlifted.Internal (Set(..))+import Data.Bifunctor (first)+import Data.Semigroup (Semigroup)+import Data.Primitive (PrimUnlifted)++import qualified Data.Map.Unlifted.Lifted as M+import qualified Data.Map.Subset.Lazy.Internal as I++-- | A subset map with a single set as its key.+singleton :: PrimUnlifted k+  => Set k+  -> v+  -> Map k v+singleton (Set s) v = I.singleton s v++-- | A subset map with a single negative set as its key. That is,+-- a lookup into this map will only succeed if the needle set and the+-- negative set do not overlap.+antisingleton :: PrimUnlifted k+  => Set k -- ^ negative set+  -> v -- ^ value+  -> Map k v+antisingleton (Set s) v = I.antisingleton s v++-- | Construct a singleton subset map by interpreting a+-- @Data.Map.Unlifted.Lifted.Map@ as requirements about+-- what must be present and absent.+fromPolarities :: PrimUnlifted k+  => M.Map k Bool -- ^ Map of required presences and absences+  -> v -- +  -> Map k v +fromPolarities (M.Map m) v = I.fromPolarities m v++lookup :: (Ord k, PrimUnlifted k) => Set k -> Map k v -> Maybe v+lookup (Set s) m = I.lookup s m++toList :: PrimUnlifted k => Map k v -> [(Set k,v)]+toList = map (first Set) . I.toList++fromList :: (Ord k, PrimUnlifted k) => [(Set k,v)] -> Map k v+fromList = I.fromList . map (first getSet)+
− src/Data/Map/Subset/Lifted.hs 
@@ -1,39 +0,0 @@-{-# 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/Subset/Strict/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.Strict.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/Strict/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.Strict.Lifted+  ( I.Map+  , singleton+  , lookup+  , toList+  , fromList+  ) where++import Prelude hiding (lookup)++import Data.Map.Subset.Strict.Internal (Map)+import Data.Set.Lifted.Internal (Set(..))+import Data.Bifunctor (first)+import Data.Semigroup (Semigroup)++import qualified Data.Map.Subset.Strict.Internal as I++singleton :: 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/Subset/Strict/Unlifted.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Map.Subset.Strict.Unlifted+  ( I.Map+  , singleton+  , lookup+  , toList+  , fromList+  ) where++import Prelude hiding (lookup)++import Data.Map.Subset.Strict.Internal (Map)+import Data.Set.Unlifted.Internal (Set(..))+import Data.Bifunctor (first)+import Data.Semigroup (Semigroup)+import Data.Primitive (PrimUnlifted)++import qualified Data.Map.Subset.Strict.Internal as I++singleton :: (PrimUnlifted k, Monoid v, Eq v)+  => Set k+  -> v+  -> Map k v+singleton (Set s) v = I.singleton s v++lookup :: (Ord k, PrimUnlifted k) => Set k -> Map k v -> Maybe v+lookup (Set s) m = I.lookup s m++toList :: PrimUnlifted k => Map k v -> [(Set k,v)]+toList = map (first Set) . I.toList++fromList :: (Ord k, PrimUnlifted k, Eq v, Semigroup v) => [(Set k,v)] -> Map k v+fromList = I.fromList . map (first getSet)+
src/Data/Map/Unboxed/Lifted.hs view
@@ -6,12 +6,21 @@ {-# OPTIONS_GHC -O2 #-} module Data.Map.Unboxed.Lifted   ( Map+  , empty   , singleton   , lookup   , size   , map   , mapMaybe+  , mapMaybeWithKey+  , keys+  , intersectionWith+  , restrict     -- * Folds+  , foldrWithKey+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey   , foldMapWithKey'     -- * Monadic Folds   , foldlWithKeyM'@@ -19,20 +28,25 @@   , foldlMapWithKeyM'   , foldrMapWithKeyM'     -- * List Conversion+  , toList   , fromList   , fromListAppend   , fromListN   , fromListAppendN+  , elems     -- * Array Conversion   , unsafeFreezeZip   ) where  import Prelude hiding (lookup,map) +import Control.DeepSeq (NFData) import Control.Monad.ST (ST) import Data.Semigroup (Semigroup) import Data.Primitive.Types (Prim) import Data.Primitive (PrimArray,Array,MutablePrimArray,MutableArray)+import Data.Set.Unboxed.Internal (Set(..))+import qualified Control.DeepSeq import qualified GHC.Exts as E import qualified Data.Semigroup as SG import qualified Data.Map.Internal as I@@ -45,6 +59,9 @@ instance Prim k => Functor (Map k) where   fmap = map +instance (Prim k, NFData k, NFData v) => NFData (Map k v) where+  rnf (Map m) = I.rnf m+ instance (Prim k, Ord k, Semigroup v) => Semigroup (Map k v) where   Map x <> Map y = Map (I.append x y) @@ -72,10 +89,18 @@ lookup :: (Prim k, Ord k) => k -> Map k v -> Maybe v lookup a (Map s) = I.lookup a s +-- | The empty map.+empty :: Map k v+empty = Map I.empty+ -- | /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)/ A list of key-value pairs in ascending order.+toList :: (Prim k, Ord k, Prim v) => Map k v -> [(k,v)]+toList (Map m) = I.toList m+ -- | /O(n*log n)/ Create a map from a list of key-value pairs. -- If the list contains more than one value for the same key, -- the last value is retained. If the keys in the argument are@@ -128,6 +153,14 @@   -> Map k w mapMaybe f (Map m) = Map (I.mapMaybe f m) +-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey :: Prim k+  => (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey 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)@@ -164,6 +197,40 @@   -> m b foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m +-- | /O(n)/ Left fold over the keys and values with a strict accumulator.+foldlWithKey' :: Prim k+  => (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 lazy accumulator.+foldrWithKey :: Prim k+  => (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)/ Right fold over the keys and values with a strict accumulator.+foldrWithKey' :: Prim k+  => (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)/ Fold over the keys and values of the map with a lazy 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)/ 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@@ -188,4 +255,26 @@   => MutablePrimArray s k   -> MutableArray s v   -> ST s (Map k v)-unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)+unsafeFreezeZip theKeys vals = fmap Map (I.unsafeFreezeZip theKeys vals)++-- | /O(1)/ Get the keys from the map.+keys :: Map k v -> Set k+keys (Map m) = Set (I.keys m)++intersectionWith :: (Prim k, Ord k)+  => (a -> b -> c)+  -> Map k a+  -> Map k b+  -> Map k c+intersectionWith f (Map a) (Map b) = Map (I.intersectionWith f a b)++restrict :: (Prim k, Ord k)+  => Map k v+  -> Set k+  -> Map k v+restrict (Map m) (Set s) = Map (I.restrict m s)++-- | /O(1)/ The values in a map. This is a zero-cost operation.+elems :: Map k v -> Array v+elems (Map m) = I.elems m+
src/Data/Map/Unboxed/Unboxed.hs view
@@ -6,11 +6,13 @@ {-# OPTIONS_GHC -O2 -Wall #-} module Data.Map.Unboxed.Unboxed   ( Map+  , empty   , singleton   , lookup   , size   , map   , mapMaybe+  , mapMaybeWithKey     -- * Folds   , foldlWithKey'   , foldrWithKey'@@ -20,7 +22,10 @@   , foldrWithKeyM'   , foldlMapWithKeyM'   , foldrMapWithKeyM'+    -- * Traversals+  , traverseWithKey_     -- * List Conversion+  , toList   , fromList   , fromListAppend   , fromListN@@ -70,10 +75,18 @@ lookup :: (Prim k, Ord k, Prim v) => k -> Map k v -> Maybe v lookup a (Map s) = I.lookup a s +-- | The empty diet map.+empty :: Map k v+empty = Map I.empty+ -- | /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)/ A list of key-value pairs in ascending order.+toList :: (Prim k, Ord k, Prim v) => Map k v -> [(k,v)]+toList (Map m) = I.toList m+ -- | /O(n*log n)/ Create a map from a list of key-value pairs. -- If the list contains more than one value for the same key, -- the last value is retained. If the keys in the argument are@@ -126,6 +139,14 @@   -> Map k w mapMaybe f (Map m) = Map (I.mapMaybe f m) +-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey :: (Prim k, Prim v, Prim w)+  => (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey 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)@@ -161,6 +182,13 @@   -> Map k v -- ^ map   -> m b foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m++-- | /O(n)/ Traverse the keys and values of the map from left to right.+traverseWithKey_ :: (Monad m, Prim k, Prim v)+  => (k -> v -> m b) -- ^ reduction+  -> Map k v -- ^ map+  -> m ()+traverseWithKey_ f (Map m) = I.traverseWithKey_ 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
src/Data/Map/Unboxed/Unlifted.hs view
@@ -6,22 +6,38 @@ {-# OPTIONS_GHC -O2 #-} module Data.Map.Unboxed.Unlifted   ( Map+  , empty   , singleton   , lookup   , size+  , map+  , mapMaybe+  , mapMaybeWithKey+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'     -- * List Conversion   , fromList   , fromListAppend   , fromListN   , fromListAppendN+    -- * Array Conversion+  , unsafeFreezeZip   ) where -import Prelude hiding (lookup)+import Prelude hiding (lookup,map)  import Data.Semigroup (Semigroup) import Data.Primitive.Types (Prim)-import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray)-import Data.Primitive (PrimArray)+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)+import Data.Primitive (PrimArray,MutablePrimArray)+import Control.Monad.ST (ST) import qualified GHC.Exts as E import qualified Data.Semigroup as SG import qualified Data.Map.Internal as I@@ -53,6 +69,10 @@ instance (Prim k, Show k, PrimUnlifted v, Show v) => Show (Map k v) where   showsPrec p (Map s) = I.showsPrec p s +-- | The empty diet map.+empty :: Map k v+empty = Map I.empty+ -- | /O(log n)/ Lookup the value at a key in the map. lookup :: (Prim k, Ord k, PrimUnlifted v) => k -> Map k v -> Maybe v lookup a (Map s) = I.lookup a s@@ -99,4 +119,103 @@ size :: PrimUnlifted v => Map k v -> Int size (Map m) = I.size m +-- | /O(n)/ Map over the values in the map.+map :: (Prim k, PrimUnlifted v, PrimUnlifted w)+  => (v -> w)+  -> Map k v+  -> Map k w+map f (Map m) = Map (I.map f m)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+mapMaybe :: (Prim k, PrimUnlifted v, PrimUnlifted w)+  => (v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey :: (Prim k, PrimUnlifted v, PrimUnlifted w)+  => (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey 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, PrimUnlifted v)+  => (b -> k -> v -> m b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> m b+foldlWithKeyM' f b0 (Map m) = I.foldlWithKeyM' f b0 m++-- | /O(n)/ Right monadic fold over the keys and values of the map. This fold+-- is strict in the accumulator.+foldrWithKeyM' :: (Monad m, Prim k, PrimUnlifted v)+  => (k -> v -> b -> m b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> m b+foldrWithKeyM' f b0 (Map m) = I.foldrWithKeyM' f b0 m++-- | /O(n)/ Monadic left fold over the keys and values of the map with a strict+-- monoidal accumulator. The monoidal accumulator is appended to the left+-- after each reduction.+foldlMapWithKeyM' :: (Monad m, Monoid b, Prim k, PrimUnlifted v)+  => (k -> v -> m b) -- ^ reduction+  -> Map k v -- ^ map+  -> m b+foldlMapWithKeyM' f (Map m) = I.foldlMapWithKeyM' f m++-- | /O(n)/ Monadic right fold over the keys and values of the map with a strict+-- monoidal accumulator. The monoidal accumulator is appended to the right+-- after each reduction.+foldrMapWithKeyM' :: (Monad m, Monoid b, Prim k, PrimUnlifted v)+  => (k -> v -> m b) -- ^ reduction+  -> Map k v -- ^ map+  -> m b+foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m++-- | /O(n)/ Fold over the keys and values of the map with a strict monoidal+-- accumulator. This function does not have left and right variants since+-- the associativity required by a monoid instance means that both variants+-- would always produce the same result.+foldMapWithKey' :: (Monoid b, Prim k, PrimUnlifted v)+  => (k -> v -> b) -- ^ reduction +  -> Map k v -- ^ map+  -> b+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m++-- | /O(n)/ Left fold over the keys and values with a strict accumulator.+foldlWithKey' :: (Prim k, PrimUnlifted v)+  => (b -> k -> v -> b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> b+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m++-- | /O(n)/ Right fold over the keys and values with a strict accumulator.+foldrWithKey' :: (Prim k, PrimUnlifted v)+  => (k -> v -> b -> b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> b+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m++-- | /O(n*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, PrimUnlifted v)+  => MutablePrimArray s k+  -> MutableUnliftedArray s v+  -> ST s (Map k v)+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
+ src/Data/Map/Unlifted/Lifted.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Data.Map.Unlifted.Lifted+  ( Map(..)+  , empty+  , singleton+  , lookup+  , size+  , map+  , mapMaybe+  , mapMaybeWithKey+  , union+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  , fromSet+    -- * Array Conversion+  , unsafeFreezeZip+  ) where++import Prelude hiding (lookup,map)++import Control.Monad.ST (ST)+import Data.Semigroup (Semigroup)+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)+import Data.Primitive (Array,MutableArray)+import Data.Set.Unlifted.Internal (Set(..))+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Map.Internal as I++-- | A map from keys @k@ to values @v@. The key type must have a+--   'PrimUnlifted' instance and the value type must have a 'Prim'+--   instance.+--+--   The data constructor for this type should not be exported.+--   I am working on this.+newtype Map k v = Map (I.Map UnliftedArray Array k v)++instance (PrimUnlifted k, Ord k, Semigroup v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (PrimUnlifted k, Ord k, Semigroup v) => Monoid (Map k v) where+  mempty = Map I.empty+  mappend = (SG.<>)+  mconcat = Map . I.concat . E.coerce++instance (PrimUnlifted k, Eq k, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (PrimUnlifted k, Ord k, Ord v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (PrimUnlifted 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 (PrimUnlifted 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 :: (PrimUnlifted k, Ord k) => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++-- | The empty diet map.+empty :: Map k v+empty = Map I.empty++-- | /O(1)/ Create a map with a single element.+singleton :: PrimUnlifted 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 :: (PrimUnlifted 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 :: (PrimUnlifted 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 :: (PrimUnlifted k, Ord k, Semigroup v) => [(k,v)] -> Map k v+fromListAppend = Map . I.fromListAppend++-- | /O(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key.+fromSet :: PrimUnlifted k+  => (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)++-- | /O(n*log n)/ This function has the same behavior as 'fromListN',+-- but it combines values with the 'Semigroup' instances instead of+-- choosing the last occurrence.+fromListAppendN :: (PrimUnlifted 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 :: PrimUnlifted 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 :: PrimUnlifted k+  => (v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybe f (Map m) = Map (I.mapMaybe f m)++-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey :: PrimUnlifted k+  => (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey 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, PrimUnlifted k)+  => (b -> k -> v -> m b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> m b+foldlWithKeyM' f b0 (Map m) = I.foldlWithKeyM' f b0 m++-- | /O(n)/ Right monadic fold over the keys and values of the map. This fold+-- is strict in the accumulator.+foldrWithKeyM' :: (Monad m, PrimUnlifted k)+  => (k -> v -> b -> m b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> m b+foldrWithKeyM' f b0 (Map m) = I.foldrWithKeyM' f b0 m++-- | /O(n)/ Monadic left fold over the keys and values of the map with a strict+-- monoidal accumulator. The monoidal accumulator is appended to the left+-- after each reduction.+foldlMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted k)+  => (k -> v -> m b) -- ^ reduction+  -> Map k v -- ^ map+  -> m b+foldlMapWithKeyM' f (Map m) = I.foldlMapWithKeyM' f m++-- | /O(n)/ Monadic right fold over the keys and values of the map with a strict+-- monoidal accumulator. The monoidal accumulator is appended to the right+-- after each reduction.+foldrMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted 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, PrimUnlifted k)+  => (k -> v -> b) -- ^ reduction +  -> Map k v -- ^ map+  -> b+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m++-- | /O(n)/ Left fold over the keys and values with a strict accumulator.+foldlWithKey' :: PrimUnlifted k+  => (b -> k -> v -> b) -- ^ reduction+  -> b -- ^ initial accumulator+  -> Map k v -- ^ map+  -> b+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m++-- | /O(n)/ Right fold over the keys and values with a strict accumulator.+foldrWithKey' :: PrimUnlifted k+  => (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, PrimUnlifted k)+  => MutableUnliftedArray s k+  -> MutableArray s v+  -> ST s (Map k v)+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)++-- | /O(n+m)/ The expression (@'union' t1 t2@) takes the left-biased union+-- of @t1@ and @t2@. It prefers @t1@ when duplicate keys are encountered.+union :: (Ord k, PrimUnlifted k) => Map k v -> Map k v -> Map k v+union (Map a) (Map b) = Map (I.appendWith const a b)+
+ src/Data/Map/Unlifted/Unboxed.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Data.Map.Unlifted.Unboxed+  ( Map+  , empty+  , singleton+  , lookup+  , size+  , map+  , mapMaybe+  , mapMaybeWithKey+    -- * Folds+  , foldlWithKey'+  , foldrWithKey'+  , foldMapWithKey'+    -- * Monadic Folds+  , foldlWithKeyM'+  , foldrWithKeyM'+  , foldlMapWithKeyM'+  , foldrMapWithKeyM'+    -- * List Conversion+  , fromList+  , fromListAppend+  , fromListN+  , fromListAppendN+  , fromSet+    -- * 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.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)+import Data.Primitive.PrimArray (PrimArray,MutablePrimArray)+import Data.Set.Unlifted.Internal (Set(..))+import qualified GHC.Exts as E+import qualified Data.Semigroup as SG+import qualified Data.Map.Internal as I++-- | A map from keys @k@ to values @v@. The key type must have a+--   'PrimUnlifted' instance and the value type must have a 'Prim'+--   instance.+newtype Map k v = Map (I.Map UnliftedArray PrimArray k v)++instance (PrimUnlifted k, Ord k, Prim v, Semigroup v) => Semigroup (Map k v) where+  Map x <> Map y = Map (I.append x y)++instance (PrimUnlifted 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 (PrimUnlifted k, Eq k, Prim v, Eq v) => Eq (Map k v) where+  Map x == Map y = I.equals x y++instance (PrimUnlifted k, Ord k, Prim v, Ord v) => Ord (Map k v) where+  compare (Map x) (Map y) = I.compare x y++instance (PrimUnlifted 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 (PrimUnlifted 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 :: (PrimUnlifted k, Ord k, Prim v) => k -> Map k v -> Maybe v+lookup a (Map s) = I.lookup a s++-- | The empty diet map.+empty :: Map k v+empty = Map I.empty++-- | /O(1)/ Create a map with a single element.+singleton :: (PrimUnlifted 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 :: (PrimUnlifted 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 :: (PrimUnlifted 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 :: (PrimUnlifted 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 :: (PrimUnlifted 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(n)/ Build a map from a set. This function is uses the underlying+-- array that backs the set as the array for the keys. It constructs the+-- values by apply the given function to each key.+fromSet :: (PrimUnlifted k, Prim v)+  => (k -> v)+  -> Set k+  -> Map k v+fromSet f (Set s) = Map (I.fromSet f s)++-- | /O(1)/ The number of elements in the map.+size :: Prim v => Map k v -> Int+size (Map m) = I.size m++-- | /O(n)/ Map over the values in the map.+map :: (PrimUnlifted 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 :: (PrimUnlifted 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)/ Drop elements for which the predicate returns 'Nothing'.+-- The predicate is given access to the key.+mapMaybeWithKey :: (PrimUnlifted k, Prim v, Prim w)+  => (k -> v -> Maybe w)+  -> Map k v+  -> Map k w+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey 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, PrimUnlifted 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, PrimUnlifted 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, PrimUnlifted 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, PrimUnlifted 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, PrimUnlifted 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' :: (PrimUnlifted 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' :: (PrimUnlifted 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, PrimUnlifted k, Prim v)+  => MutableUnliftedArray s k+  -> MutablePrimArray s v+  -> ST s (Map k v)+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)+
src/Data/Set/Internal.hs view
@@ -10,8 +10,10 @@ module Data.Set.Internal   ( Set(..)   , empty+  , null   , singleton   , difference+  , intersection   , append   , member   , showsPrec@@ -20,22 +22,29 @@   , fromListN   , fromList   , toList+  , toArray   , size   , concat     -- * Folds   , foldr+  , foldMap   , foldl'   , foldr'   , foldMap'   , foldlM'+  , liftHashWithSalt+    -- * Traversals+  , traverse_+  , itraverse_   ) where -import Prelude hiding (compare,showsPrec,concat,foldr)-import qualified Prelude as P+import Prelude hiding (compare,showsPrec,concat,foldr,foldMap,null)  import Control.Monad.ST (ST,runST)+import Data.Hashable (Hashable) import Data.Primitive.UnliftedArray (PrimUnlifted(..)) import Data.Primitive.Contiguous (Contiguous,Mutable,Element)+import qualified Prelude as P import qualified Data.Primitive.Contiguous as A import qualified Data.Concatenation as C @@ -48,6 +57,9 @@ 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)   +null :: Contiguous arr => Set arr a -> Bool+null (Set x) = A.null x+ empty :: Contiguous arr => Set arr a empty = Set A.empty @@ -100,6 +112,33 @@     !sz1 = size s1     !sz2 = size s2 +intersection :: forall a arr. (Contiguous arr, Element arr a, Ord a)+  => Set arr a+  -> Set arr a+  -> Set arr a+intersection s1@(Set arr1) s2@(Set arr2)+  | sz1 == 0 = empty+  | sz2 == 0 = empty+  | otherwise = runST $ do+      dst <- A.new (min sz1 sz2)+      let go !ix1 !ix2 !dstIx = if ix2 < sz2 && ix1 < sz1+            then do+              v1 <- A.indexM arr1 ix1+              v2 <- A.indexM arr2 ix2+              case P.compare v1 v2 of+                EQ -> do+                  A.write dst dstIx v1+                  go (ix1 + 1) (ix2 + 1) (dstIx + 1)+                LT -> go (ix1 + 1) ix2 dstIx+                GT -> go ix1 (ix2 + 1) dstIx+            else return dstIx+      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@@ -140,6 +179,9 @@ toList :: (Contiguous arr, Element arr a) => Set arr a -> [a] toList = foldr (:) [] +toArray :: Set arr a -> arr a+toArray (Set a) = a+ 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@@ -227,6 +269,14 @@ foldr f b0 (Set arr) = A.foldr f b0 arr {-# INLINEABLE foldr #-} +-- | Monoidal fold over the elements in the set. This is lazy in the accumulator.+foldMap :: (Contiguous arr, Element arr a, Monoid m)+  => (a -> m)+  -> Set arr a+  -> m+foldMap f (Set arr) = A.foldMap f arr+{-# INLINEABLE foldMap #-}+ foldl' :: (Contiguous arr, Element arr a)   => (b -> a -> b)   -> b@@ -257,3 +307,27 @@   -> m b foldlM' f b0 (Set arr) = A.foldlM' f b0 arr {-# INLINEABLE foldlM' #-}++traverse_ :: (Contiguous arr, Element arr a, Applicative m)+  => (a -> m b)+  -> Set arr a+  -> m ()+traverse_ f (Set arr) = A.traverse_ f arr+{-# INLINEABLE traverse_ #-}++itraverse_ :: (Contiguous arr, Element arr a, Applicative m)+  => (Int -> a -> m b)+  -> Set arr a+  -> m ()+itraverse_ f (Set arr) = A.itraverse_ f arr+{-# INLINEABLE itraverse_ #-}++liftHashWithSalt :: (Contiguous arr, Element arr a)+  => (Int -> a -> Int)+  -> Int -- ^ salt+  -> Set arr a -- ^ set+  -> Int+liftHashWithSalt f s (Set arr) = A.liftHashWithSalt f s arr+{-# INLINEABLE liftHashWithSalt #-}++
src/Data/Set/Lifted.hs view
@@ -6,12 +6,16 @@  module Data.Set.Lifted   ( Set+  , empty   , singleton+  , null   , member   , size   , difference   , (\\)-    -- * List Conversion+  , intersection+    -- * Conversion+  , toArray   , LI.toList   , LI.fromList     -- * Folds@@ -19,11 +23,16 @@   , LI.foldl'   , LI.foldr'   , foldMap'+  , foldMap+    -- * Traversals+  , traverse_+  , itraverse_   ) where -import Prelude hiding (foldr)+import Prelude hiding (foldr,foldMap,null) import Data.Semigroup (Semigroup) import Data.Set.Lifted.Internal (Set(..))+import Data.Primitive (Array) import qualified Data.Set.Internal as I import qualified Data.Set.Lifted.Internal as LI @@ -31,10 +40,22 @@ difference :: Ord a => Set a -> Set a -> Set a difference (Set x) (Set y) = Set (I.difference x y) +-- | The intersection of two sets.+intersection :: Ord a => Set a -> Set a -> Set a+intersection (Set x) (Set y) = Set (I.intersection x y)++-- | The empty set.+empty :: Set a+empty = Set I.empty+ -- | Infix operator for 'difference'. (\\) :: Ord a => Set a -> Set a -> Set a (\\) (Set x) (Set y) = Set (I.difference x y) +-- | True if the set is empty+null :: Set a -> Bool+null (Set s) = I.null s+ -- | 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@@ -54,3 +75,29 @@   -> m foldMap' f (Set arr) = I.foldMap' f arr +-- | Lazy monoidal fold over the elements in the set.+foldMap :: Monoid m+  => (a -> m)+  -> Set a+  -> m+foldMap f (Set arr) = I.foldMap f arr++-- | /O(1)/ Convert a set to an array. The elements are given in ascending+-- order. This function is zero-cost.+toArray :: Set a -> Array a+toArray (Set s) = I.toArray s++-- | Traverse a set, discarding the result.+traverse_ :: Applicative m+  => (a -> m b)+  -> Set a+  -> m ()+traverse_ f (Set arr) = I.traverse_ f arr++-- | Traverse a set with the indices, discarding the result.+itraverse_ :: Applicative m+  => (Int -> a -> m b)+  -> Set a+  -> m ()+itraverse_ f (Set arr) = I.itraverse_ f arr+{-# INLINEABLE itraverse_ #-}
src/Data/Set/Lifted/Internal.hs view
@@ -17,11 +17,15 @@  import Data.Primitive.UnliftedArray (PrimUnlifted(..)) import Data.Functor.Classes (Eq1(liftEq),Show1(liftShowsPrec))+import Data.Hashable (Hashable)+import Data.Hashable.Lifted (Hashable1) import Data.Primitive (Array) import Data.Semigroup (Semigroup) import Text.Show (showListWith)  import qualified Data.Foldable as F+import qualified Data.Hashable as H+import qualified Data.Hashable.Lifted as HL import qualified Data.Semigroup as SG import qualified Data.Set.Internal as I import qualified GHC.Exts as E@@ -68,6 +72,12 @@ instance Show1 Set where   liftShowsPrec f _ p s = showParen (p > 10) $    showString "fromList " . showListWith (f 0) (toList s)++instance Hashable1 Set where+  liftHashWithSalt f s (Set arr) = I.liftHashWithSalt f s arr++instance Hashable a => Hashable (Set a) where+  hashWithSalt = HL.hashWithSalt1  -- | Convert a set to a list. The elements are given in ascending order. toList :: Set a -> [a]
src/Data/Set/Unboxed.hs view
@@ -6,71 +6,46 @@  {-# OPTIONS_GHC -Wall #-} module Data.Set.Unboxed-  ( Set+  ( S.Set+  , empty   , singleton+  , null   , member   , size   , difference   , (\\)+  , intersection     -- * List Conversion-  , toList-  , fromList+  , S.toList+  , S.fromList     -- * Folds   , foldr+  , foldMap   , foldl'   , foldr'   , foldMap'+    -- * Traversals+  , traverse_+  , itraverse_   ) where -import Prelude hiding (foldr)+import Prelude hiding (foldr,foldMap,null)+import Data.Hashable (Hashable)+import Data.Primitive.PrimArray (PrimArray) import Data.Primitive.Types (Prim) import Data.Primitive.UnliftedArray (PrimUnlifted(..))-import Data.Primitive.PrimArray (PrimArray) import Data.Semigroup (Semigroup)+import Data.Set.Unboxed.Internal (Set(..)) import qualified Data.Foldable as F+import qualified Data.Hashable as H 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+import qualified Data.Set.Unboxed.Internal as S -instance (Prim a, Show a) => Show (Set a) where-  showsPrec p (Set s) = I.showsPrec p s+-- | The empty set.+empty :: Set a+empty = Set I.empty  -- | The difference of two sets. difference :: (Ord a, Prim a) => Set a -> Set a -> Set a@@ -79,22 +54,23 @@ -- | Infix operator for 'difference'. (\\) :: (Ord a, Prim a) => Set a -> Set a -> Set a (\\) (Set x) (Set y) = Set (I.difference x y)++-- | The intersection of two sets.+intersection :: (Ord a, Prim a) => Set a -> Set a -> Set a+intersection (Set x) (Set y) = Set (I.intersection 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 +-- | /O(1)/ Is the set empty?+null :: Set a -> Bool+null (Set s) = I.null 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@@ -130,5 +106,25 @@   -> m foldMap' f (Set arr) = I.foldMap' f arr +-- | Lazy 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 +-- | Traverse a set, discarding the result.+traverse_ :: (Applicative m, Prim a)+  => (a -> m b)+  -> Set a+  -> m ()+traverse_ f (Set arr) = I.traverse_ f arr++-- | Traverse a set with the indices, discarding the result.+itraverse_ :: (Applicative m, Prim a)+  => (Int -> a -> m b)+  -> Set a+  -> m ()+itraverse_ f (Set arr) = I.itraverse_ f arr+{-# INLINEABLE itraverse_ #-}
+ src/Data/Set/Unboxed/Internal.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Set.Unboxed.Internal+  ( Set(..)+  , toList+  , fromList+  ) where++import Prelude hiding (foldr)++import Data.Hashable (Hashable)+import Data.Primitive (Prim,PrimArray,Array,PrimUnlifted(..))+import Data.Semigroup (Semigroup)+import Text.Show (showListWith)++import qualified Data.Foldable as F+import qualified Data.Hashable as H+import qualified Data.Semigroup as SG+import qualified Data.Set.Internal as I+import qualified GHC.Exts as E++-- | 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++instance (Hashable a, Prim a) => Hashable (Set a) where+  hashWithSalt s (Set arr) = I.liftHashWithSalt H.hashWithSalt s arr++-- | 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++-- | 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)++
src/Data/Set/Unlifted.hs view
@@ -6,63 +6,49 @@  {-# OPTIONS_GHC -O2 #-} module Data.Set.Unlifted-  ( Set+  ( S.Set+  , empty   , singleton+  , null   , member   , size+  , difference+  , intersection+    -- * Conversion+  , toArray+  , S.toList+  , S.fromList+    -- * Folds+  , foldr+  , foldMap+  , foldl'+  , foldr'+  , foldMap'+    -- * Traversals+  , traverse_+  , itraverse_   ) where +import Prelude hiding (foldr,foldMap,null)+ 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 Data.Set.Unlifted.Internal (Set(..)) 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+import qualified Data.Set.Unlifted.Internal as S  -- | Test for membership in the set. member :: (PrimUnlifted a, Ord a) => a -> Set a -> Bool member a (Set s) = I.member a s +-- | The empty set.+empty :: Set a+empty = Set I.empty++-- | True if the set is empty+null :: Set a -> Bool+null (Set s) = I.null s+ -- | Construct a set with a single element. singleton :: PrimUnlifted a => a -> Set a singleton = Set . I.singleton@@ -71,4 +57,68 @@ size :: PrimUnlifted a => Set a -> Int size (Set s) = I.size s +-- | The difference of two sets.+difference :: (PrimUnlifted a, Ord a) => Set a -> Set a -> Set a+difference (Set x) (Set y) = Set (I.difference x y)++-- | The intersection of two sets.+intersection :: (Ord a, PrimUnlifted a) => Set a -> Set a -> Set a+intersection (Set x) (Set y) = Set (I.intersection x y)++-- | /O(1)/ Convert a set to an array. The elements are given in ascending+-- order. This function is zero-cost.+toArray :: Set a -> UnliftedArray a+toArray (Set s) = I.toArray s++-- | Right fold over the elements in the set. This is lazy in the accumulator.+foldr :: PrimUnlifted a+  => (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr f b0 (Set s) = I.foldr f b0 s++-- | Monoidal fold over the elements in the set. This is lazy in the accumulator.+foldMap :: (PrimUnlifted a, Monoid m)+  => (a -> m)+  -> Set a+  -> m+foldMap f (Set s) = I.foldMap f s++-- | Strict left fold over the elements in the set.+foldl' :: PrimUnlifted a+  => (b -> a -> b)+  -> b+  -> Set a+  -> b+foldl' f b0 (Set s) = I.foldl' f b0 s++-- | Strict right fold over the elements in the set.+foldr' :: PrimUnlifted a+  => (a -> b -> b)+  -> b+  -> Set a+  -> b+foldr' f b0 (Set s) = I.foldr' f b0 s++-- | Strict monoidal fold over the elements in the set.+foldMap' :: (PrimUnlifted a, Monoid m)+  => (a -> m)+  -> Set a+  -> m+foldMap' f (Set arr) = I.foldMap' f arr++-- | Traverse a set, discarding the result.+traverse_ :: (Applicative m, PrimUnlifted a)+  => (a -> m b)+  -> Set a+  -> m ()+traverse_ f (Set arr) = I.traverse_ f arr++-- | Traverse a set with the indices, discarding the result.+itraverse_ :: (Applicative m, PrimUnlifted a)+  => (Int -> a -> m b)+  -> Set a+  -> m ()+itraverse_ f (Set arr) = I.itraverse_ f arr
+ src/Data/Set/Unlifted/Internal.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Set.Unlifted.Internal+  ( Set(..)+  , toList+  , fromList+  ) where++import Prelude hiding (foldr)++import Data.Hashable (Hashable)+import Data.Primitive.UnliftedArray (PrimUnlifted(..),UnliftedArray)+import Data.Primitive (Array)+import Data.Semigroup (Semigroup)+import Text.Show (showListWith)++import qualified Data.Foldable as F+import qualified Data.Hashable as H+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 UnliftedArray a }++instance PrimUnlifted (Set a) where+  toArrayArray# (Set x) = toArrayArray# x+  fromArrayArray# y = Set (fromArrayArray# y)++instance (Ord a, PrimUnlifted a) => Semigroup (Set a) where+  Set x <> Set y = Set (I.append x y)+  stimes = SG.stimesIdempotentMonoid+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))++instance (Hashable a, PrimUnlifted a) => Hashable (Set a) where+  hashWithSalt s (Set arr) = I.liftHashWithSalt H.hashWithSalt s arr++instance (PrimUnlifted a, 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 = toList++instance (PrimUnlifted a, Show a) => Show (Set a) where+  showsPrec p (Set s) = I.showsPrec p s++-- | /O(n)/ Convert a set to a list. The elements are given in ascending order.+toList :: PrimUnlifted a => Set a -> [a]+toList (Set s) = I.toList s++-- | /O(n*log n)/ Convert a list to a set.+fromList :: (PrimUnlifted a, Ord a) => [a] -> Set a+fromList = Set . I.fromList+
test/Main.hs view
@@ -1,12 +1,19 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedTuples #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -15,11 +22,30 @@ import Data.Word import Data.Proxy (Proxy(..)) import Data.Int+import Data.Functor.Const (Const(..))+import Data.Kind (Type)  import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.Tasty.HUnit (testCase,(@?=)) import Test.QuickCheck (Arbitrary,Gen,(===),(==>))+import Test.HUnit.Base (assertEqual)+import Data.Bool (bool) import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Exists (ToSing(..),DependentPair(..),ShowForall(..),ShowForeach(..))+import Data.Exists (WitnessedEquality(..),WitnessedOrdering(..),EqForall(..),OrdForall(..))+import Data.Exists (EqForeach(..),OrdForeach(..),EqForallPoly(..),OrdForallPoly(..),Sing)+import Data.Exists (PrimForall(..),ToJSONKeyForall(..),ToJSONKeyFunctionForall(..))+import Data.Exists (ToJSONForeach(..),FromJSONKeyExists(..),Exists(..))+import Data.Exists (FromJSONForeach(..)) import Control.Monad (forM)+import Data.Semigroup (Semigroup)+import Unsafe.Coerce (unsafeCoerce)+import Data.Dependent.Map.Class (Universally(..),ApplyUniversally(..))+import Text.Read (readMaybe)+import Data.Continuous.Set.Lifted (Inclusivity(..))+import qualified Data.Aeson as AE+import qualified Data.Aeson.Encoding as AEE+import qualified Data.Text as T import qualified Test.Tasty.QuickCheck as TQC import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Classes as QCC@@ -34,11 +60,14 @@ 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.Map.Strict.Unboxed.Lifted as DMUL+import qualified Data.Diet.Map.Strict.Lifted.Lifted as DMLL import qualified Data.Diet.Set.Lifted as DSL+import qualified Data.Continuous.Set.Lifted as CSL import qualified Data.Diet.Unbounded.Set.Lifted as DUSL-import qualified Data.Map.Subset.Lifted as MSL+import qualified Data.Dependent.Map.Lifted.Lifted as DPMLL+import qualified Data.Dependent.Map.Unboxed.Lifted as DPMUL+import qualified Data.Map.Subset.Strict.Lifted as MSL  main :: IO () main = defaultMain $ testGroup "Data"@@ -59,7 +88,12 @@       , 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 "foldMap" foldMapSetProp+      , TQC.testProperty "foldMap'" foldMapStrictSetProp       , TQC.testProperty "difference" differenceProp+      , TQC.testProperty "intersection" intersectionProp+      , TQC.testProperty "traverse_" traverseSetProp+      , TQC.testProperty "itraverse_" itraverseSetProp       ]     , testGroup "Unlifted"       [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))@@ -81,9 +115,58 @@         , TQC.testProperty "foldlWithKey'" (mapFoldAgreement MUU.foldlWithKey' M.foldlWithKey)         , TQC.testProperty "foldrWithKey'" (mapFoldAgreement MUU.foldrWithKey' M.foldrWithKey)         , TQC.testProperty "foldMapWithKey'" (mapFoldMonoidAgreement MUU.foldMapWithKey' M.foldMapWithKey)+        , TQC.testProperty "mapMaybe" mapMaybeProp         ]       ]     ]+  , testGroup "Dependent"+    [ testGroup "Map"+      [ testGroup "Lifted"+        [ testGroup "Lifted"+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+          , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMLL.Map Key Value)))+          ]+        ]+      , testGroup "Unboxed"+        [ testGroup "Lifted"+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))+          , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))+          , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))+          ]+        ]+      ]+    ]+  , testGroup "Continuous"+    [ testGroup "Set"+      [ testGroup "Lifted"+        [ testGroup "Unit" +          [ testCase "A" $ do+              let s = CSL.singleton Nothing (Just (Inclusive,55 :: Integer))+                      <>+                      CSL.singleton (Just (Exclusive,200 :: Integer)) Nothing+                  str = show s+              assertEqual (str ++ " contains 50") (CSL.member 50 s) True+              assertEqual (str ++ " contains 270") (CSL.member 270 s) True+              assertEqual (str ++ " contains 55") (CSL.member 55 s) True+              assertEqual (str ++ " does not contain 200") (CSL.member 200 s) False+              assertEqual (str ++ " does not contain 56") (CSL.member 56 s) False+          , testCase "B" $ do+              let s = CSL.singleton Nothing (Just (Inclusive,14 :: Integer))+                      <>+                      CSL.singleton (Just (Exclusive,14 :: Integer)) Nothing+              s @?= CSL.universe+          , testCase "C" $ do+              let s = CSL.singleton Nothing (Just (Exclusive,14 :: Integer))+                      <>+                      CSL.singleton (Just (Exclusive,14 :: Integer)) Nothing+                  str = show s+              assertEqual (str ++ " does not contain 14") (CSL.member 14 s) False+          ]+        ]+      ]+    ]   , testGroup "Diet"     [ testGroup "Unbounded"       [ testGroup "Set"@@ -101,6 +184,8 @@         , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DSL.Set Word16)))         , TQC.testProperty "member" (dietMemberProp @Word8 E.fromList DSL.member)         , TQC.testProperty "difference" dietSetDifferenceProp+        , TQC.testProperty "intersection" dietSetIntersectionProp+        , TQC.testProperty "negate" dietSetNegateProp         , TQC.testProperty "aboveInclusive" dietSetAboveProp         , testGroup "belowInclusive"           [ TQC.testProperty "basic" dietSetBelowProp@@ -164,6 +249,18 @@       ys' = dietSetToSet ys    in DSL.difference xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.difference xs' ys'))) +dietSetIntersectionProp :: QC.Property+dietSetIntersectionProp = QC.property $ \(xs :: DSL.Set Word8) (ys :: DSL.Set Word8) ->+  let xs' = dietSetToSet xs+      ys' = dietSetToSet ys+   in DSL.intersection xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.intersection xs' ys')))++dietSetNegateProp :: QC.Property+dietSetNegateProp = QC.property $ \(xs :: DSL.Set Word8) ->+  let xs' = dietSetToSet xs+      expected = foldMap (\n -> bool (S.singleton n) mempty (S.member n xs')) [minBound..maxBound]+   in DSL.negate xs === mconcat (map (\x -> DSL.singleton x x) (F.toList expected))+ dietSetAboveProp :: QC.Property dietSetAboveProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) ->   let ys' = dietSetToSet ys@@ -234,7 +331,7 @@ -- 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)+  (\lo hi s -> S.fromList (enumFromTo lo hi) SG.<> s)   mempty  differenceProp :: QC.Property@@ -243,6 +340,39 @@       ys' = SL.fromList (S.toList ys)    in SL.toList (SL.difference xs' ys') === S.toList (S.difference xs ys) +intersectionProp :: QC.Property+intersectionProp = 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.intersection xs' ys') === S.toList (S.intersection xs ys)++traverseSetProp :: QC.Property+traverseSetProp = QC.property $ \(xs :: S.Set Word8) ->+  let xs' = SL.fromList (S.toList xs)+   in SL.traverse_ (Const . SG.Sum) xs' === F.traverse_ (Const . SG.Sum) xs++foldMapSetProp :: QC.Property+foldMapSetProp = QC.property $ \(xs :: S.Set Word8) ->+  let xs' = SL.fromList (S.toList xs)+   in SL.foldMap SG.Sum xs' === F.foldMap SG.Sum xs++foldMapStrictSetProp :: QC.Property+foldMapStrictSetProp = QC.property $ \(xs :: S.Set Word8) ->+  let xs' = SL.fromList (S.toList xs)+   in SL.foldMap' SG.Sum xs' === F.foldMap SG.Sum xs++mapMaybeProp :: QC.Property+mapMaybeProp = QC.property $ \(xs :: M.Map Word8 Word8) ->+  let xs' = MUU.fromList (M.toList xs)+      func x = if even x then Just (x * x) else Nothing+   in MUU.toList (MUU.mapMaybe func xs') === M.toList (M.mapMaybe func xs)++itraverseSetProp :: QC.Property+itraverseSetProp = QC.property $ \(xs :: S.Set Int) ->+  let xs' = SL.fromList (S.toList xs)+      zs = zip (enumFrom (0 :: Int)) (S.toList xs)+   in SL.itraverse_ (\ix x -> Const (SG.Sum (ix + x))) xs' === F.traverse_ (\(ix,x) -> Const (SG.Sum (ix + x))) zs+ mapFoldMonoidAgreement ::      ((Int -> Int -> [Int]) -> MUU.Map Int Int -> [Int])   -> ((Int -> Int -> [Int]) -> M.Map Int Int -> [Int])@@ -290,7 +420,7 @@ 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))+  (simpleDoubletonToList loA hiA valA loB hiB valB === E.toList (DMLL.singleton loA hiA valA SG.<> DMLL.singleton loB hiB valB))  dietValidProp :: QC.Property dietValidProp = QC.property $ \(xs :: DMLL.Map Word8 Int) ->@@ -465,4 +595,245 @@   mappend = (SG.<>)  deriving instance Arbitrary a => Arbitrary (SG.First a)++data Universe+  = UniverseInt+  | UniverseOrdering+  | UniverseBool+  | UniverseChar++data SingUniverse :: Universe -> Type where+  SingUniverseInt :: SingUniverse 'UniverseInt+  SingUniverseOrdering :: SingUniverse 'UniverseOrdering+  SingUniverseBool :: SingUniverse 'UniverseBool+  SingUniverseChar :: SingUniverse 'UniverseChar++deriving instance Show (SingUniverse u)++type instance Sing = SingUniverse++type family Interpret (u :: Universe) :: Type where+  Interpret 'UniverseInt = Int+  Interpret 'UniverseOrdering = Ordering+  Interpret 'UniverseBool = Bool+  Interpret 'UniverseChar = Char++newtype Value :: Universe -> Type where+  Value :: Interpret u -> Value u++instance EqForeach Value where+  eqForeach SingUniverseInt (Value x) (Value y) = x == y+  eqForeach SingUniverseOrdering (Value x) (Value y) = x == y+  eqForeach SingUniverseBool (Value x) (Value y) = x == y+  eqForeach SingUniverseChar (Value x) (Value y) = x == y++instance OrdForeach Value where+  compareForeach SingUniverseInt (Value x) (Value y) = compare x y+  compareForeach SingUniverseOrdering (Value x) (Value y) = compare x y+  compareForeach SingUniverseBool (Value x) (Value y) = compare x y+  compareForeach SingUniverseChar (Value x) (Value y) = compare x y++instance ShowForeach Value where+  showsPrecForeach SingUniverseInt p (Value x) = showsPrec p x+  showsPrecForeach SingUniverseBool p (Value x) = showsPrec p x+  showsPrecForeach SingUniverseOrdering p (Value x) = showsPrec p x+  showsPrecForeach SingUniverseChar p (Value x) = showsPrec p x++-- This type interpret the lowest two bits of the Word8+-- as the Universe value. Doing this is unsafe, but if the+-- data constructor of a type like this is not exported, it+-- is possible to build safe interfaces on top of this.+newtype UnboxedKey u = UnboxedKey Word8+  deriving (Show,Prim,Eq,Ord)++unboxedIntKey :: Word8 -> UnboxedKey 'UniverseInt+unboxedIntKey w = UnboxedKey (w * 4 + 0)++unboxedBoolKey :: Word8 -> UnboxedKey 'UniverseBool+unboxedBoolKey w = UnboxedKey (w * 4 + 1)++unboxedOrderingKey :: Word8 -> UnboxedKey 'UniverseOrdering+unboxedOrderingKey w = UnboxedKey (w * 4 + 2)++unboxedCharKey :: Word8 -> UnboxedKey 'UniverseChar+unboxedCharKey w = UnboxedKey (w * 4 + 3)++instance ToJSONKeyForall UnboxedKey where+  toJSONKeyForall = ToJSONKeyTextForall+    (\(UnboxedKey n) -> T.pack (show n))+    (\(UnboxedKey n) -> AEE.text (T.pack (show n)))++instance FromJSONKeyExists UnboxedKey where+  fromJSONKeyExists = AE.FromJSONKeyTextParser+    (\t -> case readMaybe (T.unpack t) of+      Nothing -> fail "Value, FromJSONKeyExists: bad value"+      Just w -> return (Exists (UnboxedKey w))+    )++instance FromJSONForeach Value where+  parseJSONForeach SingUniverseInt = fmap Value . AE.parseJSON +  parseJSONForeach SingUniverseBool = fmap Value . AE.parseJSON+  parseJSONForeach SingUniverseOrdering = fmap Value . AE.parseJSON+  parseJSONForeach SingUniverseChar = fmap Value . AE.parseJSON++instance ToJSONForeach Value where+  toJSONForeach SingUniverseInt (Value a) = AE.toJSON a+  toJSONForeach SingUniverseBool (Value a) = AE.toJSON a+  toJSONForeach SingUniverseOrdering (Value a) = AE.toJSON a+  toJSONForeach SingUniverseChar (Value a) = AE.toJSON a++instance ToSing UnboxedKey where+  toSing (UnboxedKey w) = case mod w 4 of+    0 -> unsafeCoerce SingUniverseInt+    1 -> unsafeCoerce SingUniverseBool+    2 -> unsafeCoerce SingUniverseOrdering+    _ -> unsafeCoerce SingUniverseChar++instance ShowForall UnboxedKey where+  showsPrecForall = showsPrec++instance EqForall UnboxedKey where+  eqForall = (==)++instance EqForallPoly UnboxedKey where+  eqForallPoly (UnboxedKey a) (UnboxedKey b) = if a == b+    then unsafeCoerce WitnessedEqualityEqual+    else WitnessedEqualityUnequal++instance OrdForall UnboxedKey where+  compareForall = compare++instance OrdForallPoly UnboxedKey where+  compareForallPoly (UnboxedKey a) (UnboxedKey b) = case compare a b of+    LT -> WitnessedOrderingLT+    GT -> WitnessedOrderingGT+    EQ -> unsafeCoerce WitnessedOrderingEQ++data Key u = Key !Int !(SingUniverse u)+  deriving (Show)++instance ShowForall Key where+  showsPrecForall = showsPrec++instance ToSing Key where+  toSing (Key _ s) = s++instance EqForall Key where+  eqForall (Key i1 _) (Key i2 _) = i1 == i2++instance OrdForall Key where+  compareForall (Key i1 _) (Key i2 _) = compare i1 i2++instance EqForallPoly Key where+  eqForallPoly (Key i1 s1) (Key i2 s2) = if i1 == i2+    then case s1 of+      SingUniverseInt -> case s2 of+        SingUniverseInt -> WitnessedEqualityEqual+        _ -> WitnessedEqualityUnequal+      SingUniverseOrdering -> case s2 of+        SingUniverseOrdering -> WitnessedEqualityEqual+        _ -> WitnessedEqualityUnequal+      SingUniverseBool -> case s2 of+        SingUniverseBool -> WitnessedEqualityEqual+        _ -> WitnessedEqualityUnequal+      SingUniverseChar -> case s2 of+        SingUniverseChar -> WitnessedEqualityEqual+        _ -> WitnessedEqualityUnequal+    else WitnessedEqualityUnequal++instance EqForall SingUniverse where+  eqForall _ _ = True++instance OrdForall SingUniverse where+  compareForall _ _ = EQ++instance EqForallPoly SingUniverse where+  eqForallPoly SingUniverseInt SingUniverseInt = WitnessedEqualityEqual+  eqForallPoly SingUniverseInt _ = WitnessedEqualityUnequal+  eqForallPoly SingUniverseBool SingUniverseBool = WitnessedEqualityEqual+  eqForallPoly SingUniverseBool _ = WitnessedEqualityUnequal+  eqForallPoly SingUniverseOrdering SingUniverseOrdering = WitnessedEqualityEqual+  eqForallPoly SingUniverseOrdering _ = WitnessedEqualityUnequal+  eqForallPoly SingUniverseChar SingUniverseChar = WitnessedEqualityEqual+  eqForallPoly SingUniverseChar _ = WitnessedEqualityUnequal++instance OrdForallPoly SingUniverse where+  compareForallPoly SingUniverseInt SingUniverseInt      = WitnessedOrderingEQ+  compareForallPoly SingUniverseInt SingUniverseOrdering = WitnessedOrderingLT+  compareForallPoly SingUniverseInt SingUniverseBool     = WitnessedOrderingLT+  compareForallPoly SingUniverseInt SingUniverseChar     = WitnessedOrderingLT+  compareForallPoly SingUniverseOrdering SingUniverseInt      = WitnessedOrderingGT+  compareForallPoly SingUniverseOrdering SingUniverseOrdering = WitnessedOrderingEQ+  compareForallPoly SingUniverseOrdering SingUniverseBool     = WitnessedOrderingLT+  compareForallPoly SingUniverseOrdering SingUniverseChar     = WitnessedOrderingLT+  compareForallPoly SingUniverseBool SingUniverseInt      = WitnessedOrderingGT+  compareForallPoly SingUniverseBool SingUniverseOrdering = WitnessedOrderingGT+  compareForallPoly SingUniverseBool SingUniverseBool     = WitnessedOrderingEQ+  compareForallPoly SingUniverseBool SingUniverseChar     = WitnessedOrderingLT+  compareForallPoly SingUniverseChar SingUniverseInt      = WitnessedOrderingGT+  compareForallPoly SingUniverseChar SingUniverseOrdering = WitnessedOrderingGT+  compareForallPoly SingUniverseChar SingUniverseBool     = WitnessedOrderingGT+  compareForallPoly SingUniverseChar SingUniverseChar     = WitnessedOrderingEQ++instance OrdForallPoly Key where+  compareForallPoly (Key i1 s1) (Key i2 s2) = case compare i1 i2 of+    LT -> WitnessedOrderingLT+    GT -> WitnessedOrderingGT+    EQ -> compareForallPoly s1 s2++class ArbitraryDependentPair k v where+  arbitraryDependentPair :: Gen (DependentPair k v)++instance ArbitraryDependentPair k v => Arbitrary (DependentPair k v) where+  arbitrary = arbitraryDependentPair++instance ArbitraryDependentPair Key Value where+  arbitraryDependentPair = do+    (i :: Int) <- QC.choose (0, 10)+    QC.oneof+      [ DependentPair (Key i SingUniverseInt) . Value <$> QC.arbitrary+      , DependentPair (Key i SingUniverseBool) . Value <$> QC.arbitrary+      , DependentPair (Key i SingUniverseChar) . Value <$> QC.arbitrary+      , DependentPair (Key i SingUniverseOrdering) . Value <$> QC.arbitrary+      ]++instance ArbitraryDependentPair UnboxedKey Value where+  arbitraryDependentPair = do+    (i :: Word8) <- QC.choose (0, 10)+    QC.oneof+      [ DependentPair (unboxedIntKey i) . Value <$> QC.arbitrary+      , DependentPair (unboxedBoolKey i) . Value <$> QC.arbitrary+      , DependentPair (unboxedCharKey i) . Value <$> QC.arbitrary+      , DependentPair (unboxedOrderingKey i) . Value <$> QC.arbitrary+      ]+    +instance (ArbitraryDependentPair k v, OrdForallPoly k) => Arbitrary (DPMLL.Map k v) where+  arbitrary = do+    len <- QC.choose (0,35)+    DPMLL.fromList <$> QC.vectorOf len arbitraryDependentPair++instance (ArbitraryDependentPair k v, OrdForallPoly k, Universally k Prim, ApplyUniversally k Prim) => Arbitrary (DPMUL.Map k v) where+  arbitrary = do+    len <- QC.choose (0,35)+    DPMUL.fromList <$> QC.vectorOf len arbitraryDependentPair++instance Universally UnboxedKey Prim where+  universally _ _ _ x = x++instance ApplyUniversally UnboxedKey Prim where+  applyUniversallyLifted _ _ _ x = x+  applyUniversallyUnlifted _ _ _ x = x++-- very unsafe instance+instance PrimForall UnboxedKey where+  sizeOfForall# _ = sizeOf# (undefined :: UnboxedKey a)+  alignmentForall# _ = alignment# (undefined :: UnboxedKey a)+  indexByteArrayForall# = indexByteArray#+  readByteArrayForall# = readByteArray#+  writeByteArrayForall# = writeByteArray#+  setByteArrayForall# = setByteArray#+  readOffAddrForall# = readOffAddr#+  writeOffAddrForall# = writeOffAddr#+  indexOffAddrForall# = indexOffAddr#+  setOffAddrForall# = setOffAddr#