main..73e7201 · typerep-map

git.iko.soy/typerep-map

on 73e7201 help sign in

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

since splitsnapshots

unifiedsplit

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

1name: CI

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

4on:

3on:

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

5+ # but only for the master branch

5 push:

6 push:

6 branches:

7 branches:

7− - main

8+ - master

8 pull_request:

9 pull_request:

10jobs:

11jobs:

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

24 steps:

25 steps:

25 - uses: actions/checkout@v2

26 - uses: actions/checkout@v2

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

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

28 - uses: actions/setup-haskell@v1

29 - uses: actions/setup-haskell@v1

29 name: Setup Haskell

30 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/releases

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

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=main&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=master&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+1−43

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

37 , delete

38 , unionWith

39 , union

40− , intersectionWith

41− , intersection

42 , map

40 , map

43 , adjust

41 , adjust

44− , alter

46 -- * Query

43 -- * Query

47 , lookup

44 , lookup

48 , member

45 , member

49 , size

46 , size

50 , keys

47 , keys

51− , keysWith

52− , toListWith

53 ) where

48 ) where

55import Prelude hiding (lookup, map)

50import Prelude hiding (lookup, map)

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

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

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

58import Data.Typeable (Typeable)

53import Data.Typeable (Typeable)

59import GHC.Exts (coerce)

54import GHC.Exts (coerce)

60−import Type.Reflection (SomeTypeRep, TypeRep)

55+import Type.Reflection (SomeTypeRep)

62import qualified Data.TypeRepMap as F

57import qualified Data.TypeRepMap as F

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

136union = F.union

131union = F.union

