typerep-map 0.3.3.0 → 0.4.0.0
raw patch · 11 files changed
+459/−138 lines, 11 filesdep ~basedep ~ghc-primdep ~hspec
Dependency ranges changed: base, ghc-prim, hspec
Files
- CHANGELOG.md +18/−1
- README.md +0/−4
- benchmark/CMap.hs +8/−8
- benchmark/CacheMap.hs +6/−6
- benchmark/DMap.hs +6/−6
- src/Data/TMap.hs +57/−9
- src/Data/TypeRepMap.hs +14/−5
- src/Data/TypeRepMap/Internal.hs +209/−57
- test/Test/TypeRep/TypeRepMap.hs +62/−4
- test/Test/TypeRep/TypeRepMapProperty.hs +69/−26
- typerep-map.cabal +10/−12
CHANGELOG.md view
@@ -3,6 +3,23 @@ `typerep-map` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.4.0.0 — Aug 3, 2021++* [#109](https://github.com/kowainik/typerep-map/issues/109):+ Support GHC-9.0.+* [#30](https://github.com/kowainik/typerep-map/issues/30):+ Remove `containers` from dependencies.+* [#94](https://github.com/kowainik/typerep-map/issues/94),+ [#99](https://github.com/kowainik/typerep-map/issues/99),+ [#100](https://github.com/kowainik/typerep-map/issues/100):+ Improve performance of `insert` and `delete`.+* [#95](https://github.com/kowainik/typerep-map/issues/95):+ Add `alter`.+* [#96](https://github.com/kowainik/typerep-map/issues/96):+ Add `intersection` and `intersectionWith`.+* [#105](https://github.com/kowainik/typerep-map/issues/105):+ Add `keysWith` and `toListWith`.+ ## 0.3.3.0 — Apr 18, 2020 * [#83](https://github.com/kowainik/typerep-map/issues/83):@@ -53,4 +70,4 @@ * Initially created. [1]: https://pvp.haskell.org-[2]: https://github.com/kowainik/typerep-map/blob/master/CHANGELOG.md+[2]: https://github.com/kowainik/typerep-map/releases
README.md view
@@ -3,11 +3,7 @@  [](https://github.com/kowainik/typerep-map/actions)-[](https://travis-ci.org/kowainik/typerep-map)-[](https://ci.appveyor.com/project/kowainik/typerep-map) [](https://hackage.haskell.org/package/typerep-map)-[](http://stackage.org/lts/package/typerep-map)-[](http://stackage.org/nightly/package/typerep-map) [](LICENSE)
benchmark/CMap.hs view
@@ -17,7 +17,7 @@ import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable)-import GHC.TypeLits (type (+), KnownNat, Nat)+import GHC.TypeLits (KnownNat, Nat, type (+)) import Data.TypeRep.CMap (TypeRepMap (..), empty, insert, lookup) @@ -30,16 +30,16 @@ env (mkMap 10000) $ \ ~bigMap -> bench name $ nf tenLookups bigMap , benchInsertSmall = Just $ \name ->- bench name $ whnf (inserts empty 10) (Proxy @ 99999)+ bench name $ whnf (inserts empty 10) (Proxy @99999) , benchInsertBig = Just $ \name -> env (mkMap 10000) $ \ ~bigMap ->- bench name $ whnf (inserts bigMap 1) (Proxy @ 99999)+ bench name $ whnf (inserts bigMap 1) (Proxy @99999) , benchUpdateSmall = Just $ \name -> env (mkMap 10) $ \ ~smallMap ->- bench name $ whnf (inserts smallMap 10) (Proxy @ 0)+ bench name $ whnf (inserts smallMap 10) (Proxy @0) , benchUpdateBig = Just $ \name -> env (mkMap 10000) $ \ ~bigMap ->- bench name $ whnf (inserts bigMap 10) (Proxy @ 0)+ bench name $ whnf (inserts bigMap 10) (Proxy @0) } tenLookups@@ -49,7 +49,7 @@ ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where- lp :: forall (a::Nat). Typeable a => Proxy a+ lp :: forall (a :: Nat) . Typeable a => Proxy a lp = fromJust $ lookup tmap inserts@@ -61,8 +61,8 @@ inserts !c 0 _ = c inserts !c n x = inserts (insert x c)- (n-1)- (Proxy :: Proxy (a+1))+ (n - 1)+ (Proxy :: Proxy (a + 1)) mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> Type)) mkMap n = pure $ buildBigMap n (Proxy :: Proxy 0) empty
benchmark/CacheMap.hs view
@@ -18,7 +18,7 @@ import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import GHC.Exts (fromList)-import GHC.TypeLits (type (+), KnownNat, Nat)+import GHC.TypeLits (KnownNat, Nat, type (+)) import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), empty, insert, lookup) @@ -31,16 +31,16 @@ env (mkMap 10000) $ \ ~bigMap -> bench name $ nf tenLookups bigMap , benchInsertSmall = Just $ \name ->- bench name $ whnf (inserts empty 10) (Proxy @ 99999)+ bench name $ whnf (inserts empty 10) (Proxy @99999) , benchInsertBig = Just $ \name -> env (mkMap 10000) $ \ ~bigMap ->- bench name $ whnf (inserts bigMap 1) (Proxy @ 99999)+ bench name $ whnf (inserts bigMap 1) (Proxy @99999) , benchUpdateSmall = Just $ \name -> env (mkMap 10) $ \ ~smallMap ->- bench name $ whnf (inserts smallMap 10) (Proxy @ 0)+ bench name $ whnf (inserts smallMap 10) (Proxy @0) , benchUpdateBig = Just $ \name -> env (mkMap 10000) $ \ ~bigMap ->- bench name $ whnf (inserts bigMap 10) (Proxy @ 0)+ bench name $ whnf (inserts bigMap 10) (Proxy @0) } tenLookups@@ -62,7 +62,7 @@ inserts !c 0 _ = c inserts !c n x = inserts (insert x c)- (n-1)+ (n - 1) (Proxy :: Proxy (a + 1)) mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> Type))
benchmark/DMap.hs view
@@ -18,7 +18,7 @@ import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..))-import GHC.TypeLits (type (+), KnownNat, Nat)+import GHC.TypeLits (KnownNat, Nat, type (+)) import Type.Reflection (TypeRep, Typeable, typeRep) import Type.Reflection.Unsafe (typeRepFingerprint) @@ -36,10 +36,10 @@ env mkBigMap $ \ ~(DMapNF bigMap) -> bench name $ nf tenLookups bigMap , benchInsertSmall = Just $ \name ->- bench name $ whnf (inserts empty 10) (Proxy @ 99999)+ bench name $ whnf (inserts empty 10) (Proxy @99999) , benchInsertBig = Just $ \name -> env mkBigMap $ \ ~(DMapNF bigMap) ->- bench name $ whnf (inserts bigMap 1) (Proxy @ 99999)+ bench name $ whnf (inserts bigMap 1) (Proxy @99999) , benchUpdateSmall = Nothing -- Not implemented , benchUpdateBig = Nothing -- Not implemented }@@ -62,9 +62,9 @@ -> TypeRepMap (Proxy :: Nat -> Type) inserts !c 0 _ = c inserts !c n x = inserts- (insert (typeRep @ a) x c)- (n-1)- (Proxy :: Proxy (a+1))+ (insert (typeRep @a) x c)+ (n - 1)+ (Proxy :: Proxy (a + 1)) -- TypeRepMap of 10000 elements mkBigMap :: IO (DMapNF (Proxy :: Nat -> Type))
src/Data/TMap.hs view
@@ -2,9 +2,12 @@ {-# LANGUAGE Rank2Types #-} {- |-Copyright: (c) 2017-2020 Kowainik-SPDX-License-Identifier: MPL-2.0-Maintainer: Kowainik <xrom.xkov@gmail.com>+Module : Data.TMap+Copyright : (c) 2017-2021 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable 'TMap' is a heterogeneous data structure similar in its essence to 'Data.Map.Map' with types as keys, where each value has the type of its key.@@ -21,7 +24,6 @@ The runtime representation of 'TMap' is an array, not a tree. This makes 'lookup' significantly more efficient.- -} module Data.TMap@@ -37,14 +39,19 @@ , delete , unionWith , union+ , intersectionWith+ , intersection , map , adjust+ , alter -- * Query , lookup , member , size , keys+ , keysWith+ , toListWith ) where import Prelude hiding (lookup, map)@@ -52,7 +59,7 @@ import Data.Functor.Identity (Identity (..)) import Data.Typeable (Typeable) import GHC.Exts (coerce)-import Type.Reflection (SomeTypeRep)+import Type.Reflection (SomeTypeRep, TypeRep) import qualified Data.TypeRepMap as F @@ -87,6 +94,7 @@ {- | Insert a value into a 'TMap'.+TMap optimizes for fast reads rather than inserts, as a trade-off inserts are @O(n)@. prop> size (insert v tm) >= size tm prop> member @a (insert (x :: a) tm) == True@@ -98,6 +106,9 @@ {- | Delete a value from a 'TMap'. +TMap optimizes for fast reads rather than modifications, as a trade-off deletes are @O(n)@,+with an @O(log(n))@ optimization for when the element is already missing.+ prop> size (delete @a tm) <= size tm prop> member @a (delete @a tm) == False @@ -114,7 +125,7 @@ {-# INLINE delete #-} -- | The union of two 'TMap's using a combining function.-unionWith :: (forall x. Typeable x => x -> x -> x) -> TMap -> TMap -> TMap+unionWith :: (forall x . Typeable x => x -> x -> x) -> TMap -> TMap -> TMap unionWith f = F.unionWith fId where fId :: forall y . Typeable y => Identity y -> Identity y -> Identity y@@ -127,6 +138,24 @@ union = F.union {-# INLINE union #-} +-- | The intersection of two 'TMap's using a combining function.+--+-- @O(n + m)@+intersectionWith :: (forall x . Typeable x => x -> x -> x) -> TMap -> TMap -> TMap+intersectionWith f = F.intersectionWith fId+ where+ fId :: forall y . Typeable y => Identity y -> Identity y -> Identity y+ fId y1 y2 = f (coerce y1) (coerce y2)+{-# INLINE intersectionWith #-}++-- | The intersection of two 'TMap's.+-- It keeps all values from the first map whose keys are present in the second.+--+-- @O(n + m)@+intersection :: TMap -> TMap -> TMap+intersection = F.intersection+{-# INLINE intersection #-}+ {- | Lookup a value of the given type in a 'TMap'. >>> x = lookup $ insert (11 :: Int) empty@@ -135,7 +164,7 @@ >>> x :: Maybe () Nothing -}-lookup :: forall a. Typeable a => TMap -> Maybe a+lookup :: forall a . Typeable a => TMap -> Maybe a lookup = coerce (F.lookup @a @Identity) {-# INLINE lookup #-} @@ -160,8 +189,18 @@ keys = F.keys {-# INLINE keys #-} +-- | Return the list of keys by wrapping them with a user-provided function.+keysWith :: (forall a . TypeRep a -> r) -> TMap -> [r]+keysWith = F.keysWith+{-# INLINE keysWith #-}++-- | Return the list of key-value pairs by wrapping them with a user-provided function.+toListWith :: (forall a . Typeable a => a -> r) -> TMap -> [r]+toListWith f = F.toListWith (f . runIdentity)+{-# INLINE toListWith #-}+ -- | Map a function over the values.-map :: (forall a. Typeable a => a -> a) -> TMap -> TMap+map :: (forall a . Typeable a => a -> a) -> TMap -> TMap map f = F.hoistWithKey (liftToIdentity f) {-# INLINE map #-} @@ -170,5 +209,14 @@ adjust f = F.adjust (liftToIdentity f) {-# INLINE adjust #-} -liftToIdentity :: forall a. (a -> a) -> Identity a -> Identity a+-- | Updates a value at a specific key, whether or not it exists.+-- This can be used to insert, delete, or update a value of a given type in the map.+alter :: Typeable a => (Maybe a -> Maybe a) -> TMap -> TMap+alter f = F.alter (liftF f)+ where+ liftF :: forall a . (Maybe a -> Maybe a) -> Maybe (Identity a) -> Maybe (Identity a)+ liftF = coerce+{-# INLINE alter #-}++liftToIdentity :: forall a . (a -> a) -> Identity a -> Identity a liftToIdentity = coerce
src/Data/TypeRepMap.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-} {- |-Copyright: (c) 2017-2020 Kowainik-SPDX-License-Identifier: MPL-2.0-Maintainer: Kowainik <xrom.xkov@gmail.com>+Module : Data.TypeRepMap+Copyright : (c) 2017-2021 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable - A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This+A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This sort of parametrization may be familiar to users of @vinyl@ records. @'TypeRepMap' f@ is a more efficient replacement for @DMap@@ -44,7 +47,8 @@ "border-color" -> F (rgb 148 0 211) "border-width" -> F 0.5 @---}+-}+ module Data.TypeRepMap ( -- * Map type TypeRepMap()@@ -57,17 +61,22 @@ , insert , delete , adjust+ , alter , hoist , hoistA , hoistWithKey , unionWith , union+ , intersectionWith+ , intersection -- * Query , lookup , member , size , keys+ , keysWith+ , toListWith -- * 'IsList' , WrapTypeable (..)
src/Data/TypeRepMap/Internal.hs view
@@ -20,9 +20,12 @@ -- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-} {- |-Copyright: (c) 2017-2020 Kowainik-SPDX-License-Identifier: MPL-2.0-Maintainer: Kowainik <xrom.xkov@gmail.com>+Module : Data.TypeRepMap.Internal+Copyright : (c) 2017-2021 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable Internal API for 'TypeRepMap' and operations on it. The functions here do not have any stability guarantees and can change between minor versions.@@ -42,13 +45,15 @@ import Control.Monad.Zip (mzip) import Data.Function (on) import Data.Kind (Type)-import Data.Type.Equality ((:~:) (..), TestEquality (..)) import Data.List (intercalate, nubBy) import Data.Maybe (fromMaybe)-import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,- thawArray, unsafeFreezeArray, writeArray)-import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)-import Data.Semigroup (Semigroup (..), All(..))+import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', sizeofArray, thawArray,+ unsafeFreezeArray, writeArray)+import Data.Primitive.PrimArray (MutablePrimArray, PrimArray, indexPrimArray, newPrimArray,+ primArrayFromListN, primArrayToList, sizeofPrimArray,+ unsafeFreezePrimArray, writePrimArray)+import Data.Semigroup (All (..), Semigroup (..))+import Data.Type.Equality (TestEquality (..), (:~:) (..)) import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#)) import GHC.Exts (IsList (..), inline, sortWith) import GHC.Fingerprint (Fingerprint (..))@@ -64,7 +69,6 @@ import Type.Reflection.Unsafe (typeRepFingerprint) import Unsafe.Coerce (unsafeCoerce) -import qualified Data.Map.Strict as Map import qualified GHC.Exts as GHC (fromList, toList) {- |@@ -127,7 +131,7 @@ go i | i == size tm1 = True | otherwise = case testEquality tr1i tr2i of- Nothing -> False+ Nothing -> False Just Refl -> repEq tr1i (fromAny tv1i) (fromAny tv2i) && go (i + 1) where tr1i :: TypeRep x@@ -170,33 +174,49 @@ -} one :: forall a f . Typeable a => f a -> TypeRepMap f-one x = insert x empty+one x = TypeRepMap (primArrayFromListN 1 [fa])+ (primArrayFromListN 1 [fb])+ (pure @Array v)+ (pure @Array k)+ where+ (Fingerprint fa fb, v, k) = (calcFp @a, toAny x, unsafeCoerce $ typeRep @a) {-# INLINE one #-} {- | Insert a value into a 'TypeRepMap'.+TypeRepMap optimizes for fast reads rather than inserts, as a trade-off inserts are @O(n)@. prop> size (insert v tm) >= size tm prop> member @a (insert (x :: f a) tm) == True -} insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f-insert x = fromTriples . addX . toTriples+insert x m+ | size m == 0 = one x+ | otherwise = case cachedBinarySearch (typeFp @a) (fingerprintAs m) (fingerprintBs m) of+ Nothing -> union m $ one x+ Just i -> m {trAnys = changeAnyArr i (trAnys m)} where- tripleX :: (Fingerprint, Any, Any)- tripleX@(fpX, _, _) = (calcFp @a, toAny x, unsafeCoerce $ typeRep @a)-- addX :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)]- addX l = tripleX : deleteByFst fpX l+ changeAnyArr :: Int -> Array Any -> Array Any+ changeAnyArr i trAs = runST $ do+ let n = sizeofArray trAs+ mutArr <- thawArray trAs 0 n+ writeArray mutArr i $ toAny x+ unsafeFreezeArray mutArr {-# INLINE insert #-} -- Extract the kind of a type. We use it to work around lack of syntax for -- inferred type variables (which are not subject to type applications). type KindOf (a :: k) = k +type ArgKindOf (f :: k -> l) = k+ {- | Delete a value from a 'TypeRepMap'. +TypeRepMap optimizes for fast reads rather than modifications, as a trade-off deletes are+@O(n)@, with an @O(log(n))@ optimization for when the element is already missing.+ prop> size (delete @a tm) <= size tm prop> member @a (delete @a tm) == False @@ -209,30 +229,60 @@ True -} delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeRepMap f-delete = fromTriples . deleteByFst (typeFp @a) . toTriples+delete m+ -- Lookups are fast, so check if we even have the element first.+ | not (member @a m) = m+ -- We know we have the element, If the map has exactly one element, we can return the empty map+ | size m == 1 = empty+ -- Otherwise, filter out the element in linear time.+ | otherwise = fromSortedTriples . deleteFirst ((== typeFp @a) . fst3) . toSortedTriples $ m {-# INLINE delete #-} +deleteFirst :: (a -> Bool) -> [a] -> [a]+deleteFirst _ [] = []+deleteFirst p (x : xs) = if p x then xs else x : deleteFirst p xs+ {- |-Update a value at a specific key with the result of the provided function. When-the key is not a member of the map, the original map is returned.+Update a value at a specific key with the result of the provided function.+When the key is not a member of the map, the original map is returned. >>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "a"] >>> lookup @String $ adjust (fmap (++ "ww")) trmap Just (Identity "aww") -} adjust :: forall a f . Typeable a => (f a -> f a) -> TypeRepMap f -> TypeRepMap f-adjust fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of- Nothing -> tr- Just i -> tr {trAnys = changeAnyArr i (trAnys tr)}+adjust fun = alter (fmap fun)+{-# INLINE adjust #-}++{- |+Updates a value at a specific key, whether or not it exists.+This can be used to insert, delete, or update a value of a given type in the map.++>>> func = (\case Nothing -> Just (Identity "new"); Just (Identity s) -> Just (Identity (reverse s)))+>>> lookup @String $ alter func empty+Just (Identity "new")+>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "helllo"]+>>> lookup @String $ alter func trmap+>>> Just (Identity "olleh")+-}+alter :: forall a f . Typeable a => (Maybe (f a) -> Maybe (f a)) -> TypeRepMap f -> TypeRepMap f+alter fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of+ Nothing ->+ case (fun Nothing) of+ Nothing -> tr+ Just v -> insert v tr+ Just i ->+ case fun (Just . fromAny $ indexArray (trAnys tr) i) of+ Nothing -> delete @a tr+ Just v -> tr{trAnys = replaceAnyAt i (toAny v) (trAnys tr)} where- changeAnyArr :: Int -> Array Any -> Array Any- changeAnyArr i trAs = runST $ do+ replaceAnyAt :: Int -> Any -> Array Any -> Array Any+ replaceAnyAt i v trAs = runST $ do let n = sizeofArray trAs mutArr <- thawArray trAs 0 n- a <- toAny . fun . fromAny <$> readArray mutArr i- writeArray mutArr i a+ writeArray mutArr i v unsafeFreezeArray mutArr-{-# INLINE adjust #-}+{-# INLINE alter #-} {- | Map over the elements of a 'TypeRepMap'. @@ -266,33 +316,89 @@ withTr t = withTypeable t f {-# INLINE hoistWithKey #-} --- | The union of two 'TypeRepMap's using a combining function.+-- | The union of two 'TypeRepMap's using a combining function for conflicting entries. @O(n + m)@ unionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f-unionWith f m1 m2 = fromTriples- $ toTripleList- $ Map.unionWith combine- (fromTripleList $ toTriples m1)- (fromTripleList $ toTriples m2)+unionWith f ma mb = do+ fromSortedTriples $ mergeMaps (toSortedTriples ma) (toSortedTriples mb) where f' :: forall x. TypeRep x -> f x -> f x -> f x f' tr = withTypeable tr f - combine :: (Any, Any) -> (Any, Any) -> (Any, Any)- combine (av, ak) (bv, _) = (toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak)-- fromTripleList :: Ord a => [(a, b, c)] -> Map.Map a (b, c)- fromTripleList = Map.fromList . map (\(a, b, c) -> (a, (b, c)))+ combine :: (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) -> (Fingerprint, Any, Any)+ combine (fp, av, ak) (_, bv, _) = (fp, toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak) - toTripleList :: Map.Map a (b, c) -> [(a, b, c)]- toTripleList = map (\(a, (b, c)) -> (a, b, c)) . Map.toList+ -- Merges two typrepmaps into a sorted, dedup'd list of triples.+ -- Using 'toSortedTriples' allows us to assume the triples are sorted by fingerprint,+ -- Given O(n) performance from 'toSortedTriples', and given that we can merge-sort in+ -- O(n + m) time, then can '.fromSortedTriples' back into cachedBinarySearch order in O(n + m)+ -- that gives a total of O(n + m).+ mergeMaps :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)]+ -- We've addressed all elements from both maps+ mergeMaps as [] = as+ mergeMaps [] bs = bs+ -- Merge+ mergeMaps (a@(af, _, _) : as) (b@(bf, _, _) : bs) =+ case compare af bf of+ -- Fingerprints are equal, union the elements using our function+ -- If the incoming maps were de-duped, there shouldn't be any other equivalent+ -- fingerprints+ EQ -> combine a b : mergeMaps as bs+ -- First fingerprint must not be in the second map or we would have seen it by now+ -- Add it to the result as-is+ LT -> a : mergeMaps as (b : bs)+ -- Second fingerprint must not be in the first map or we would have seen it by now+ -- Add it to the result as-is+ GT -> b : mergeMaps (a:as) bs {-# INLINE unionWith #-} --- | The (left-biased) union of two 'TypeRepMap's. It prefers the first map when+-- | The (left-biased) union of two 'TypeRepMap's in @O(n + m)@. It prefers the first map when -- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@. union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f union = unionWith const {-# INLINE union #-} +-- | The 'intersection' of two 'TypeRepMap's using a combining function+--+-- @O(n + m)@+intersectionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f+intersectionWith f ma mb =+ fromSortedTriples $ mergeMaps (toSortedTriples ma) (toSortedTriples mb)+ where+ f' :: forall x. TypeRep x -> f x -> f x -> f x+ f' tr = withTypeable tr f++ combine :: (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) -> (Fingerprint, Any, Any)+ combine (fp, av, ak) (_, bv, _) = (fp, toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak)++ -- Merges two typrepmaps into a sorted, dedup'd list of triples.+ mergeMaps :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)]+ -- If either list is empty, the intersection must be finished.+ mergeMaps _ [] = []+ mergeMaps [] _ = []+ -- Merge the two maps considering one element at a time.+ mergeMaps (a@(af, _, _) : as) (b@(bf, _, _) : bs) =+ case compare af bf of+ -- Fingerprints are equal, union the elements using our function+ -- If the incoming maps were de-duped, there shouldn't be any other equivalent+ -- fingerprints+ EQ -> combine a b : mergeMaps as bs+ -- First fingerprint must not be in the second map or we would have seen it by now+ -- Skip it an move on+ LT -> mergeMaps as (b : bs)+ -- Second fingerprint must not be in the first map or we would have seen it by now+ -- Skip it an move on+ GT -> mergeMaps (a:as) bs+{-# INLINE intersectionWith #-}++-- | The intersection of two 'TypeRepMap's.+-- It keeps all values from the first map whose keys are present in the second.+--+-- @O(n + m)@+intersection :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f+intersection = intersectionWith const+{-# INLINE intersection #-}++ {- | Check if a value of the given type is present in a 'TypeRepMap'. >>> member @Char $ one (Identity 'a')@@ -328,9 +434,22 @@ -- | Return the list of 'SomeTypeRep' from the keys. keys :: TypeRepMap f -> [SomeTypeRep]-keys TypeRepMap{..} = SomeTypeRep . anyToTypeRep <$> toList trKeys+keys = keysWith SomeTypeRep {-# INLINE keys #-} +-- | Return the list of keys by wrapping them with a user-provided function.+keysWith :: (forall (a :: ArgKindOf f). TypeRep a -> r) -> TypeRepMap f -> [r]+keysWith f TypeRepMap{..} = f . anyToTypeRep <$> toList trKeys+{-# INLINE keysWith #-}++-- | Return the list of key-value pairs by wrapping them with a user-provided function.+toListWith :: forall f r . (forall (a :: ArgKindOf f) . Typeable a => f a -> r) -> TypeRepMap f -> [r]+toListWith f = map toF . toTriples+ where+ withTypeRep :: TypeRep a -> f a -> r+ withTypeRep tr an = withTypeable tr $ f an+ toF (_, an, k) = withTypeRep (unsafeCoerce k) (fromAny an)+ -- | Binary searched based on this article -- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html -- with modification for our two-vector search case.@@ -374,8 +493,20 @@ toTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)] toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ trAnys tm) (GHC.toList $ trKeys tm) -deleteByFst :: Eq a => a -> [(a, b, c)] -> [(a, b, c)]-deleteByFst x = filter ((/= x) . fst3)+-- | Efficiently get sorted triples from a map in O(n) time+--+-- We assume the incoming TypeRepMap is already sorted into 'cachedBinarySearch' order using fromSortedList.+-- Then we can construct the index mapping from the "cached" ordering into monotonically+-- increasing order using 'generateOrderMapping' with the length of the TRM. This takes @O(n).+-- We then pull those indexes from the source TRM to get the sorted triples in a total of @O(n).+toSortedTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)]+toSortedTriples tm = trip <$> ordering+ where+ trip i = ( Fingerprint (indexPrimArray (fingerprintAs tm) i) (indexPrimArray (fingerprintBs tm) i)+ , indexArray (trAnys tm) i+ , indexArray (trKeys tm) i)+ ordering :: [ Int ]+ ordering = generateOrderMapping (size tm) nubByFst :: (Eq a) => [(a, b, c)] -> [(a, b, c)] nubByFst = nubBy ((==) `on` fst3)@@ -395,9 +526,6 @@ instance Show (WrapTypeable f) where show (WrapTypeable (_ :: f a)) = show $ calcFp @a -wrapTypeable :: TypeRep a -> f a -> WrapTypeable f-wrapTypeable tr = withTypeable tr WrapTypeable- {- | prop> fromList . toList == 'id'@@ -425,19 +553,19 @@ k (WrapTypeable (_ :: f a)) = unsafeCoerce $ typeRep @a toList :: TypeRepMap f -> [WrapTypeable f]- toList = map toWrapTypeable . toTriples- where- toWrapTypeable :: (Fingerprint, Any, Any) -> WrapTypeable f- toWrapTypeable (_, an, k) = wrapTypeable (unsafeCoerce k) (fromAny an)+ toList = toListWith WrapTypeable calcFp :: forall a . Typeable a => Fingerprint calcFp = typeRepFingerprint $ typeRep @a fromTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f-fromTriples kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans) (GHC.fromList ks)+fromTriples = fromSortedTriples . sortWith fst3 . nubByFst++fromSortedTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f+fromSortedTriples kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans) (GHC.fromList ks) where (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps- (fps, ans, ks) = unzip3 $ fromSortedList $ sortWith fst3 $ nubByFst kvs+ (fps, ans, ks) = unzip3 $ fromSortedList kvs ---------------------------------------------------------------------------- -- Tree-like conversion@@ -464,11 +592,35 @@ writeArray result i (indexArray origin newFirst) loop (2 * i + 2) (newFirst + 1) +-- Returns a list of indexes which represents the "sorted" order of an array generated by+-- fromSortedList of the provided length.+-- I.e. fmap (fromSortedList [1, 2, 3, 4, 5, 6] !!) (generateOrderMapping 6) == [1, 2, 3, 4, 5, 6]+--+-- >>> generateOrderMapping 6+-- [3,1,4,0,5,2]+--+-- >>> generateOrderMapping 8+-- [7,3,1,4,0,5,2,6]+generateOrderMapping :: Int -> [Int]+generateOrderMapping len = runST $ do+ orderMappingArr <- newPrimArray len+ _ <- loop orderMappingArr 0 0+ primArrayToList <$> unsafeFreezePrimArray orderMappingArr+ where+ loop :: MutablePrimArray s Int -> Int -> Int -> ST s Int+ loop result i first =+ if i >= len+ then pure first+ else do+ newFirst <- loop result (2 * i + 1) first+ writePrimArray result newFirst i+ loop result (2 * i + 2) (newFirst + 1)+ ---------------------------------------------------------------------------- -- Helper functions. ---------------------------------------------------------------------------- --- | Check that invariant of the structure is hold.+-- | Check that invariant of the structure holds. -- The structure maintains the following invariant. -- For each element @A@ at index @i@: --@@ -481,8 +633,8 @@ invariantCheck :: TypeRepMap f -> Bool invariantCheck TypeRepMap{..} = getAll (check 0) where- lastMay [] = Nothing- lastMay [x] = Just x+ lastMay [] = Nothing+ lastMay [x] = Just x lastMay (_:xs) = lastMay xs sz = sizeofPrimArray fingerprintAs check i | i >= sz = All True
test/Test/TypeRep/TypeRepMap.hs view
@@ -5,14 +5,18 @@ import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..))-import GHC.Exts (fromList)-import Test.Hspec (Spec, describe, it, shouldBe)+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Typeable (cast)+import GHC.Exts (fromList, toList)+import Type.Reflection (SomeTypeRep(..), typeRep)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy, expectationFailure) -import Data.TMap (TMap, empty, insert, lookup, one, size, union)+import Data.TMap (TMap, empty, insert, lookup, one, size, union, keys) import Data.TypeRepMap.Internal (WrapTypeable (..)) --- Simple test for 'lookup', 'insert' and 'size' functions.+-- Simple test for 'lookup', 'insert', 'size', 'keys', 'toList' functions. typeRepMapSpec :: Spec typeRepMapSpec = describe "TypeRepMap" $ do describe "Lookup Test" $ do@@ -39,6 +43,60 @@ lookup m `shouldBe` Just True lookup @Int m `shouldBe` Nothing + describe "Keys Test" $ do+ it "returns nothing on empty map" $+ keys empty `shouldBe` []+ it "returns the correct TypeRep" $+ keys (one 'a') `shouldBe` [SomeTypeRep $ typeRep @Char]+ it "returns the correct TypeReps for 10 different types" $+ keys mapOf10 `shouldMatchList`+ [ SomeTypeRep $ typeRep @Bool+ , SomeTypeRep $ typeRep @[Bool]+ , SomeTypeRep $ typeRep @(Maybe Bool)+ , SomeTypeRep $ typeRep @(Maybe ())+ , SomeTypeRep $ typeRep @[()]+ , SomeTypeRep $ typeRep @()+ , SomeTypeRep $ typeRep @String+ , SomeTypeRep $ typeRep @(Maybe Char)+ , SomeTypeRep $ typeRep @Char+ , SomeTypeRep $ typeRep @Int+ ]++ describe "ToList Test" $ do+ it "returns nothing on empty map" $+ toList empty `shouldSatisfy` null+ it "returns correct result when 1 element is inserted" $+ case toList (one 'a') of+ [WrapTypeable (Identity x)] -> cast x `shouldBe` Just 'a'+ _ -> expectationFailure "did not return exactly 1 result"+ it "returns correct result when 10 elements are inserted" $ do+ let+ getTypeRep (WrapTypeable (Identity (_ :: a))) = SomeTypeRep $ typeRep @a+ got = sortBy (comparing getTypeRep) (toList mapOf10)+ expected = sortBy (comparing fst)+ [ (SomeTypeRep $ typeRep @Bool,+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just True)+ , (SomeTypeRep $ typeRep @[Bool],+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just [True, False])+ , (SomeTypeRep $ typeRep @(Maybe Bool),+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just True))+ , (SomeTypeRep $ typeRep @(Maybe ()),+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just ()))+ , (SomeTypeRep $ typeRep @[()],+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just [()])+ , (SomeTypeRep $ typeRep @(),+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just ())+ , (SomeTypeRep $ typeRep @String,+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just ("aaa" :: String))+ , (SomeTypeRep $ typeRep @(Maybe Char),+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just 'a'))+ , (SomeTypeRep $ typeRep @Char,+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just 'a')+ , (SomeTypeRep $ typeRep @Int,+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (11 :: Int))+ ]+ length got `shouldBe` 10+ sequence_ $ zipWith snd expected got mapOf10 :: TMap mapOf10 = insert True
test/Test/TypeRep/TypeRepMapProperty.hs view
@@ -20,7 +20,8 @@ import Test.Hspec.Hedgehog (hedgehog) import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,- lookup, member)+ lookup, member, union, generateOrderMapping, fromSortedList,+ adjust, alter, intersection) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range@@ -34,6 +35,13 @@ deleteMemberSpec insertInvariantSpec deleteInvariantSpec+ alterInsertSpec+ alterDeleteSpec+ alterAdjustSpec+ alterModifySpec+ intersectionSpec+ describe "Internal helpers" $ do+ generateOrderMappingInvariantSpec describe "Instance Laws" $ do semigroupAssocSpec monoidIdentitySpec@@ -80,45 +88,66 @@ WrapTypeable (_ :: IntProxy n) <- forAll genTF assert $ invariantCheck (delete @n m) +alterInsertSpec :: Property+alterInsertSpec = it "insert proxy m === alter (const (Just proxy)) m" $ hedgehog $ do+ m <- forAll genMap+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF+ insert proxy m === alter (const (Just proxy)) m++alterDeleteSpec :: Property+alterDeleteSpec = it "delete proxy m === alter (const Nothing) m" $ hedgehog $ do+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF+ m <- insert proxy <$> forAll genMap+ delete @n @IntProxy m === alter @n @IntProxy (const Nothing) m++alterAdjustSpec :: Property+alterAdjustSpec = it "adjust f m == alter (fmap f) m" $ hedgehog $ do+ m <- forAll genMap+ WrapTypeable (_ :: IntProxy n) <- forAll genTF+ let f (IntProxy p n) = IntProxy p (n * 10)+ adjust @n @IntProxy f m === alter @n @IntProxy (fmap f) m++alterModifySpec :: Property+alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do+ m <- forAll genMap+ WrapTypeable (_ :: IntProxy n) <- forAll genTF+ randInt <- forAll (Gen.int Range.constantBounded)+ -- Function with some interesting behaviour, which inserts, seletes and modifies+ let f Nothing = Just (IntProxy Proxy randInt)+ f (Just (IntProxy p n))+ | even n = Nothing+ | otherwise = Just $ IntProxy p (n * 10)+ lookup @n @IntProxy (alter @n f m) === f (lookup @n @IntProxy m)++intersectionSpec :: Property+intersectionSpec = it "m `intersection` (m `union` n) == m" $ hedgehog $ do+ m <- forAll genMap+ n <- forAll genMap+ m `intersection` (m `union` n) === m+ ------------------------------------------------------------------------------- Semigroup and Monoid laws+-- Internal helpers ------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ < 806-{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's.-It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because-it doesn't compare values so it's not true equality. But this should be enough-for tests.--}-newtype FpMap f = FpMap (TypeRepMap f)- deriving newtype (Show, Semigroup, Monoid)+generateOrderMappingInvariantSpec :: Property+generateOrderMappingInvariantSpec =+ it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do+ n <- forAll $ Gen.int (Range.linear 0 100)+ fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n] -instance Eq (FpMap f) where- FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =- as1 == as2 && bs1 == bs2-#endif+----------------------------------------------------------------------------+-- Semigroup and Monoid laws+---------------------------------------------------------------------------- semigroupAssocSpec :: Property semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do-#if __GLASGOW_HASKELL__ >= 806 x <- forAll genMap y <- forAll genMap z <- forAll genMap-#else- x <- FpMap <$> forAll genMap- y <- FpMap <$> forAll genMap- z <- FpMap <$> forAll genMap-#endif (x <> (y <> z)) === ((x <> y) <> z) monoidIdentitySpec :: Property monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do-#if __GLASGOW_HASKELL__ >= 806 x <- forAll genMap-#else- x <- FpMap <$> forAll genMap-#endif- x <> mempty === x mempty <> x === x @@ -139,3 +168,17 @@ case someNatVal randNat of Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt Nothing -> error "Invalid test generator"++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------+#if __GLASGOW_HASKELL__ < 806+{- | We add an orphan Eq instance for old GHC versions just to make testing easier.+It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because+it doesn't compare values so it's not true equality. But this should be enough+for tests.+-}+instance Eq (TypeRepMap f) where+ TypeRepMap as1 bs1 _ _ == TypeRepMap as2 bs2 _ _ =+ as1 == as2 && bs1 == bs2+#endif
typerep-map.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: typerep-map-version: 0.3.3.0+version: 0.4.0.0 synopsis: Efficient implementation of a dependent map with types as keys description: A dependent map from type representations to values of these types.@@ -23,7 +23,7 @@ license-file: LICENSE author: Veronika Romashkina, Vladislav Zavialov, Dmitrii Kovanikov maintainer: Kowainik <xrom.xkov@gmail.com>-copyright: 2017-2020 Kowainik+copyright: 2017-2021 Kowainik category: Data, Data Structures, Types build-type: Simple extra-doc-files: README.md@@ -31,15 +31,16 @@ tested-with: GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.3- , GHC == 8.10.1+ , GHC == 8.8.4+ , GHC == 8.10.5+ , GHC == 9.0.1 source-repository head type: git location: https://github.com/kowainik/typerep-map.git common common-options- build-depends: base >= 4.10 && < 4.15+ build-depends: base >= 4.10 && < 4.16 default-language: Haskell2010 default-extensions: BangPatterns@@ -53,10 +54,8 @@ -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates- if impl(ghc >= 8.0)- ghc-options: -Wredundant-constraints- if impl(ghc >= 8.2)- ghc-options: -fhide-source-paths+ -Wredundant-constraints+ -fhide-source-paths if impl(ghc >= 8.4) ghc-options: -Wmissing-export-lists -Wpartial-fields@@ -73,8 +72,7 @@ Data.TypeRepMap Data.TypeRepMap.Internal - build-depends: containers >= 0.5.10.2 && < 0.7- , ghc-prim >= 0.5.1.1 && < 0.7+ build-depends: ghc-prim >= 0.5.1.1 && < 0.8 , primitive ^>= 0.7.0 , deepseq ^>= 1.4 @@ -103,7 +101,7 @@ build-depends: ghc-typelits-knownnat >= 0.4.2 && < 0.8 , hedgehog ^>= 1.0- , hspec ^>= 2.7.1+ , hspec >= 2.7.1 && < 2.9 , hspec-hedgehog ^>= 0.0.1 , typerep-map , typerep-extra-impls