e55aed6...main · typerep-map

git.iko.soy/typerep-map

on main help sign in

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

since splitsnapshots

unifiedsplit

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

1name: CI

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

3on:

4on:

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

5− # but only for the master branch

6 push:

5 push:

7 branches:

6 branches:

8− - master

7+ - main

9 pull_request:

8 pull_request:

11jobs:

10jobs:

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

25 steps:

24 steps:

26 - uses: actions/checkout@v2

25 - 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'

29 - uses: actions/setup-haskell@v1

28 - uses: actions/setup-haskell@v1

30 name: Setup Haskell

29 name: Setup Haskell

CHANGELOG.md+1−1

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

53* Initially created.

55[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 @@

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

6[![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)

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

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

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

src/Data/TMap.hs+43−1

@@ -37,14 +37,19 @@ module Data.TMap

37 , delete

38 , unionWith

39 , union

40+ , intersectionWith

41+ , intersection

40 , map

42 , map

41 , adjust

43 , adjust

44+ , alter

43 -- * Query

46 -- * Query

44 , lookup

47 , lookup

45 , member

48 , member

46 , size

49 , size

47 , keys

50 , keys

51+ , keysWith

52+ , toListWith

48 ) where

53 ) where

50import Prelude hiding (lookup, map)

55import Prelude hiding (lookup, map)

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

52import Data.Functor.Identity (Identity (..))

57import Data.Functor.Identity (Identity (..))

53import Data.Typeable (Typeable)

58import Data.Typeable (Typeable)

54import GHC.Exts (coerce)

59import GHC.Exts (coerce)

55−import Type.Reflection (SomeTypeRep)

60+import Type.Reflection (SomeTypeRep, TypeRep)

57import qualified Data.TypeRepMap as F

62import qualified Data.TypeRepMap as F

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

131union = F.union

136union = F.union

