1b739d8...main · typerep-map

git.iko.soy/typerep-map

8 files changed+173−22

since splitsnapshots

unifiedsplit

.github/workflows/ci.yml+3−4 CHANGELOG.md+1−1 README.md+1−1 src/Data/TMap.hs+33−1 src/Data/TypeRepMap.hs+5−1 src/Data/TypeRepMap/Internal.hs+59−8 test/Test/TypeRep/TypeRepMap.hs+62−4 test/Test/TypeRep/TypeRepMapProperty.hs+9−2

.github/workflows/ci.yml+3−4

@@ -1,11 +1,10 @@

11name: CI

3+# Trigger the workflow on push or pull request, but only for the main branch

34on:

4− # Trigger the workflow on push or pull request,

5− # but only for the master branch

65 push:

76 branches:

8− - master

7+ - main

98 pull_request:

109

1110jobs:

@@ -24,7 +23,7 @@ jobs:

2423

2524 steps:

2625 - uses: actions/checkout@v2

27− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'

26+ if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main'

2827

2928 - uses: actions/setup-haskell@v1

3029 name: Setup Haskell

CHANGELOG.md+1−1

@@ -53,4 +53,4 @@ The changelog is available [on GitHub][2].

5353* Initially created.

5454

5555[1]: https://pvp.haskell.org

56−[2]: https://github.com/kowainik/typerep-map/blob/master/CHANGELOG.md

56+[2]: https://github.com/kowainik/typerep-map/releases

README.md+1−1

@@ -4,7 +4,7 @@