137{-# INLINE union #-}

132{-# INLINE union #-}

138

133

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−

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

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

158

135

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

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

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

187keys = F.keys

164keys = F.keys

188{-# INLINE keys #-}

165{-# INLINE keys #-}

189

166

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−

200-- | Map a function over the values.

167-- | Map a function over the values.

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

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

202map f = F.hoistWithKey (liftToIdentity f)

169map f = F.hoistWithKey (liftToIdentity f)

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

207adjust f = F.adjust (liftToIdentity f)

174adjust f = F.adjust (liftToIdentity f)

208{-# INLINE adjust #-}

175{-# INLINE adjust #-}

209

176

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−

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

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

220liftToIdentity = coerce

178liftToIdentity = coerce

src/Data/TypeRepMap.hs+1−6

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,22 +57,17 @@ module Data.TypeRepMap

57 , insert

58 , delete

59 , adjust

60− , alter

61 , hoist

60 , hoist

62 , hoistA

61 , hoistA

63 , hoistWithKey

62 , hoistWithKey

64 , unionWith

63 , unionWith

65 , union

64 , union

66− , intersectionWith

67− , intersection

69 -- * Query

66 -- * Query

70 , lookup

67 , lookup

71 , member

68 , member

72 , size

69 , size

73 , keys

70 , keys

74− , keysWith

75− , toListWith

77 -- * 'IsList'

72 -- * 'IsList'

78 , WrapTypeable (..)

73 , WrapTypeable (..)

src/Data/TypeRepMap/Internal.hs+20−102

@@ -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', sizeofArray,

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

49 thawArray, unsafeFreezeArray, writeArray)

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

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

@@ -187,26 +187,13 @@ prop> member @a (insert (x :: f a) tm) == True

187

188-}

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

190−insert x m

190+insert = union . one

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)}

195− where

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

197− changeAnyArr i trAs = runST $ do

198− let n = sizeofArray trAs

199− mutArr <- thawArray trAs 0 n

200− writeArray mutArr i $ toAny x

201− unsafeFreezeArray mutArr

202{-# INLINE insert #-}

191{-# INLINE insert #-}

203

192

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

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

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

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

206type KindOf (a :: k) = k

195type KindOf (a :: k) = k

207

196

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

209−

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

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

211

198

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

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

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

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

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

239

226

240{- |

227{- |

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

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

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

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

243

230

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

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

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

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

246Just (Identity "aww")

233Just (Identity "aww")

247-}

234-}

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

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

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

236+adjust fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of

265− Nothing ->

237+ Nothing -> tr

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

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

238+ Just i -> tr {trAnys = changeAnyArr i (trAnys tr)}

273 where

239 where

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

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

275− replaceAnyAt i v trAs = runST $ do

241+ changeAnyArr i trAs = runST $ do

276 let n = sizeofArray trAs

242 let n = sizeofArray trAs

277 mutArr <- thawArray trAs 0 n

243 mutArr <- thawArray trAs 0 n

244+ a <- toAny . fun . fromAny <$> readArray mutArr i

278− writeArray mutArr i v

245+ writeArray mutArr i a

279 unsafeFreezeArray mutArr

246 unsafeFreezeArray mutArr

280−{-# INLINE alter #-}

247+{-# INLINE adjust #-}

281

248

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

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

283

250

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

352union = unionWith const

319union = unionWith const

353{-# INLINE union #-}

320{-# INLINE union #-}

354

321

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−

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

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

398

323

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

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

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

429

354

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

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

431keys :: TypeRepMap f -> [SomeTypeRep]

356keys :: TypeRepMap f -> [SomeTypeRep]

432−keys = keysWith SomeTypeRep

357+keys TypeRepMap{..} = SomeTypeRep . anyToTypeRep <$> toList trKeys

433{-# INLINE keys #-}

358{-# INLINE keys #-}

434

359

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−

448-- | Binary searched based on this article

360-- | Binary searched based on this article

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

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

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

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

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

521instance Show (WrapTypeable f) where

433instance Show (WrapTypeable f) where

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

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

523

435

436+wrapTypeable :: TypeRep a -> f a -> WrapTypeable f

437+wrapTypeable tr = withTypeable tr WrapTypeable

438+

524{- |

439{- |

525

440

526prop> fromList . toList == 'id'

441prop> fromList . toList == 'id'

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

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

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

549

464

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

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

551− toList = toListWith WrapTypeable

466+ toList = map toWrapTypeable . toTriples

467+ where

468+ toWrapTypeable :: (Fingerprint, Any, Any) -> WrapTypeable f

469+ toWrapTypeable (_, an, k) = wrapTypeable (unsafeCoerce k) (fromAny an)

552

470

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

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

554calcFp = typeRepFingerprint $ typeRep @a

472calcFp = typeRepFingerprint $ typeRep @a

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

@@ -5,18 +5,14 @@ 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)

11−import GHC.Exts (fromList, toList)

8+import GHC.Exts (fromList)

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

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

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

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

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

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

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

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

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

20typeRepMapSpec :: Spec

16typeRepMapSpec :: Spec

21typeRepMapSpec = describe "TypeRepMap" $ do

17typeRepMapSpec = describe "TypeRepMap" $ do

22 describe "Lookup Test" $ do

18 describe "Lookup Test" $ do

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

43 lookup m `shouldBe` Just True

39 lookup m `shouldBe` Just True

44 lookup @Int m `shouldBe` Nothing

40 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

101mapOf10 :: TMap

43mapOf10 :: TMap

102mapOf10 = insert True

44mapOf10 = insert True

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

@@ -20,8 +20,7 @@ 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, union, generateOrderMapping, fromSortedList,

23+ lookup, member, generateOrderMapping, fromSortedList)

24− adjust, alter, intersection)

26import qualified Hedgehog.Gen as Gen

25import qualified Hedgehog.Gen as Gen

27import qualified Hedgehog.Range as Range

26import qualified Hedgehog.Range as Range

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

35 deleteMemberSpec

34 deleteMemberSpec

36 insertInvariantSpec

35 insertInvariantSpec

37 deleteInvariantSpec

36 deleteInvariantSpec

38− alterInsertSpec

39− alterDeleteSpec

40− alterAdjustSpec

41− alterModifySpec

42− intersectionSpec

43 describe "Internal helpers" $ do

37 describe "Internal helpers" $ do

44 generateOrderMappingInvariantSpec

38 generateOrderMappingInvariantSpec

45 describe "Instance Laws" $ do

39 describe "Instance Laws" $ do

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

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

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

89 assert $ invariantCheck (delete @n m)

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

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

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

129-- Internal helpers

86-- Internal helpers

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

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

131generateOrderMappingInvariantSpec :: Property

88generateOrderMappingInvariantSpec :: Property

132−generateOrderMappingInvariantSpec =

89+generateOrderMappingInvariantSpec =

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

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

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

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

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

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

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

138-- Semigroup and Monoid laws

95-- Semigroup and Monoid laws

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

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

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+

141semigroupAssocSpec :: Property

112semigroupAssocSpec :: Property

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

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

114+#if __GLASGOW_HASKELL__ >= 806

143 x <- forAll genMap

115 x <- forAll genMap

144 y <- forAll genMap

116 y <- forAll genMap

145 z <- forAll genMap

117 z <- forAll genMap

118+#else

119+ x <- FpMap <$> forAll genMap

120+ y <- FpMap <$> forAll genMap

121+ z <- FpMap <$> forAll genMap

122+#endif

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

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

147

124

148monoidIdentitySpec :: Property

125monoidIdentitySpec :: Property

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

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

127+#if __GLASGOW_HASKELL__ >= 806

150 x <- forAll genMap

128 x <- forAll genMap

129+#else

130+ x <- FpMap <$> forAll genMap

131+#endif

132+

151 x <> mempty === x

133 x <> mempty === x

152 mempty <> x === x

134 mempty <> x === x

153

135

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

168 case someNatVal randNat of

150 case someNatVal randNat of

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

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

170 Nothing -> error "Invalid test generator"

152 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