132{-# INLINE union #-}

137{-# INLINE union #-}

133

138

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+

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

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

135

158

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

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

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

164keys = F.keys

187keys = F.keys

165{-# INLINE keys #-}

188{-# INLINE keys #-}

166

189

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+

167-- | Map a function over the values.

200-- | Map a function over the values.

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

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

169map f = F.hoistWithKey (liftToIdentity f)

202map f = F.hoistWithKey (liftToIdentity f)

@@ -174,5 +207,14 @@ adjust :: Typeable a => (a -> a) -> TMap -> TMap

174adjust f = F.adjust (liftToIdentity f)

207adjust f = F.adjust (liftToIdentity f)

175{-# INLINE adjust #-}

208{-# INLINE adjust #-}

176

209

210+-- | Updates a value at a specific key, whether or not it exists.

211+-- This can be used to insert, delete, or update a value of a given type in the map.

212+alter :: Typeable a => (Maybe a -> Maybe a) -> TMap -> TMap

213+alter f = F.alter (liftF f)

214+ where

215+ liftF :: forall a. (Maybe a -> Maybe a) -> Maybe (Identity a) -> Maybe (Identity a)

216+ liftF = coerce

217+{-# INLINE alter #-}

218+

177liftToIdentity :: forall a. (a -> a) -> Identity a -> Identity a

219liftToIdentity :: forall a. (a -> a) -> Identity a -> Identity a

178liftToIdentity = coerce

220liftToIdentity = coerce

src/Data/TypeRepMap.hs+6−1

5SPDX-License-Identifier: MPL-2.0

6Maintainer: 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

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

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

@@ -57,17 +57,22 @@ module Data.TypeRepMap

57 , insert

58 , delete

59 , adjust

60+ , alter

60 , hoist

61 , hoist

61 , hoistA

62 , hoistA

62 , hoistWithKey

63 , hoistWithKey

63 , unionWith

64 , unionWith

64 , union

65 , union

66+ , intersectionWith

67+ , intersection

66 -- * Query

69 -- * Query

67 , lookup

70 , lookup

68 , member

71 , member

69 , size

72 , size

70 , keys

73 , keys

74+ , keysWith

75+ , toListWith

72 -- * 'IsList'

77 -- * 'IsList'

73 , WrapTypeable (..)

78 , WrapTypeable (..)

src/Data/TypeRepMap/Internal.hs+90−19

@@ -45,7 +45,7 @@ import Data.Kind (Type)

45import Data.Type.Equality ((:~:) (..), TestEquality (..))

46import Data.List (intercalate, nubBy)

47import Data.Maybe (fromMaybe)

48−import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,

48+import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', sizeofArray,

49 thawArray, unsafeFreezeArray, writeArray)

50import Data.Primitive.PrimArray (writePrimArray, newPrimArray, unsafeFreezePrimArray, primArrayToList, MutablePrimArray, primArrayFromListN, PrimArray, indexPrimArray, sizeofPrimArray)

51import Data.Semigroup (Semigroup (..), All(..))

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

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

206type KindOf (a :: k) = k

207

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

209+

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

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

209

211

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

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

@@ -236,26 +238,46 @@ deleteFirst _ [] = []

236deleteFirst p (x : xs) = if p x then xs else x : deleteFirst p xs

238deleteFirst p (x : xs) = if p x then xs else x : deleteFirst p xs

237

239

238{- |

240{- |

239−Update a value at a specific key with the result of the provided function. When

241+Update a value at a specific key with the result of the provided function.

240−the key is not a member of the map, the original map is returned.

242+When the key is not a member of the map, the original map is returned.

241

243

242>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "a"]

244>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "a"]

243>>> lookup @String $ adjust (fmap (++ "ww")) trmap

245>>> lookup @String $ adjust (fmap (++ "ww")) trmap

244Just (Identity "aww")

246Just (Identity "aww")

245-}

247-}

246adjust :: forall a f . Typeable a => (f a -> f a) -> TypeRepMap f -> TypeRepMap f

248adjust :: forall a f . Typeable a => (f a -> f a) -> TypeRepMap f -> TypeRepMap f

249+adjust fun = alter (fmap fun)

250+{-# INLINE adjust #-}

251+

252+{- |

253+Updates a value at a specific key, whether or not it exists.

254+This can be used to insert, delete, or update a value of a given type in the map.

255+

256+>>> func = (\case Nothing -> Just (Identity "new"); Just (Identity s) -> Just (Identity (reverse s)))

257+>>> lookup @String $ alter func empty

258+Just (Identity "new")

259+>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "helllo"]

260+>>> lookup @String $ alter func trmap

261+>>> Just (Identity "olleh")

262+-}

263+alter :: forall a f . Typeable a => (Maybe (f a) -> Maybe (f a)) -> TypeRepMap f -> TypeRepMap f

247−adjust fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of

264+alter fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of

248− Nothing -> tr

265+ Nothing ->

266+ case (fun Nothing) of

267+ Nothing -> tr

268+ Just v -> insert v tr

269+ Just i ->

270+ case fun (Just . fromAny $ indexArray (trAnys tr) i) of

271+ Nothing -> delete @a tr

249− Just i -> tr {trAnys = changeAnyArr i (trAnys tr)}

272+ Just v -> tr{trAnys = replaceAnyAt i (toAny v) (trAnys tr)}

250 where

273 where

251− changeAnyArr :: Int -> Array Any -> Array Any

274+ replaceAnyAt :: Int -> Any -> Array Any -> Array Any

252− changeAnyArr i trAs = runST $ do

275+ replaceAnyAt i v trAs = runST $ do

253 let n = sizeofArray trAs

276 let n = sizeofArray trAs

254 mutArr <- thawArray trAs 0 n

277 mutArr <- thawArray trAs 0 n

255− a <- toAny . fun . fromAny <$> readArray mutArr i

256− writeArray mutArr i a

278+ writeArray mutArr i v

257 unsafeFreezeArray mutArr

279 unsafeFreezeArray mutArr

258−{-# INLINE adjust #-}

280+{-# INLINE alter #-}

259

281

260{- | Map over the elements of a 'TypeRepMap'.

282{- | Map over the elements of a 'TypeRepMap'.

261

283

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

330union = unionWith const

352union = unionWith const

331{-# INLINE union #-}

353{-# INLINE union #-}

332

354

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+

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

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

334

398

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

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

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

365

429

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

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

367keys :: TypeRepMap f -> [SomeTypeRep]

431keys :: TypeRepMap f -> [SomeTypeRep]

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

432+keys = keysWith SomeTypeRep

369{-# INLINE keys #-}

433{-# INLINE keys #-}

370

434

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+

371-- | Binary searched based on this article

448-- | Binary searched based on this article

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

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

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

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

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

444instance Show (WrapTypeable f) where

521instance Show (WrapTypeable f) where

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

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

446

523

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

448−wrapTypeable tr = withTypeable tr WrapTypeable

449−

450{- |

524{- |

451

525

452prop> fromList . toList == 'id'

526prop> fromList . toList == 'id'

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

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

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

475

549

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

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

477− toList = map toWrapTypeable . toTriples

551+ toList = toListWith WrapTypeable

478− where

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

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

481

552

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

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

483calcFp = typeRepFingerprint $ typeRep @a

554calcFp = typeRepFingerprint $ typeRep @a

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

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

5import Prelude hiding (lookup)

7import Data.Functor.Identity (Identity (..))

8+import Data.List (sortBy)

9+import Data.Ord (comparing)

10+import Data.Typeable (cast)

8−import GHC.Exts (fromList)

11+import GHC.Exts (fromList, toList)

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

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

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

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

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

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

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

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

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

16typeRepMapSpec :: Spec

20typeRepMapSpec :: Spec

17typeRepMapSpec = describe "TypeRepMap" $ do

21typeRepMapSpec = describe "TypeRepMap" $ do

18 describe "Lookup Test" $ do

22 describe "Lookup Test" $ do

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

39 lookup m `shouldBe` Just True

43 lookup m `shouldBe` Just True

40 lookup @Int m `shouldBe` Nothing

44 lookup @Int m `shouldBe` Nothing

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

100

43mapOf10 :: TMap

101mapOf10 :: TMap

44mapOf10 = insert True

102mapOf10 = insert True

test/Test/TypeRep/TypeRepMapProperty.hs+59−27

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

20import Test.Hspec.Hedgehog (hedgehog)

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

23− lookup, member, generateOrderMapping, fromSortedList)

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

24+ adjust, alter, intersection)

25import qualified Hedgehog.Gen as Gen

26import qualified Hedgehog.Gen as Gen

26import qualified Hedgehog.Range as Range

27import qualified Hedgehog.Range as Range

@@ -34,6 +35,11 @@ typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do

34 deleteMemberSpec

35 deleteMemberSpec

35 insertInvariantSpec

36 insertInvariantSpec

36 deleteInvariantSpec

37 deleteInvariantSpec

38+ alterInsertSpec

39+ alterDeleteSpec

40+ alterAdjustSpec

41+ alterModifySpec

42+ intersectionSpec

37 describe "Internal helpers" $ do

43 describe "Internal helpers" $ do

38 generateOrderMappingInvariantSpec

44 generateOrderMappingInvariantSpec

39 describe "Instance Laws" $ do

45 describe "Instance Laws" $ do

@@ -82,11 +88,48 @@ deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do

82 WrapTypeable (_ :: IntProxy n) <- forAll genTF

88 WrapTypeable (_ :: IntProxy n) <- forAll genTF

83 assert $ invariantCheck (delete @n m)

89 assert $ invariantCheck (delete @n m)

91+alterInsertSpec :: Property

92+alterInsertSpec = it "insert proxy m === alter (const (Just proxy)) m" $ hedgehog $ do

93+ m <- forAll genMap

94+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF

95+ insert proxy m === alter (const (Just proxy)) m

96+

97+alterDeleteSpec :: Property

98+alterDeleteSpec = it "delete proxy m === alter (const Nothing) m" $ hedgehog $ do

99+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF

100+ m <- insert proxy <$> forAll genMap

101+ delete @n @IntProxy m === alter @n @IntProxy (const Nothing) m

102+

103+alterAdjustSpec :: Property

104+alterAdjustSpec = it "adjust f m == alter (fmap f) m" $ hedgehog $ do

105+ m <- forAll genMap

106+ WrapTypeable (_ :: IntProxy n) <- forAll genTF

107+ let f (IntProxy p n) = IntProxy p (n * 10)

108+ adjust @n @IntProxy f m === alter @n @IntProxy (fmap f) m

109+

110+alterModifySpec :: Property

111+alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do

112+ m <- forAll genMap

113+ WrapTypeable (_ :: IntProxy n) <- forAll genTF

114+ randInt <- forAll (Gen.int Range.constantBounded)

115+ -- Function with some interesting behaviour, which inserts, seletes and modifies

116+ let f Nothing = Just (IntProxy Proxy randInt)

117+ f (Just (IntProxy p n))

118+ | even n = Nothing

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

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

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+

85----------------------------------------------------------------------------

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

86-- Internal helpers

129-- Internal helpers

87----------------------------------------------------------------------------

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

88generateOrderMappingInvariantSpec :: Property

131generateOrderMappingInvariantSpec :: Property

89−generateOrderMappingInvariantSpec =

132+generateOrderMappingInvariantSpec =

90 it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do

133 it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do

91 n <- forAll $ Gen.int (Range.linear 0 100)

134 n <- forAll $ Gen.int (Range.linear 0 100)

92 fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]

135 fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]

@@ -95,41 +138,16 @@ generateOrderMappingInvariantSpec =

95-- Semigroup and Monoid laws

138-- Semigroup and Monoid laws

96----------------------------------------------------------------------------

139----------------------------------------------------------------------------

140

98−#if __GLASGOW_HASKELL__ < 806

99−{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's.

100−It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because

101−it doesn't compare values so it's not true equality. But this should be enough

102−for tests.

103−-}

104−newtype FpMap f = FpMap (TypeRepMap f)

105− deriving newtype (Show, Semigroup, Monoid)

106−

107−instance Eq (FpMap f) where

108− FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) =

109− as1 == as2 && bs1 == bs2

110−#endif

111−

112semigroupAssocSpec :: Property

141semigroupAssocSpec :: Property

113semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do

142semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do

114−#if __GLASGOW_HASKELL__ >= 806

115 x <- forAll genMap

143 x <- forAll genMap

116 y <- forAll genMap

144 y <- forAll genMap

117 z <- forAll genMap

145 z <- forAll genMap

118−#else

119− x <- FpMap <$> forAll genMap

120− y <- FpMap <$> forAll genMap

121− z <- FpMap <$> forAll genMap

122−#endif

123 (x <> (y <> z)) === ((x <> y) <> z)

146 (x <> (y <> z)) === ((x <> y) <> z)

124

147

125monoidIdentitySpec :: Property

148monoidIdentitySpec :: Property

126monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do

149monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do

127−#if __GLASGOW_HASKELL__ >= 806

128 x <- forAll genMap

150 x <- forAll genMap

129−#else

130− x <- FpMap <$> forAll genMap

131−#endif

132−

133 x <> mempty === x

151 x <> mempty === x

134 mempty <> x === x

152 mempty <> x === x

135

153

@@ -150,3 +168,17 @@ genTF = do

150 case someNatVal randNat of

168 case someNatVal randNat of

151 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt

169 Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt

152 Nothing -> error "Invalid test generator"

170 Nothing -> error "Invalid test generator"

171+

172+----------------------------------------------------------------------------

173+-- Helpers

174+----------------------------------------------------------------------------

175+#if __GLASGOW_HASKELL__ < 806

176+{- | We add an orphan Eq instance for old GHC versions just to make testing easier.

177+It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because

178+it doesn't compare values so it's not true equality. But this should be enough

179+for tests.

180+-}

181+instance Eq (TypeRepMap f) where

182+ TypeRepMap as1 bs1 _ _ == TypeRepMap as2 bs2 _ _ =

183+ as1 == as2 && bs1 == bs2

184+#endif