main..22af858 · typerep-map

git.iko.soy/typerep-map

on 22af858 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−47

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

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

92{- |

87{- |

94Insert a value into a 'TMap'.

89Insert a value into a 'TMap'.

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

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

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

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

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

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

104

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

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

106

100

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−

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

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

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

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

112

103

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

136union = F.union

127union = F.union

137{-# INLINE union #-}

128{-# INLINE union #-}

138

129

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

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

158

131

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

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

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

187keys = F.keys

160keys = F.keys

188{-# INLINE keys #-}

161{-# INLINE keys #-}

189

162

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.

163-- | Map a function over the values.

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

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

202map f = F.hoistWithKey (liftToIdentity f)

165map f = F.hoistWithKey (liftToIdentity f)

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

207adjust f = F.adjust (liftToIdentity f)

170adjust f = F.adjust (liftToIdentity f)

208{-# INLINE adjust #-}

171{-# INLINE adjust #-}

209

172

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

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

220liftToIdentity = coerce

174liftToIdentity = 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+49−196

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

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

49 thawArray, unsafeFreezeArray, writeArray)

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

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

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

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

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

@@ -64,6 +64,7 @@ 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

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

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

69{- |

70{- |

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

169

170

170-}

171-}

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

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

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

173+one x = insert x empty

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)

178{-# INLINE one #-}

174{-# INLINE one #-}

179

175

180{- |

176{- |

181

177

182Insert a value into a 'TypeRepMap'.

178Insert a value into a 'TypeRepMap'.

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

184

179

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

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

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

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

187

182

188-}

183-}

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

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

190−insert x m

185+insert x = fromTriples . addX . toTriples

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

186 where

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

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

197− changeAnyArr i trAs = runST $ do

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

198− let n = sizeofArray trAs

189+

199− mutArr <- thawArray trAs 0 n

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

200− writeArray mutArr i $ toAny x

191+ addX l = tripleX : deleteByFst fpX l

201− unsafeFreezeArray mutArr

202{-# INLINE insert #-}

192{-# INLINE insert #-}

203

193

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

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

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

206type KindOf (a :: k) = k

196type KindOf (a :: k) = k

207

197

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

209−

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

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

211

199

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−

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

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

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

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

217

202

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

224True

209True

225-}

210-}

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

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

227−delete m

212+delete = fromTriples . deleteByFst (typeFp @a) . toTriples

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

234{-# INLINE delete #-}

213{-# INLINE delete #-}

235

214

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

237−deleteFirst _ [] = []

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

239−

240{- |

215{- |

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

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

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

243

218

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

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

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

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

246Just (Identity "aww")

221Just (Identity "aww")

247-}

222-}

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

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

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

265− Nothing ->

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

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

273 where

227 where

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

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

275− replaceAnyAt i v trAs = runST $ do

229+ changeAnyArr i trAs = runST $ do

276 let n = sizeofArray trAs

230 let n = sizeofArray trAs

277 mutArr <- thawArray trAs 0 n

231 mutArr <- thawArray trAs 0 n

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

278− writeArray mutArr i v

233+ writeArray mutArr i a

279 unsafeFreezeArray mutArr

234 unsafeFreezeArray mutArr

280−{-# INLINE alter #-}

235+{-# INLINE adjust #-}

281

236

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

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

283

238

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

311 withTr t = withTypeable t f

266 withTr t = withTypeable t f

312{-# INLINE hoistWithKey #-}

267{-# INLINE hoistWithKey #-}

313

268

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

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

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

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

316−unionWith f ma mb = do

271+unionWith f m1 m2 = fromTriples

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

272+ $ toTripleList

273+ $ Map.unionWith combine

274+ (fromTripleList $ toTriples m1)

275+ (fromTripleList $ toTriples m2)

318 where

276 where

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

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

320 f' tr = withTypeable tr f

278 f' tr = withTypeable tr f

321

279

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

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

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

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

324−

282+

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

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

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

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

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

285+

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

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

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

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

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

347{-# INLINE unionWith #-}

288{-# INLINE unionWith #-}

348

289

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

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

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

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

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

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

352union = unionWith const

293union = unionWith const

353{-# INLINE union #-}

294{-# INLINE union #-}

354

295

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

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

398

297

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

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

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

429

328

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

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

431keys :: TypeRepMap f -> [SomeTypeRep]

330keys :: TypeRepMap f -> [SomeTypeRep]

432−keys = keysWith SomeTypeRep

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

433{-# INLINE keys #-}

332{-# INLINE keys #-}

434

333

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

334-- | Binary searched based on this article

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

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

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

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

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

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

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

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

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

490

376

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

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

492−--

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

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)

505

379

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

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

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

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

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

521instance Show (WrapTypeable f) where

395instance Show (WrapTypeable f) where

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

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

523

397

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

399+wrapTypeable tr = withTypeable tr WrapTypeable

400+

524{- |

401{- |

525

402

526prop> fromList . toList == 'id'

403prop> fromList . toList == 'id'

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

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

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

549

426

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

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

551− toList = toListWith WrapTypeable

428+ toList = map toWrapTypeable . toTriples

429+ where

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

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

552

432

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

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

554calcFp = typeRepFingerprint $ typeRep @a

434calcFp = typeRepFingerprint $ typeRep @a

555

435

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

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

557−fromTriples = fromSortedTriples . sortWith fst3 . nubByFst

558−

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

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

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

561 where

438 where

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

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

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

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

564

441

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

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

566-- Tree-like conversion

443-- Tree-like conversion

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

587 writeArray result i (indexArray origin newFirst)

464 writeArray result i (indexArray origin newFirst)

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

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

589

466

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−

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

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

615-- Helper functions.

468-- Helper functions.

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

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

617

470

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

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

619-- The structure maintains the following invariant.

472-- The structure maintains the following invariant.

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

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

621--

474--

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

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

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

44− generateOrderMappingInvariantSpec

45 describe "Instance Laws" $ do

37 describe "Instance Laws" $ do

46 semigroupAssocSpec

38 semigroupAssocSpec

47 monoidIdentitySpec

39 monoidIdentitySpec

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

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

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

89 assert $ invariantCheck (delete @n m)

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

129−-- Internal helpers

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−

137----------------------------------------------------------------------------

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

138-- Semigroup and Monoid laws

84-- Semigroup and Monoid laws

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

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

140

87+#if __GLASGOW_HASKELL__ < 806

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)

95+

96+instance Eq (FpMap f) where

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

98+ as1 == as2 && bs1 == bs2

99+#endif

100+

141semigroupAssocSpec :: Property

101semigroupAssocSpec :: Property

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

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

103+#if __GLASGOW_HASKELL__ >= 806

143 x <- forAll genMap

104 x <- forAll genMap

144 y <- forAll genMap

105 y <- forAll genMap

145 z <- forAll genMap

106 z <- forAll genMap

107+#else

108+ x <- FpMap <$> forAll genMap

109+ y <- FpMap <$> forAll genMap

110+ z <- FpMap <$> forAll genMap

111+#endif

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

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

147

113

148monoidIdentitySpec :: Property

114monoidIdentitySpec :: Property

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

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

116+#if __GLASGOW_HASKELL__ >= 806

150 x <- forAll genMap

117 x <- forAll genMap

118+#else

119+ x <- FpMap <$> forAll genMap

120+#endif

121+

151 x <> mempty === x

122 x <> mempty === x

152 mempty <> x === x

123 mempty <> x === x

153

124

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

168 case someNatVal randNat of

139 case someNatVal randNat of

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

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

170 Nothing -> error "Invalid test generator"

141 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+2−1

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

73 Data.TypeRepMap

74 Data.TypeRepMap.Internal

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

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

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

77 , primitive ^>= 0.7.0

78 , primitive ^>= 0.7.0

78 , deepseq ^>= 1.4

79 , deepseq ^>= 1.4