bc49de4 · typerep-map · git.iko.soy

git.iko.soy/typerep-map

on main help sign in

[#25] Add TMap, restructure internal lib (#32)

bc49de4Veronika Romashkina8 years ago

benchmark/CacheMap.hs+2−2

compare with main

unifiedsplit

@@ -21,11 +21,11 @@ import Data.Proxy (Proxy (..))

21import Data.Typeable (Typeable)

22import GHC.TypeLits

24−import Data.TypeRep.CacheMap (TF (..), TypeRepMap (..), fromList, lookup)

24+import Data.TypeRep.Map (TF (..), TypeRepMap (..), fromList, lookup)

26benchCacheMap :: Benchmark

27benchCacheMap = bgroup "vector optimal cache"

28− [ bench "lookup" $ nf tenLookups bigMap

28+ [ bench "lookup" $ nf tenLookups bigMap

29 -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999)

30 -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1)

31 ]

internal/Data/TypeRep/CacheMap.hsdeleted−282

@@ -1,282 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MagicHash #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE Rank2Types #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeInType #-}

11−

12−-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}

13−

14−module Data.TypeRep.CacheMap

15− ( -- * Map type

16− TypeRepMap (..)

17−

18− -- 'TypeRepMap' interface

19− , empty

20− , one

21− , insert

22− , delete

23− , hoist

24− , unionWith

25− , union

26− , lookup

27− , member

28− , size

29−

30− -- * Helpful testing functions

31− , TF (..)

32− , fromList

33− , toFps

34− ) where

35−

36−import Prelude hiding (lookup)

37−

38−import Control.Arrow ((&&&))

39−import Data.Function (on)

40−import Data.IntMap.Strict (IntMap)

41−import Data.Kind (Type)

42−import Data.List (nubBy)

43−import Data.Maybe (fromJust)