55[![GitHub CI](https://github.com/kowainik/typerep-map/workflows/CI/badge.svg)](https://github.com/kowainik/typerep-map/actions)

66[![Build status](https://img.shields.io/travis/kowainik/typerep-map.svg?logo=travis)](https://travis-ci.org/kowainik/typerep-map)

7−[![Windows build status](https://ci.appveyor.com/api/projects/status/github/kowainik/typerep-map?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/typerep-map)

7+[![Windows build status](https://ci.appveyor.com/api/projects/status/github/kowainik/typerep-map?branch=main&svg=true)](https://ci.appveyor.com/project/kowainik/typerep-map)

88[![Hackage](https://img.shields.io/hackage/v/typerep-map.svg?logo=haskell)](https://hackage.haskell.org/package/typerep-map)

99[![Stackage LTS](http://stackage.org/package/typerep-map/badge/lts)](http://stackage.org/lts/package/typerep-map)

1010[![Stackage Nightly](http://stackage.org/package/typerep-map/badge/nightly)](http://stackage.org/nightly/package/typerep-map)

src/Data/TMap.hs+33−1

@@ -37,6 +37,8 @@ module Data.TMap

3737 , delete

3838 , unionWith

3939 , union

40+ , intersectionWith

41+ , intersection

4042 , map

4143 , adjust

4244 , alter

@@ -46,6 +48,8 @@ module Data.TMap

4648 , member

4749 , size

4850 , keys

51+ , keysWith

52+ , toListWith

4953 ) where

5054

5155import Prelude hiding (lookup, map)

@@ -53,7 +57,7 @@ import Prelude hiding (lookup, map)

5357import Data.Functor.Identity (Identity (..))

5458import Data.Typeable (Typeable)

5559import GHC.Exts (coerce)

56−import Type.Reflection (SomeTypeRep)

60+import Type.Reflection (SomeTypeRep, TypeRep)

5761

5862import qualified Data.TypeRepMap as F

5963

@@ -132,6 +136,24 @@ union :: TMap -> TMap -> TMap

132136union = F.union

133137{-# INLINE union #-}

134138

139+-- | The intersection of two 'TMap's using a combining function.

140+--

141+-- @O(n + m)@

142+intersectionWith :: (forall x. Typeable x => x -> x -> x) -> TMap -> TMap -> TMap

143+intersectionWith f = F.intersectionWith fId

144+ where

145+ fId :: forall y . Typeable y => Identity y -> Identity y -> Identity y

146+ fId y1 y2 = f (coerce y1) (coerce y2)

147+{-# INLINE intersectionWith #-}

148+

149+-- | The intersection of two 'TMap's.

150+-- It keeps all values from the first map whose keys are present in the second.

151+--

152+-- @O(n + m)@

153+intersection :: TMap -> TMap -> TMap

154+intersection = F.intersection

155+{-# INLINE intersection #-}

156+

135157{- | Lookup a value of the given type in a 'TMap'.

136158

137159>>> x = lookup $ insert (11 :: Int) empty

@@ -165,6 +187,16 @@ keys :: TMap -> [SomeTypeRep]

165187keys = F.keys

166188{-# INLINE keys #-}

167189

190+-- | Return the list of keys by wrapping them with a user-provided function.

191+keysWith :: (forall a. TypeRep a -> r) -> TMap -> [r]

192+keysWith = F.keysWith

193+{-# INLINE keysWith #-}

194+

195+-- | Return the list of key-value pairs by wrapping them with a user-provided function.

196+toListWith :: (forall a. Typeable a => a -> r) -> TMap -> [r]

197+toListWith = F.toListWith

198+{-# INLINE toListWith #-}

199+

168200-- | Map a function over the values.

169201map :: (forall a. Typeable a => a -> a) -> TMap -> TMap

170202map f = F.hoistWithKey (liftToIdentity f)

src/Data/TypeRepMap.hs+5−1

55SPDX-License-Identifier: MPL-2.0

66Maintainer: Kowainik <xrom.xkov@gmail.com>

8− A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This

8+A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This

99sort of parametrization may be familiar to users of @vinyl@ records.

1010

1111@'TypeRepMap' f@ is a more efficient replacement for @DMap

@@ -63,12 +63,16 @@ module Data.TypeRepMap

6363 , hoistWithKey

6464 , unionWith

6565 , union

66+ , intersectionWith

67+ , intersection

6668

6769 -- * Query

6870 , lookup

6971 , member

7072 , size

7173 , keys

74+ , keysWith

75+ , toListWith

7276

7377 -- * 'IsList'

7478 , WrapTypeable (..)

src/Data/TypeRepMap/Internal.hs+59−8

@@ -205,6 +205,8 @@ insert x m

205205-- inferred type variables (which are not subject to type applications).

206206type KindOf (a :: k) = k

207207

208+type ArgKindOf (f :: k -> l) = k

209+

208210{- | Delete a value from a 'TypeRepMap'.

209211

210212TypeRepMap optimizes for fast reads rather than modifications, as a trade-off deletes are

@@ -350,6 +352,48 @@ union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

350352union = unionWith const

351353{-# INLINE union #-}

352354

355+-- | The 'intersection' of two 'TypeRepMap's using a combining function

356+--

357+-- @O(n + m)@

358+intersectionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f

359+intersectionWith f ma mb =

360+ fromSortedTriples $ mergeMaps (toSortedTriples ma) (toSortedTriples mb)

361+ where

362+ f' :: forall x. TypeRep x -> f x -> f x -> f x

363+ f' tr = withTypeable tr f

364+

365+ combine :: (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) -> (Fingerprint, Any, Any)

366+ combine (fp, av, ak) (_, bv, _) = (fp, toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak)

367+

368+ -- Merges two typrepmaps into a sorted, dedup'd list of triples.

369+ mergeMaps :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)]

370+ -- If either list is empty, the intersection must be finished.

371+ mergeMaps _ [] = []

372+ mergeMaps [] _ = []

373+ -- Merge the two maps considering one element at a time.

374+ mergeMaps (a@(af, _, _) : as) (b@(bf, _, _) : bs) =

375+ case compare af bf of

376+ -- Fingerprints are equal, union the elements using our function

377+ -- If the incoming maps were de-duped, there shouldn't be any other equivalent

378+ -- fingerprints

379+ EQ -> combine a b : mergeMaps as bs

380+ -- First fingerprint must not be in the second map or we would have seen it by now

381+ -- Skip it an move on

382+ LT -> mergeMaps as (b : bs)

383+ -- Second fingerprint must not be in the first map or we would have seen it by now

384+ -- Skip it an move on

385+ GT -> mergeMaps (a:as) bs

386+{-# INLINE intersectionWith #-}

387+

388+-- | The intersection of two 'TypeRepMap's.

389+-- It keeps all values from the first map whose keys are present in the second.

390+--

391+-- @O(n + m)@

392+intersection :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

393+intersection = intersectionWith const

394+{-# INLINE intersection #-}

395+

396+

353397{- | Check if a value of the given type is present in a 'TypeRepMap'.

354398

355399>>> member @Char $ one (Identity 'a')

@@ -385,9 +429,22 @@ size = sizeofPrimArray . fingerprintAs

385429

386430-- | Return the list of 'SomeTypeRep' from the keys.

387431keys :: TypeRepMap f -> [SomeTypeRep]

388−keys TypeRepMap{..} = SomeTypeRep . anyToTypeRep <$> toList trKeys

432+keys = keysWith SomeTypeRep

389433{-# INLINE keys #-}

390434

435+-- | Return the list of keys by wrapping them with a user-provided function.

436+keysWith :: (forall (a :: ArgKindOf f). TypeRep a -> r) -> TypeRepMap f -> [r]

437+keysWith f TypeRepMap{..} = f . anyToTypeRep <$> toList trKeys

438+{-# INLINE keysWith #-}

439+

440+-- | Return the list of key-value pairs by wrapping them with a user-provided function.

441+toListWith :: forall f r. (forall (a :: ArgKindOf f). Typeable a => f a -> r) -> TypeRepMap f -> [r]

442+toListWith f = map toF . toTriples

443+ where

444+ withTypeRep :: TypeRep a -> f a -> r

445+ withTypeRep tr an = withTypeable tr $ f an

446+ toF (_, an, k) = withTypeRep (unsafeCoerce k) (fromAny an)

447+

391448-- | Binary searched based on this article

392449-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html

393450-- with modification for our two-vector search case.

@@ -464,9 +521,6 @@ data WrapTypeable f where

464521instance Show (WrapTypeable f) where

465522 show (WrapTypeable (_ :: f a)) = show $ calcFp @a

466523

467−wrapTypeable :: TypeRep a -> f a -> WrapTypeable f

468−wrapTypeable tr = withTypeable tr WrapTypeable

469−

470524{- |

471525

472526prop> fromList . toList == 'id'

@@ -494,10 +548,7 @@ instance IsList (TypeRepMap f) where

494548 k (WrapTypeable (_ :: f a)) = unsafeCoerce $ typeRep @a

495549

496550 toList :: TypeRepMap f -> [WrapTypeable f]

497− toList = map toWrapTypeable . toTriples

498− where

499− toWrapTypeable :: (Fingerprint, Any, Any) -> WrapTypeable f

500− toWrapTypeable (_, an, k) = wrapTypeable (unsafeCoerce k) (fromAny an)

551+ toList = toListWith WrapTypeable

501552

502553calcFp :: forall a . Typeable a => Fingerprint

503554calcFp = typeRepFingerprint $ typeRep @a

test/Test/TypeRep/TypeRepMap.hs+62−4

@@ -5,14 +5,18 @@ module Test.TypeRep.TypeRepMap

55import Prelude hiding (lookup)

77import Data.Functor.Identity (Identity (..))

8−import GHC.Exts (fromList)

9−import Test.Hspec (Spec, describe, it, shouldBe)

8+import Data.List (sortBy)

9+import Data.Ord (comparing)

10+import Data.Typeable (cast)

11+import GHC.Exts (fromList, toList)

12+import Type.Reflection (SomeTypeRep(..), typeRep)

13+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy, expectationFailure)

1014

11−import Data.TMap (TMap, empty, insert, lookup, one, size, union)

15+import Data.TMap (TMap, empty, insert, lookup, one, size, union, keys)

1216import Data.TypeRepMap.Internal (WrapTypeable (..))

1317

1418

15−-- Simple test for 'lookup', 'insert' and 'size' functions.

19+-- Simple test for 'lookup', 'insert', 'size', 'keys', 'toList' functions.

1620typeRepMapSpec :: Spec

1721typeRepMapSpec = describe "TypeRepMap" $ do

1822 describe "Lookup Test" $ do

@@ -39,6 +43,60 @@ typeRepMapSpec = describe "TypeRepMap" $ do

3943 lookup m `shouldBe` Just True

4044 lookup @Int m `shouldBe` Nothing

4145

46+ describe "Keys Test" $ do

47+ it "returns nothing on empty map" $

48+ keys empty `shouldBe` []

49+ it "returns the correct TypeRep" $

50+ keys (one 'a') `shouldBe` [SomeTypeRep $ typeRep @Char]

51+ it "returns the correct TypeReps for 10 different types" $

52+ keys mapOf10 `shouldMatchList`

53+ [ SomeTypeRep $ typeRep @Bool

54+ , SomeTypeRep $ typeRep @[Bool]

55+ , SomeTypeRep $ typeRep @(Maybe Bool)

56+ , SomeTypeRep $ typeRep @(Maybe ())

57+ , SomeTypeRep $ typeRep @[()]

58+ , SomeTypeRep $ typeRep @()

59+ , SomeTypeRep $ typeRep @String

60+ , SomeTypeRep $ typeRep @(Maybe Char)

61+ , SomeTypeRep $ typeRep @Char

62+ , SomeTypeRep $ typeRep @Int

63+ ]

64+

65+ describe "ToList Test" $ do

66+ it "returns nothing on empty map" $

67+ toList empty `shouldSatisfy` null

68+ it "returns correct result when 1 element is inserted" $

69+ case toList (one 'a') of

70+ [WrapTypeable (Identity x)] -> cast x `shouldBe` Just 'a'

71+ _ -> expectationFailure "did not return exactly 1 result"

72+ it "returns correct result when 10 elements are inserted" $ do

73+ let

74+ getTypeRep (WrapTypeable (Identity (_ :: a))) = SomeTypeRep $ typeRep @a

75+ got = sortBy (comparing getTypeRep) (toList mapOf10)

76+ expected = sortBy (comparing fst)

77+ [ (SomeTypeRep $ typeRep @Bool,

78+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just True)

79+ , (SomeTypeRep $ typeRep @[Bool],

80+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just [True, False])

81+ , (SomeTypeRep $ typeRep @(Maybe Bool),

82+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just True))

83+ , (SomeTypeRep $ typeRep @(Maybe ()),

84+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just ()))

85+ , (SomeTypeRep $ typeRep @[()],

86+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just [()])

87+ , (SomeTypeRep $ typeRep @(),

88+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just ())

89+ , (SomeTypeRep $ typeRep @String,

90+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just ("aaa" :: String))

91+ , (SomeTypeRep $ typeRep @(Maybe Char),

92+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just 'a'))

93+ , (SomeTypeRep $ typeRep @Char,

94+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just 'a')

95+ , (SomeTypeRep $ typeRep @Int,

96+ \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (11 :: Int))

97+ ]

98+ length got `shouldBe` 10

99+ sequence_ $ zipWith snd expected got

42100

43101mapOf10 :: TMap

44102mapOf10 = insert True

test/Test/TypeRep/TypeRepMapProperty.hs+9−2

@@ -20,8 +20,8 @@ import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)

2020import Test.Hspec.Hedgehog (hedgehog)

2121

2222import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,

23− lookup, member, generateOrderMapping, fromSortedList, alter,

24− adjust)

23+ lookup, member, union, generateOrderMapping, fromSortedList,

24+ adjust, alter, intersection)

2525

2626import qualified Hedgehog.Gen as Gen

2727import qualified Hedgehog.Range as Range

@@ -39,6 +39,7 @@ typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do

3939 alterDeleteSpec

4040 alterAdjustSpec

4141 alterModifySpec

42+ intersectionSpec

4243 describe "Internal helpers" $ do

4344 generateOrderMappingInvariantSpec

4445 describe "Instance Laws" $ do

@@ -118,6 +119,12 @@ alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do

118119 | otherwise = Just $ IntProxy p (n * 10)

119120 lookup @n @IntProxy (alter @n f m) === f (lookup @n @IntProxy m)

120121

122+intersectionSpec :: Property

123+intersectionSpec = it "m `intersection` (m `union` n) == m" $ hedgehog $ do

124+ m <- forAll genMap

125+ n <- forAll genMap

126+ m `intersection` (m `union` n) === m

127+

121128----------------------------------------------------------------------------

122129-- Internal helpers

123130----------------------------------------------------------------------------