22af858...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+196−49

@@ -45,9 +45,9 @@ 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)

50−import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)

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

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

52import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))

53import GHC.Exts (IsList (..), inline, sortWith)

@@ -64,7 +64,6 @@ import Type.Reflection (SomeTypeRep (..), TypeRep, Typeable, typeRep, withTypeab

64import Type.Reflection.Unsafe (typeRepFingerprint)

65import Unsafe.Coerce (unsafeCoerce)

67−import qualified Data.Map.Strict as Map

68import qualified GHC.Exts as GHC (fromList, toList)

67import qualified GHC.Exts as GHC (fromList, toList)

70{- |

69{- |

@@ -170,33 +169,49 @@ prop> member @a (one (x :: f a)) == True

170

169

171-}

170-}

172one :: forall a f . Typeable a => f a -> TypeRepMap f

171one :: forall a f . Typeable a => f a -> TypeRepMap f

173−one x = insert x empty

172+one x = TypeRepMap (primArrayFromListN 1 [fa])

173+ (primArrayFromListN 1 [fb])

174+ (pure @Array v)

175+ (pure @Array k)

176+ where

177+ (Fingerprint fa fb, v, k) = (calcFp @a, toAny x, unsafeCoerce $ typeRep @a)

174{-# INLINE one #-}

178{-# INLINE one #-}

175

179

176{- |

180{- |

177

181

178Insert a value into a 'TypeRepMap'.

182Insert a value into a 'TypeRepMap'.

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

179

184

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

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

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

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

182

187

183-}

188-}

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

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

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

186 where

195 where

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

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

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

197+ changeAnyArr i trAs = runST $ do

189−

198+ let n = sizeofArray trAs

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

199+ mutArr <- thawArray trAs 0 n

191− addX l = tripleX : deleteByFst fpX l

200+ writeArray mutArr i $ toAny x

201+ unsafeFreezeArray mutArr

192{-# INLINE insert #-}

202{-# INLINE insert #-}

193

203

194-- 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

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

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

196type KindOf (a :: k) = k

206type KindOf (a :: k) = k

197

207

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

209+

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

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

199

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+

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

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

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

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

202

217

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

209True

224True

210-}

225-}

211delete :: 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

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

213{-# INLINE delete #-}

234{-# INLINE delete #-}

214

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+

215{- |

240{- |

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

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

218

243

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

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

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

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

221Just (Identity "aww")

246Just (Identity "aww")

222-}

247-}

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

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

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

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

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

227 where

273 where

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

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

229− changeAnyArr i trAs = runST $ do

275+ replaceAnyAt i v trAs = runST $ do

230 let n = sizeofArray trAs

276 let n = sizeofArray trAs

231 mutArr <- thawArray trAs 0 n

277 mutArr <- thawArray trAs 0 n

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

233− writeArray mutArr i a

278+ writeArray mutArr i v

234 unsafeFreezeArray mutArr

279 unsafeFreezeArray mutArr

235−{-# INLINE adjust #-}

280+{-# INLINE alter #-}

236

281

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

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

238

283

@@ -266,33 +311,89 @@ hoistWithKey f (TypeRepMap as bs ans ks) = TypeRepMap as bs newAns ks

266 withTr t = withTypeable t f

311 withTr t = withTypeable t f

267{-# INLINE hoistWithKey #-}

312{-# INLINE hoistWithKey #-}

268

313

269−-- | The union of two 'TypeRepMap's using a combining function.

314+-- | The union of two 'TypeRepMap's using a combining function for conflicting entries. @O(n + m)@

270unionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f

315unionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f

271−unionWith f m1 m2 = fromTriples

316+unionWith f ma mb = do

272− $ toTripleList

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

273− $ Map.unionWith combine

274− (fromTripleList $ toTriples m1)

275− (fromTripleList $ toTriples m2)

276 where

318 where

277 f' :: forall x. TypeRep x -> f x -> f x -> f x

319 f' :: forall x. TypeRep x -> f x -> f x -> f x

278 f' tr = withTypeable tr f

320 f' tr = withTypeable tr f

279

321

280− combine :: (Any, Any) -> (Any, Any) -> (Any, Any)

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

281− combine (av, ak) (bv, _) = (toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak)

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

282−

324+

283− fromTripleList :: Ord a => [(a, b, c)] -> Map.Map a (b, c)

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

284− fromTripleList = Map.fromList . map (\(a, b, c) -> (a, (b, c)))

326+ -- Using 'toSortedTriples' allows us to assume the triples are sorted by fingerprint,

285−

327+ -- Given O(n) performance from 'toSortedTriples', and given that we can merge-sort in

286− toTripleList :: Map.Map a (b, c) -> [(a, b, c)]

328+ -- O(n + m) time, then can '.fromSortedTriples' back into cachedBinarySearch order in O(n + m)

287− toTripleList = map (\(a, (b, c)) -> (a, b, c)) . Map.toList

329+ -- that gives a total of O(n + m).

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

331+ -- We've addressed all elements from both maps

332+ mergeMaps as [] = as

333+ mergeMaps [] bs = bs

334+ -- Merge

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

336+ case compare af bf of

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

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

339+ -- fingerprints

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

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

342+ -- Add it to the result as-is

343+ LT -> a : mergeMaps as (b : bs)

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

345+ -- Add it to the result as-is

346+ GT -> b : mergeMaps (a:as) bs

288{-# INLINE unionWith #-}

347{-# INLINE unionWith #-}

289

348

290−-- | The (left-biased) union of two 'TypeRepMap's. It prefers the first map when

349+-- | The (left-biased) union of two 'TypeRepMap's in @O(n + m)@. It prefers the first map when

291-- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@.

350-- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@.

292union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

351union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

293union = unionWith const

352union = unionWith const

294{-# INLINE union #-}

353{-# INLINE union #-}

295

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+

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

297

398

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

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

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

328

429

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

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

330keys :: TypeRepMap f -> [SomeTypeRep]

431keys :: TypeRepMap f -> [SomeTypeRep]

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

432+keys = keysWith SomeTypeRep

332{-# INLINE keys #-}

433{-# INLINE keys #-}

333

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+

334-- | Binary searched based on this article

448-- | Binary searched based on this article

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

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

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

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

@@ -374,8 +488,20 @@ typeFp = typeRepFingerprint $ typeRep @a

374toTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)]

488toTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)]

375toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ trAnys tm) (GHC.toList $ trKeys tm)

489toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ trAnys tm) (GHC.toList $ trKeys tm)

376

490

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

491+-- | Efficiently get sorted triples from a map in O(n) time

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

492+--

493+-- We assume the incoming TypeRepMap is already sorted into 'cachedBinarySearch' order using fromSortedList.

494+-- Then we can construct the index mapping from the "cached" ordering into monotonically

495+-- increasing order using 'generateOrderMapping' with the length of the TRM. This takes @O(n).

496+-- We then pull those indexes from the source TRM to get the sorted triples in a total of @O(n).

497+toSortedTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)]

498+toSortedTriples tm = trip <$> ordering

499+ where

500+ trip i = ( Fingerprint (indexPrimArray (fingerprintAs tm) i) (indexPrimArray (fingerprintBs tm) i)

501+ , indexArray (trAnys tm) i

502+ , indexArray (trKeys tm) i)

503+ ordering :: [ Int ]

504+ ordering = generateOrderMapping (size tm)

379

505

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

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

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

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

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

395instance Show (WrapTypeable f) where

521instance Show (WrapTypeable f) where

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

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

397

523

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

399−wrapTypeable tr = withTypeable tr WrapTypeable

400−

401{- |

524{- |

402

525

403prop> fromList . toList == 'id'

526prop> fromList . toList == 'id'

@@ -425,19 +548,19 @@ instance IsList (TypeRepMap f) where

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

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

426

549

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

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

428− toList = map toWrapTypeable . toTriples

551+ toList = toListWith WrapTypeable

429− where

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

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

432

552

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

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

434calcFp = typeRepFingerprint $ typeRep @a

554calcFp = typeRepFingerprint $ typeRep @a

435

555

436fromTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f

556fromTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f

557+fromTriples = fromSortedTriples . sortWith fst3 . nubByFst

558+

559+fromSortedTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f

437−fromTriples kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans) (GHC.fromList ks)

560+fromSortedTriples kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans) (GHC.fromList ks)

438 where

561 where

439 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps

562 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps

440− (fps, ans, ks) = unzip3 $ fromSortedList $ sortWith fst3 $ nubByFst kvs

563+ (fps, ans, ks) = unzip3 $ fromSortedList kvs

441

564

442----------------------------------------------------------------------------

565----------------------------------------------------------------------------

443-- Tree-like conversion

566-- Tree-like conversion

@@ -464,11 +587,35 @@ fromSortedList l = runST $ do

464 writeArray result i (indexArray origin newFirst)

587 writeArray result i (indexArray origin newFirst)

465 loop (2 * i + 2) (newFirst + 1)

588 loop (2 * i + 2) (newFirst + 1)

466

589

590+-- Returns a list of indexes which represents the "sorted" order of an array generated by

591+-- fromSortedList of the provided length.

592+-- I.e. fmap (fromSortedList [1, 2, 3, 4, 5, 6] !!) (generateOrderMapping 6) == [1, 2, 3, 4, 5, 6]

593+--

594+-- >>> generateOrderMapping 6

595+-- [3,1,4,0,5,2]

596+--

597+-- >>> generateOrderMapping 8

598+-- [7,3,1,4,0,5,2,6]

599+generateOrderMapping :: Int -> [Int]

600+generateOrderMapping len = runST $ do

601+ orderMappingArr <- newPrimArray len

602+ _ <- loop orderMappingArr 0 0

603+ primArrayToList <$> unsafeFreezePrimArray orderMappingArr

604+ where

605+ loop :: MutablePrimArray s Int -> Int -> Int -> ST s Int

606+ loop result i first =

607+ if i >= len

608+ then pure first

609+ else do

610+ newFirst <- loop result (2 * i + 1) first

611+ writePrimArray result newFirst i

612+ loop result (2 * i + 2) (newFirst + 1)

613+

467----------------------------------------------------------------------------

614----------------------------------------------------------------------------

468-- Helper functions.

615-- Helper functions.

469----------------------------------------------------------------------------

616----------------------------------------------------------------------------

470

617

471−-- | Check that invariant of the structure is hold.

618+-- | Check that invariant of the structure holds.

472-- The structure maintains the following invariant.

619-- The structure maintains the following invariant.

473-- For each element @A@ at index @i@:

620-- For each element @A@ at index @i@:

474--

621--

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+69−26

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

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,13 @@ 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

43+ describe "Internal helpers" $ do

44+ generateOrderMappingInvariantSpec

37 describe "Instance Laws" $ do

45 describe "Instance Laws" $ do

38 semigroupAssocSpec

46 semigroupAssocSpec

39 monoidIdentitySpec

47 monoidIdentitySpec

@@ -80,45 +88,66 @@ deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do

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

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

81 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+

83----------------------------------------------------------------------------

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

84−-- Semigroup and Monoid laws

129+-- Internal helpers

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

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

131+generateOrderMappingInvariantSpec :: Property

132+generateOrderMappingInvariantSpec =

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

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

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

136

87−#if __GLASGOW_HASKELL__ < 806

137+----------------------------------------------------------------------------

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

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

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

91−for tests.

92−-}

93−newtype FpMap f = FpMap (TypeRepMap f)

94− deriving newtype (Show, Semigroup, Monoid)

138+-- Semigroup and Monoid laws

95−

139+----------------------------------------------------------------------------

96−instance Eq (FpMap f) where

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

98− as1 == as2 && bs1 == bs2

99−#endif

100

140

101semigroupAssocSpec :: Property

141semigroupAssocSpec :: Property

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

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

103−#if __GLASGOW_HASKELL__ >= 806

104 x <- forAll genMap

143 x <- forAll genMap

105 y <- forAll genMap

144 y <- forAll genMap

106 z <- forAll genMap

145 z <- forAll genMap

107−#else

108− x <- FpMap <$> forAll genMap

109− y <- FpMap <$> forAll genMap

110− z <- FpMap <$> forAll genMap

111−#endif

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

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

113

147

114monoidIdentitySpec :: Property

148monoidIdentitySpec :: Property

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

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

116−#if __GLASGOW_HASKELL__ >= 806

117 x <- forAll genMap

150 x <- forAll genMap

118−#else

119− x <- FpMap <$> forAll genMap

120−#endif

121−

122 x <> mempty === x

151 x <> mempty === x

123 mempty <> x === x

152 mempty <> x === x

124

153

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

139 case someNatVal randNat of

168 case someNatVal randNat of

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

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

141 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

typerep-map.cabal+1−2

@@ -73,8 +73,7 @@ library

73 Data.TypeRepMap

74 Data.TypeRepMap.Internal

76− build-depends: containers >= 0.5.10.2 && < 0.7

77− , ghc-prim >= 0.5.1.1 && < 0.7

76+ build-depends: ghc-prim >= 0.5.1.1 && < 0.7

78 , primitive ^>= 0.7.0

77 , primitive ^>= 0.7.0

79 , deepseq ^>= 1.4

78 , deepseq ^>= 1.4