44−import Data.Primitive.Array (Array, indexArray, mapArray')

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

46−import Data.Proxy (Proxy (..))

47−import Data.Typeable (Typeable, typeRep, typeRepFingerprint)

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

49−import GHC.Exts (inline, sortWith)

50−import GHC.Fingerprint (Fingerprint (..))

51−import GHC.Prim (eqWord#, ltWord#)

52−import GHC.Word (Word64 (..))

53−import Unsafe.Coerce (unsafeCoerce)

54−

55−import qualified Data.IntMap.Strict as IM

56−import qualified Data.Map.Strict as Map

57−import qualified GHC.Exts as GHC (fromList, toList)

58−

59−-- | Map-like data structure that keeps types as keys.

60−data TypeRepMap (f :: k -> Type) = TypeRepMap

61− { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64)

62− , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64)

63− , anys :: {-# UNPACK #-} !(Array Any)

64− }

65−

66−-- | Shows only 'Fingerprint's.

67−instance Show (TypeRepMap f) where

68− show = show . toFps

69−

70−-- | Returns the list of 'Fingerprint's from 'TypeRepMap'.

71−toFps :: TypeRepMap f -> [Fingerprint]

72−toFps TypeRepMap{..} = zipWith Fingerprint

73− (GHC.toList fingerprintAs)

74− (GHC.toList fingerprintBs)

75−

76−

77−-- | Empty structure.

78−empty :: TypeRepMap f

79−empty = TypeRepMap mempty mempty mempty

80−

81−-- | Construct a 'TypeRepMap' with a single element.

82−one :: forall a f . Typeable a => f a -> TypeRepMap f

83−one x = insert x empty

84−{-# INLINE one #-}

85−

86−-- | Inserts the value with its type as a key.

87−insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f

88−insert x = fromListPairs . addX . toPairList

89− where

90− pairX :: (Fingerprint, Any)

91− pairX@(fpX, _) = (calcFp x, toAny x)

92−

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

94− addX l = pairX : deleteByFst fpX l

95−{-# INLINE insert #-}

96−

97−-- Helper type to workaround some issues with types

98−type KindOf (a :: k) = k

99−

100−{- | Deletes value from list.

101−

102−>>> let trMap = delete @Bool $ insert (Identity True) $ one (Identity 'a')

103−>>> size trMap

104−1

105−>>> member @Bool trMap

106−False

107−>>> member @Char trMap

108−True

109−-}

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

111−delete = fromListPairs . deleteByFst (typeFp @a) . toPairList

112−{-# INLINE delete #-}

113−

114−{- | Map over elements.

115−

116−>>> let trMap = insert (Identity True) $ one (Identity 'a')

117−>>> lookup @Bool trMap

118−Just (Identity True)

119−>>> lookup @Char trMap

120−Just (Identity 'a')

121−>>> let trMap2 = hoist ((:[]) . runIdentity) trMap

122−>>> lookup @Bool trMap2

123−Just [True]

124−>>> lookup @Char trMap2

125−Just "a"

126−-}

127−hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g

128−hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ mapArray' (toAny . f . fromAny) ans

129−{-# INLINE hoist #-}

130−

131−-- | The union with a combining function.

132−unionWith :: (forall x. f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f

133−unionWith f m1 m2 = fromListPairs

134− $ Map.toList

135− $ Map.unionWith combine

136− (Map.fromList $ toPairList m1)

137− (Map.fromList $ toPairList m2)

138− where

139− combine :: Any -> Any -> Any

140− combine a b = toAny $ f (fromAny a) (fromAny b)

141−{-# INLINE unionWith #-}

142−

143−-- | The (left-biased) union of two maps. It prefers the first map when

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

145−union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

146−union = unionWith const

147−{-# INLINE union #-}

148−

149−{- | Returns 'True' if there exist value of given type.

150−

151−>>> member @Char $ one (Identity 'a')

152−True

153−>>> member @Bool $ one (Identity 'a')

154−False

155−-}

156−member :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> Bool

157−member trMap = case lookup @a trMap of

158− Nothing -> False

159− Just _ -> True

160−{-# INLINE member #-}

161−

162−{- | Looks up the value at the type.

163−

164−>>> let x = lookup $ insert (Identity (11 :: Int)) empty

165−>>> x :: Maybe (Identity Int)

166−Just (Identity 11)

167−>>> x :: Maybe (Identity ())

168−Nothing

169−-}

170−lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)

171−lookup tVect = fromAny . (anys tVect `indexArray`)

172− <$> cachedBinarySearch (typeFp @a)

173− (fingerprintAs tVect)

174− (fingerprintBs tVect)

175−{-# INLINE lookup #-}

176−

177−-- | Returns the size of the 'TypeRepMap'.

178−size :: TypeRepMap f -> Int

179−size = sizeofPrimArray . fingerprintAs

180−{-# INLINE size #-}

181−

182−-- | Binary searched based on this article

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

184−-- with modification for our two-vector search case.

185−cachedBinarySearch :: Fingerprint -> PrimArray Word64 -> PrimArray Word64 -> Maybe Int

186−cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)

187− where

188− go :: Int# -> Maybe Int

189− go i = case i <# len of

190− 0# -> Nothing

191− _ -> let !(W64# valA) = indexPrimArray fpAs (I# i) in case a `ltWord#` valA of

192− 0# -> case a `eqWord#` valA of

193− 0# -> go (2# *# i +# 2#)

194− _ -> let !(W64# valB) = indexPrimArray fpBs (I# i) in case b `eqWord#` valB of

195− 0# -> case b `ltWord#` valB of

196− 0# -> go (2# *# i +# 2#)

197− _ -> go (2# *# i +# 1#)

198− _ -> Just (I# i)

199− _ -> go (2# *# i +# 1#)

200−

201− len :: Int#

202− len = let !(I# l) = sizeofPrimArray fpAs in l

203−{-# INLINE cachedBinarySearch #-}

204−

205−----------------------------------------------------------------------------

206−-- Internal functions

207−----------------------------------------------------------------------------

208−

209−toAny :: f a -> Any

210−toAny = unsafeCoerce

211−

212−fromAny :: Any -> f a

213−fromAny = unsafeCoerce

214−

215−typeFp :: forall a . Typeable a => Fingerprint

216−typeFp = typeRepFingerprint $ typeRep $ Proxy @a

217−{-# INLINE typeFp #-}

218−

219−toPairList :: TypeRepMap f -> [(Fingerprint, Any)]

220−toPairList trMap = zip (toFps trMap) (GHC.toList $ anys trMap)

221−

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

223−deleteByFst x = filter ((/= x) . fst)

224−

225−nubByFst :: (Eq a) => [(a, b)] -> [(a, b)]

226−nubByFst = nubBy ((==) `on` fst)

227−

228−----------------------------------------------------------------------------

229−-- Functions for testing and benchmarking

230−----------------------------------------------------------------------------

231−

232−-- | Existential wrapper around 'Typeable' indexed by @f@ type parameter.

233−-- Useful for 'TypeRepMap' structure creation form list of 'TF's.

234−data TF f where

235− TF :: Typeable a => f a -> TF f

236−

237−instance Show (TF f) where

238− show (TF tf) = show $ calcFp tf

239−

240−{- | Creates 'TypeRepMap' from a list of 'TF's.

241−

242−>>> size $ fromList [TF $ Identity True, TF $ Identity 'a']

243−2

244−

245−-}

246−fromList :: forall f . [TF f] -> TypeRepMap f

247−fromList = fromListPairs . map (fp &&& an)

248− where

249− fp :: TF f -> Fingerprint

250− fp (TF x) = calcFp x

251−

252− an :: TF f -> Any

253− an (TF x) = toAny x

254−

255−fromF :: Typeable a => f a -> Proxy a

256−fromF _ = Proxy

257−

258−calcFp :: Typeable a => f a -> Fingerprint

259−calcFp = typeRepFingerprint . typeRep . fromF

260−

261−fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f

262−fromListPairs kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans)

263− where

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

265− (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubByFst kvs

266−

267−----------------------------------------------------------------------------

268−-- Tree-like conversion

269−----------------------------------------------------------------------------

270−

271−fromSortedList :: forall a . [a] -> [a]

272−fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)

273− where

274− -- state monad could be used here, but it's another dependency

275− go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)

276− go i first result vector =

277− if i >= IM.size vector

278− then (result, first)

279− else do

280− let (newResult, newFirst) = go (2 * i + 1) first result vector

281− let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult

282− go (2 * i + 2) (newFirst + 1) withCur vector

src/Data/TypeRep/Map.hs+258−1

@@ -1,3 +1,16 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE MagicHash #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE Rank2Types #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeInType #-}

11+

12+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}

13+

1-- | This module introduces the 'TypeRepMap' data structure and functions to work with it.

14-- | This module introduces the 'TypeRepMap' data structure and functions to work with it.

3module Data.TypeRep.Map

16module Data.TypeRep.Map

@@ -23,8 +36,252 @@ module Data.TypeRep.Map

23 -- * Helpful testing functions

36 -- * Helpful testing functions

24 , TF (..)

37 , TF (..)

25 , fromList

38 , fromList

39+ , toFingerprints

26 ) where

40 ) where

28import Prelude hiding (lookup)

42import Prelude hiding (lookup)

30−import Data.TypeRep.CacheMap

44+import Control.Arrow ((&&&))

45+import Data.Function (on)

46+import Data.IntMap.Strict (IntMap)

47+import Data.Kind (Type)

48+import Data.List (nubBy)

49+import Data.Maybe (fromJust)

50+import Data.Primitive.Array (Array, indexArray, mapArray')

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

52+import Data.Proxy (Proxy (..))

53+import Data.Typeable (Typeable, typeRep, typeRepFingerprint)

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

55+import GHC.Exts (inline, sortWith)

56+import GHC.Fingerprint (Fingerprint (..))

57+import GHC.Prim (eqWord#, ltWord#)

58+import GHC.Word (Word64 (..))

59+import Unsafe.Coerce (unsafeCoerce)

60+

61+import qualified Data.IntMap.Strict as IM

62+import qualified Data.Map.Strict as Map

63+import qualified GHC.Exts as GHC (fromList, toList)

64+

65+-- | Map-like data structure that keeps types as keys.

66+data TypeRepMap (f :: k -> Type) = TypeRepMap

67+ { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64)

68+ , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64)

69+ , anys :: {-# UNPACK #-} !(Array Any)

70+ }

71+

72+-- | Shows only 'Fingerprint's.

73+instance Show (TypeRepMap f) where

74+ show = show . toFingerprints

75+

76+-- | Returns the list of 'Fingerprint's from 'TypeRepMap'.

77+toFingerprints :: TypeRepMap f -> [Fingerprint]

78+toFingerprints TypeRepMap{..} =

79+ zipWith Fingerprint (GHC.toList fingerprintAs) (GHC.toList fingerprintBs)

80+

81+

82+-- | Empty structure.

83+empty :: TypeRepMap f

84+empty = TypeRepMap mempty mempty mempty

85+

86+-- | Construct a 'TypeRepMap' with a single element.

87+one :: forall a f . Typeable a => f a -> TypeRepMap f

88+one x = insert x empty

89+{-# INLINE one #-}

90+

91+-- | Inserts the value with its type as a key.

92+insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f

93+insert x = fromListPairs . addX . toPairList

94+ where

95+ pairX :: (Fingerprint, Any)

96+ pairX@(fpX, _) = (calcFp x, toAny x)

97+

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

99+ addX l = pairX : deleteByFst fpX l

100+{-# INLINE insert #-}

101+

102+-- Helper type to workaround some issues with types

103+type KindOf (a :: k) = k

104+

105+{- | Deletes value from list.

106+

107+>>> let trMap = delete @Bool $ insert (Identity True) $ one (Identity 'a')

108+>>> size trMap

109+1

110+>>> member @Bool trMap

111+False

112+>>> member @Char trMap

113+True

114+-}

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

116+delete = fromListPairs . deleteByFst (typeFp @a) . toPairList

117+{-# INLINE delete #-}

118+

119+{- | Map over elements.

120+

121+>>> let trMap = insert (Identity True) $ one (Identity 'a')

122+>>> lookup @Bool trMap

123+Just (Identity True)

124+>>> lookup @Char trMap

125+Just (Identity 'a')

126+>>> let trMap2 = hoist ((:[]) . runIdentity) trMap

127+>>> lookup @Bool trMap2

128+Just [True]

129+>>> lookup @Char trMap2

130+Just "a"

131+-}

132+hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g

133+hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ mapArray' (toAny . f . fromAny) ans

134+{-# INLINE hoist #-}

135+

136+-- | The union with a combining function.

137+unionWith :: (forall x. f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f

138+unionWith f m1 m2 = fromListPairs

139+ $ Map.toList

140+ $ Map.unionWith combine

141+ (Map.fromList $ toPairList m1)

142+ (Map.fromList $ toPairList m2)

143+ where

144+ combine :: Any -> Any -> Any

145+ combine a b = toAny $ f (fromAny a) (fromAny b)

146+{-# INLINE unionWith #-}

147+

148+-- | The (left-biased) union of two maps. It prefers the first map when

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

150+union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

151+union = unionWith const

152+{-# INLINE union #-}

153+

154+{- | Returns 'True' if there exist value of given type.

155+

156+>>> member @Char $ one (Identity 'a')

157+True

158+>>> member @Bool $ one (Identity 'a')

159+False

160+-}

161+member :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> Bool

162+member trMap = case lookup @a trMap of

163+ Nothing -> False

164+ Just _ -> True

165+{-# INLINE member #-}

166+

167+{- | Looks up the value at the type.

168+

169+>>> let x = lookup $ insert (Identity (11 :: Int)) empty

170+>>> x :: Maybe (Identity Int)

171+Just (Identity 11)

172+>>> x :: Maybe (Identity ())

173+Nothing

174+-}

175+lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)

176+lookup tVect = fromAny . (anys tVect `indexArray`)

177+ <$> cachedBinarySearch (typeFp @a)

178+ (fingerprintAs tVect)

179+ (fingerprintBs tVect)

180+{-# INLINE lookup #-}

181+

182+-- | Returns the size of the 'TypeRepMap'.

183+size :: TypeRepMap f -> Int

184+size = sizeofPrimArray . fingerprintAs

185+{-# INLINE size #-}

186+

187+-- | Binary searched based on this article

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

189+-- with modification for our two-vector search case.

190+cachedBinarySearch :: Fingerprint -> PrimArray Word64 -> PrimArray Word64 -> Maybe Int

191+cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)

192+ where

193+ go :: Int# -> Maybe Int

194+ go i = case i <# len of

195+ 0# -> Nothing

196+ _ -> let !(W64# valA) = indexPrimArray fpAs (I# i) in case a `ltWord#` valA of

197+ 0# -> case a `eqWord#` valA of

198+ 0# -> go (2# *# i +# 2#)

199+ _ -> let !(W64# valB) = indexPrimArray fpBs (I# i) in case b `eqWord#` valB of

200+ 0# -> case b `ltWord#` valB of

201+ 0# -> go (2# *# i +# 2#)

202+ _ -> go (2# *# i +# 1#)

203+ _ -> Just (I# i)

204+ _ -> go (2# *# i +# 1#)

205+

206+ len :: Int#

207+ len = let !(I# l) = sizeofPrimArray fpAs in l

208+{-# INLINE cachedBinarySearch #-}

209+

210+----------------------------------------------------------------------------

211+-- Internal functions

212+----------------------------------------------------------------------------

213+

214+toAny :: f a -> Any

215+toAny = unsafeCoerce

216+

217+fromAny :: Any -> f a

218+fromAny = unsafeCoerce

219+

220+typeFp :: forall a . Typeable a => Fingerprint

221+typeFp = typeRepFingerprint $ typeRep $ Proxy @a

222+{-# INLINE typeFp #-}

223+

224+toPairList :: TypeRepMap f -> [(Fingerprint, Any)]

225+toPairList trMap = zip (toFingerprints trMap) (GHC.toList $ anys trMap)

226+

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

228+deleteByFst x = filter ((/= x) . fst)

229+

230+nubByFst :: (Eq a) => [(a, b)] -> [(a, b)]

231+nubByFst = nubBy ((==) `on` fst)

232+

233+----------------------------------------------------------------------------

234+-- Functions for testing and benchmarking

235+----------------------------------------------------------------------------

236+

237+-- | Existential wrapper around 'Typeable' indexed by @f@ type parameter.

238+-- Useful for 'TypeRepMap' structure creation form list of 'TF's.

239+data TF f where

240+ TF :: Typeable a => f a -> TF f

241+

242+instance Show (TF f) where

243+ show (TF tf) = show $ calcFp tf

244+

245+{- | Creates 'TypeRepMap' from a list of 'TF's.

246+

247+>>> size $ fromList [TF $ Identity True, TF $ Identity 'a']

248+2

249+

250+-}

251+fromList :: forall f . [TF f] -> TypeRepMap f

252+fromList = fromListPairs . map (fp &&& an)

253+ where

254+ fp :: TF f -> Fingerprint

255+ fp (TF x) = calcFp x

256+

257+ an :: TF f -> Any

258+ an (TF x) = toAny x

259+

260+fromF :: Typeable a => f a -> Proxy a

261+fromF _ = Proxy

262+

263+calcFp :: Typeable a => f a -> Fingerprint

264+calcFp = typeRepFingerprint . typeRep . fromF

265+

266+fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f

267+fromListPairs kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans)

268+ where

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

270+ (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubByFst kvs

271+

272+----------------------------------------------------------------------------

273+-- Tree-like conversion

274+----------------------------------------------------------------------------

275+

276+fromSortedList :: forall a . [a] -> [a]

277+fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)

278+ where

279+ -- state monad could be used here, but it's another dependency

280+ go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)

281+ go i first result vector =

282+ if i >= IM.size vector

283+ then (result, first)

284+ else do

285+ let (newResult, newFirst) = go (2 * i + 1) first result vector

286+ let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult

287+ go (2 * i + 2) (newFirst + 1) withCur vector

src/Data/TypeRep/TMap.hsnew file+89

@@ -0,0 +1,89 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE Rank2Types #-}

4+-- | This module introduces 'TMap' data type — 'TR.TypeRepMap' parametrized by 'Identity'.

6+module Data.TypeRep.TMap

7+ ( -- * Map type

8+ TMap

10+ -- * Construction

11+ , empty

12+ , one

13+

14+ -- * Modification

15+ , insert

16+ , delete

17+ , hoist

18+ , unionWith

19+ , union

20+

21+ -- * Query

22+ , lookup

23+ , member

24+ , size

25+ ) where

26+

27+import Prelude hiding (lookup)

28+

29+import Data.Functor.Identity (Identity (..))

30+import Data.Typeable (Typeable)

31+import GHC.Exts (coerce)

32+

33+import qualified Data.TypeRep.Map as TR

34+

35+-- | 'TR.TypeRepMap' parametrized by 'Identity'.

36+type TMap = TR.TypeRepMap Identity

37+

38+-- | Similar to 'TR.empty' but for 'TMap'.

39+empty :: TMap

40+empty = TR.empty

41+{-# INLINE empty #-}

42+

43+-- | Similar to 'TR.one' but for 'TMap'.

44+one :: forall a . Typeable a => a -> TMap

45+one x = coerce (TR.one @a @Identity $ coerce x)

46+{-# INLINE one #-}

47+

48+-- | Similar to 'TR.insert' but for 'TMap'.

49+insert :: forall a . Typeable a => a -> TMap -> TMap

50+insert x = coerce (TR.insert @a @Identity $ coerce x)

51+{-# INLINE insert #-}

52+

53+-- | Similar to 'TR.delete' but for 'TMap'.

54+delete :: forall a . Typeable a => TMap -> TMap

55+delete = TR.delete @a @Identity

56+{-# INLINE delete #-}

57+

58+-- | Similar to 'TR.hoist' but for 'TMap'.

59+hoist :: (forall x. x -> g x) -> TMap -> TR.TypeRepMap g

60+hoist f = TR.hoist (f . coerce)

61+{-# INLINE hoist #-}

62+

63+-- | Similar to 'TR.unionWith' but for 'TMap'.

64+unionWith :: (forall x. x -> x -> x) -> TMap -> TMap -> TMap

65+unionWith f = TR.unionWith fId

66+ where

67+ fId :: forall y . Identity y -> Identity y -> Identity y

68+ fId y1 y2 = Identity $ f (coerce y1) (coerce y2)

69+{-# INLINE unionWith #-}

70+

71+-- | Similar to 'TR.union' but for 'TMap'.

72+union :: TMap -> TMap -> TMap

73+union = TR.union

74+{-# INLINE union #-}

75+

76+-- | Similar to 'TR.lookup' but for 'TMap'.

77+lookup :: forall a. Typeable a => TMap -> Maybe a

78+lookup = coerce (TR.lookup @a @Identity)

79+{-# INLINE lookup #-}

80+

81+-- | Similar to 'TR.member' but for 'TMap'.

82+member :: forall a . Typeable a => TMap -> Bool

83+member = TR.member @a @Identity

84+{-# INLINE member #-}

85+

86+-- | Similar to 'TR.size' but for 'TMap'.

87+size :: TMap -> Int

88+size = TR.size

89+{-# INLINE size #-}

test/Test/TypeRep/CacheMap.hs+19−18

@@ -5,43 +5,44 @@ import Prelude hiding (lookup)

5import Data.Functor.Identity (Identity (..))

6import Test.Tasty.Hspec (Spec, describe, it, shouldBe)

8−import Data.TypeRep.CacheMap (TF (..), TypeRepMap, empty, fromList, insert, lookup, size, union)

8+import Data.TypeRep.Map (TF (..), fromList)

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

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

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

11spec_insertLookup :: Spec

12spec_insertLookup :: Spec

12spec_insertLookup = do

13spec_insertLookup = do

13 describe "Lookup Test" $ do

14 describe "Lookup Test" $ do

14 it "returns the inserted element" $

15 it "returns the inserted element" $

15− lookup (fromList [TF $ Identity 'a']) `shouldBe` Just (Identity 'a')

16+ lookup (fromList [TF $ Identity 'a']) `shouldBe` Just 'a'

16 it "returns the second inserted value of the same type" $

17 it "returns the second inserted value of the same type" $

17− lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just (Identity 'b')

18+ lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just 'b'

19 describe "Size Test" $ do

20 describe "Size Test" $ do

20 it "is empty" $

21 it "is empty" $

21 size empty `shouldBe` 0

22 size empty `shouldBe` 0

22 it "is of size 1 when 1 element inserted" $

23 it "is of size 1 when 1 element inserted" $

23− size (insert (Identity 'a') empty) `shouldBe` 1

24+ size (one 'a') `shouldBe` 1

24 it "doesn't increase size when element of the same type is added" $

25 it "doesn't increase size when element of the same type is added" $

25− size (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` 1

26+ size (insert 'b' $ insert 'a' empty) `shouldBe` 1

26 it "returns 10 when 10 different types are inserted" $

27 it "returns 10 when 10 different types are inserted" $

27 size mapOf10 `shouldBe` 10

28 size mapOf10 `shouldBe` 10

29 describe "Union test" $ do

30 describe "Union test" $ do

30 let m = fromList [TF $ Identity 'a', TF $ Identity True] `union` fromList [TF $ Identity 'b']

31 let m = fromList [TF $ Identity 'a', TF $ Identity True] `union` fromList [TF $ Identity 'b']

31 it "lookup works on union as expected" $ do

32 it "lookup works on union as expected" $ do

32− lookup m `shouldBe` Just (Identity 'a')

33+ lookup m `shouldBe` Just 'a'

33− lookup m `shouldBe` Just (Identity True)

34+ lookup m `shouldBe` Just True

34 lookup @Int m `shouldBe` Nothing

35 lookup @Int m `shouldBe` Nothing

37−mapOf10 :: TypeRepMap Identity

38+mapOf10 :: TMap

38−mapOf10 = insert (Identity True)

39+mapOf10 = insert True

39− $ insert (Identity [True, False])

40+ $ insert [True, False]

40− $ insert (Identity $ Just True)

41+ $ insert (Just True)

41− $ insert (Identity $ Just ())

42+ $ insert (Just ())

42− $ insert (Identity [()])

43+ $ insert [()]

43− $ insert (Identity ())

44+ $ insert ()

44− $ insert (Identity "aaa")

45+ $ insert "aaa"

45− $ insert (Identity $ Just 'a')

46+ $ insert (Just 'a')

46− $ insert (Identity 'a')

47+ $ insert 'a'

47− $ insert (Identity (11 :: Int)) empty

48+ $ insert (11 :: Int) empty

test/Test/TypeRep/MapProperty.hs+1−1

@@ -15,7 +15,7 @@ import Hedgehog (MonadGen, PropertyT, forAll, property, (===))

15import Test.Tasty (TestName, TestTree)

16import Test.Tasty.Hedgehog (testProperty)

18−import Data.TypeRep.CacheMap (TF (..), TypeRepMap, delete, fromList, insert, lookup, member)

18+import Data.TypeRep.Map (TF (..), TypeRepMap, delete, fromList, insert, lookup, member)

20import qualified Hedgehog.Gen as Gen

21import qualified Hedgehog.Range as Range

internal/Data/TypeRep/CMap.hs → typerep-extra-impls/Data/TypeRep/CMap.hsrenamed

The content is the same.

internal/Data/TypeRep/OptimalVector.hs → typerep-extra-impls/Data/TypeRep/OptimalVector.hsrenamed

The content is the same.

internal/Data/TypeRep/Vector.hs → typerep-extra-impls/Data/TypeRep/Vector.hsrenamed

The content is the same.

typerep-map.cabal+9−8

@@ -24,26 +24,26 @@ source-repository head

24library

25 hs-source-dirs: src

26 exposed-modules: Data.TypeRep.Map

27+ Data.TypeRep.TMap

27 ghc-options: -Wall

28 ghc-options: -Wall

28 build-depends: base

29 build-depends: base

29− , typerep-map-internal

30+ , containers

31+ , ghc-prim

32+ , primitive

30 default-extensions: OverloadedStrings

33 default-extensions: OverloadedStrings

31 RecordWildCards

34 RecordWildCards

32 ScopedTypeVariables

35 ScopedTypeVariables

33 TypeApplications

36 TypeApplications

34 default-language: Haskell2010

37 default-language: Haskell2010

36−library typerep-map-internal

39+library typerep-extra-impls

37− hs-source-dirs: internal

40+ hs-source-dirs: typerep-extra-impls

38 exposed-modules: Data.TypeRep.CMap

41 exposed-modules: Data.TypeRep.CMap

39− Data.TypeRep.CacheMap

40 Data.TypeRep.OptimalVector

42 Data.TypeRep.OptimalVector

41 Data.TypeRep.Vector

43 Data.TypeRep.Vector

42 ghc-options: -Wall

44 ghc-options: -Wall

43 build-depends: base

45 build-depends: base

44 , containers

46 , containers

45− , ghc-prim

46− , primitive

47 , vector

48 default-extensions: OverloadedStrings

49 RecordWildCards

@@ -65,7 +65,7 @@ test-suite typerep-map-test

65 , ghc-typelits-knownnat

66 , hedgehog

67 , typerep-map

68− , typerep-map-internal

68+ , typerep-extra-impls

69 , tasty

70 , tasty-discover >= 4.1.1

71 , tasty-hedgehog

@@ -93,7 +93,8 @@ benchmark typerep-map-benchmark

93 , dependent-map

94 , dependent-sum

95 , ghc-typelits-knownnat

96− , typerep-map-internal

96+ , typerep-map

97+ , typerep-extra-impls

97 default-extensions: OverloadedStrings

98 default-extensions: OverloadedStrings

98 RecordWildCards

99 RecordWildCards

99 ScopedTypeVariables

100 ScopedTypeVariables