aeef5b8...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+47−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

@@ -87,6 +92,7 @@ one x = coerce (F.one @a @Identity $ coerce x)

87{- |

92{- |

89Insert a value into a 'TMap'.

94Insert a value into a 'TMap'.

95+TMap optimizes for fast reads rather than inserts, as a trade-off inserts are @O(n)@.

91prop> size (insert v tm) >= size tm

97prop> size (insert v tm) >= size tm

92prop> member @a (insert (x :: a) tm) == True

98prop> member @a (insert (x :: a) tm) == True

@@ -98,6 +104,9 @@ insert x = coerce (F.insert @a @Identity $ coerce x)

104

99{- | Delete a value from a 'TMap'.

105{- | Delete a value from a 'TMap'.

100

106

107+TMap optimizes for fast reads rather than modifications, as a trade-off deletes are @O(n)@,

108+with an @O(log(n))@ optimization for when the element is already missing.

109+

101prop> size (delete @a tm) <= size tm

110prop> size (delete @a tm) <= size tm

102prop> member @a (delete @a tm) == False

111prop> member @a (delete @a tm) == False

103

112

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

127union = F.union

136union = F.union

128{-# INLINE union #-}

137{-# INLINE union #-}

129

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+

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

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

131

158

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

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

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

160keys = F.keys

187keys = F.keys

161{-# INLINE keys #-}

188{-# INLINE keys #-}

162

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+

163-- | Map a function over the values.

200-- | Map a function over the values.

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

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

165map f = F.hoistWithKey (liftToIdentity f)

202map f = F.hoistWithKey (liftToIdentity f)

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

170adjust f = F.adjust (liftToIdentity f)

207adjust f = F.adjust (liftToIdentity f)

171{-# INLINE adjust #-}

208{-# INLINE adjust #-}

172

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+

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

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

174liftToIdentity = 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+116−29

@@ -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(..))

@@ -180,27 +180,38 @@ one x = TypeRepMap (primArrayFromListN 1 [fa])

180{- |

181

182Insert a value into a 'TypeRepMap'.

183+TypeRepMap optimizes for fast reads rather than inserts, as a trade-off inserts are @O(n)@.

183

184

184prop> size (insert v tm) >= size tm

185prop> size (insert v tm) >= size tm

185prop> member @a (insert (x :: f a) tm) == True

186prop> member @a (insert (x :: f a) tm) == True

186

187

187-}

188-}

188insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f

189insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f

189−insert x = fromTriples . addX . toTriples

190+insert x m

191+ | size m == 0 = one x

192+ | otherwise = case cachedBinarySearch (typeFp @a) (fingerprintAs m) (fingerprintBs m) of

193+ Nothing -> union m $ one x

194+ Just i -> m {trAnys = changeAnyArr i (trAnys m)}

190 where

195 where

191− tripleX :: (Fingerprint, Any, Any)

196+ changeAnyArr :: Int -> Array Any -> Array Any

192− tripleX@(fpX, _, _) = (calcFp @a, toAny x, unsafeCoerce $ typeRep @a)

197+ changeAnyArr i trAs = runST $ do

193−

198+ let n = sizeofArray trAs

194− addX :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)]

199+ mutArr <- thawArray trAs 0 n

195− addX l = tripleX : deleteByFst fpX l

200+ writeArray mutArr i $ toAny x

201+ unsafeFreezeArray mutArr

196{-# INLINE insert #-}

202{-# INLINE insert #-}

197

203

198-- Extract the kind of a type. We use it to work around lack of syntax for

204-- Extract the kind of a type. We use it to work around lack of syntax for

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

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

200type KindOf (a :: k) = k

206type KindOf (a :: k) = k

201

207

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

209+

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

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

203

211

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

213+@O(n)@, with an @O(log(n))@ optimization for when the element is already missing.

214+

204prop> size (delete @a tm) <= size tm

215prop> size (delete @a tm) <= size tm

205prop> member @a (delete @a tm) == False

216prop> member @a (delete @a tm) == False

206

217

@@ -213,30 +224,60 @@ False

213True

224True

214-}

225-}

215delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeRepMap f

226delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeRepMap f

216−delete = fromTriples . deleteByFst (typeFp @a) . toTriples

227+delete m

228+ -- Lookups are fast, so check if we even have the element first.

229+ | not (member @a m) = m

230+ -- We know we have the element, If the map has exactly one element, we can return the empty map

231+ | size m == 1 = empty

232+ -- Otherwise, filter out the element in linear time.

233+ | otherwise = fromSortedTriples . deleteFirst ((== typeFp @a) . fst3) . toSortedTriples $ m

217{-# INLINE delete #-}

234{-# INLINE delete #-}

218

235

236+deleteFirst :: (a -> Bool) -> [a] -> [a]

237+deleteFirst _ [] = []

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

239+

219{- |

240{- |

220−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.

221−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.

222

243

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

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

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

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

225Just (Identity "aww")

246Just (Identity "aww")

226-}

247-}

227adjust :: 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

228−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

229− 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

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

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

231 where

273 where

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

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

233− changeAnyArr i trAs = runST $ do

275+ replaceAnyAt i v trAs = runST $ do

234 let n = sizeofArray trAs

276 let n = sizeofArray trAs

235 mutArr <- thawArray trAs 0 n

277 mutArr <- thawArray trAs 0 n

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

237− writeArray mutArr i a

278+ writeArray mutArr i v

238 unsafeFreezeArray mutArr

279 unsafeFreezeArray mutArr

239−{-# INLINE adjust #-}

280+{-# INLINE alter #-}

240

281

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

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

242

283

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

311union = unionWith const

352union = unionWith const

312{-# INLINE union #-}

353{-# INLINE union #-}

313

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+

314{- | 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'.

315

398

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

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

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

346

429

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

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

348keys :: TypeRepMap f -> [SomeTypeRep]

431keys :: TypeRepMap f -> [SomeTypeRep]

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

432+keys = keysWith SomeTypeRep

350{-# INLINE keys #-}

433{-# INLINE keys #-}

351

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+

352-- | Binary searched based on this article

448-- | Binary searched based on this article

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

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

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

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

@@ -407,9 +503,6 @@ toSortedTriples tm = trip <$> ordering

407 ordering :: [ Int ]

503 ordering :: [ Int ]

408 ordering = generateOrderMapping (size tm)

504 ordering = generateOrderMapping (size tm)

409

505

410−deleteByFst :: Eq a => a -> [(a, b, c)] -> [(a, b, c)]

411−deleteByFst x = filter ((/= x) . fst3)

412−

413nubByFst :: (Eq a) => [(a, b, c)] -> [(a, b, c)]

506nubByFst :: (Eq a) => [(a, b, c)] -> [(a, b, c)]

414nubByFst = nubBy ((==) `on` fst3)

507nubByFst = nubBy ((==) `on` fst3)

415

508

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

428instance Show (WrapTypeable f) where

521instance Show (WrapTypeable f) where

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

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

430

523

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

432−wrapTypeable tr = withTypeable tr WrapTypeable

433−

434{- |

524{- |

435

525

436prop> fromList . toList == 'id'

526prop> fromList . toList == 'id'

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

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

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

459

549

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

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

461− toList = map toWrapTypeable . toTriples

551+ toList = toListWith WrapTypeable

462− where

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

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

465

552

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

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

467calcFp = 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