b3c8d19 · typerep-map · git.iko.soy

src/Data/TMap.hs+20

compare with main

unifiedsplit

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

37 , delete

38 , unionWith

39 , union

40+ , intersectionWith

41+ , intersection

40 , map

42 , map

41 , adjust

43 , adjust

42 , alter

44 , alter

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

132union = F.union

134union = F.union

133{-# INLINE union #-}

135{-# INLINE union #-}

134

136

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

138+--

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

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

141+intersectionWith f = F.intersectionWith fId

142+ where

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

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

145+{-# INLINE intersectionWith #-}

146+

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

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

149+--

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

151+intersection :: TMap -> TMap -> TMap

152+intersection = F.intersection

153+{-# INLINE intersection #-}

154+

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

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

136

156

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

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

src/Data/TypeRepMap.hs+2

@@ -63,6 +63,8 @@ module Data.TypeRepMap

63 , hoistWithKey

64 , unionWith

65 , union

66+ , intersectionWith

67+ , intersection

66

68

67 -- * Query

69 -- * Query

68 , lookup

70 , lookup

src/Data/TypeRepMap/Internal.hs+42

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

350union = unionWith const

351{-# INLINE union #-}

352

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

354+--

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

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

357+intersectionWith f ma mb =

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

359+ where

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

361+ f' tr = withTypeable tr f

362+

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

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

365+

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

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

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

369+ mergeMaps _ [] = []

370+ mergeMaps [] _ = []

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

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

373+ case compare af bf of

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

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

376+ -- fingerprints

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

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

379+ -- Skip it an move on

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

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

382+ -- Skip it an move on

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

384+{-# INLINE intersectionWith #-}

385+

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

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

388+--

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

390+intersection :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

391+intersection = intersectionWith const

392+{-# INLINE intersection #-}

393+

394+

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

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

354

396

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

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

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

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

20import Test.Hspec.Hedgehog (hedgehog)

21

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

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

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

24− adjust)

24+ adjust, alter, intersection)

25

26import qualified Hedgehog.Gen as Gen

27import qualified Hedgehog.Range as Range

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

39 alterDeleteSpec

40 alterAdjustSpec

41 alterModifySpec

42+ intersectionSpec

42 describe "Internal helpers" $ do

43 describe "Internal helpers" $ do

43 generateOrderMappingInvariantSpec

44 generateOrderMappingInvariantSpec

44 describe "Instance Laws" $ do

45 describe "Instance Laws" $ do

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

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

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

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

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

120

121

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+

121----------------------------------------------------------------------------

128----------------------------------------------------------------------------

122-- Internal helpers

129-- Internal helpers

123----------------------------------------------------------------------------

130----------------------------------------------------------------------------