cbcbb07 · typerep-map · git.iko.soy

git.iko.soy/typerep-map

[#17] Add more map-like functions (#19)

cbcbb07Dmitrii Kovanikov8 years ago

README.md+9−1

@@ -9,7 +9,7 @@

9`typerep-map` introduces `TypeRepMap` — data structure like [`Map`](http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#t:Map), but where types serve as keys, and values have the types specified in the corresponding key spots.

11```haskell

12−ghci> let typeRepMap = insert (Identity True) $ insert (Identity (42 :: Int)) empty

12+ghci> let typeRepMap = insert (Identity True) $ one (Identity (42 :: Int))

14ghci> size typeRepMap

152

@@ -27,4 +27,12 @@ Nothing

28ghci> lookup (insert (Identity "hello") typeRepMap) :: Maybe (Identity String)

29Just (Identity "hello")

30+

31+ghci> member @Int typeRepMap

32+True

33+

34+ghci> let trMap = delete @Int typeRepMap

35+

36+ghci> member @Int trMap

37+False

30```

38```

internal/Data/TypeRep/CacheMap.hs+67−19

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

1−{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE MagicHash #-}

6+{-# LANGUAGE MagicHash #-}

6−{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE TypeInType #-}

7−{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeFamilies #-}

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

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

@@ -14,8 +15,11 @@ module Data.TypeRep.CacheMap

15 -- 'TypeRepMap' interface

16 -- 'TypeRepMap' interface

16 , empty

17 , empty

18+ , one

17 , insert

19 , insert

20+ , delete

18 , lookup

21 , lookup

22+ , member

19 , size

23 , size

21 -- * Helpful testing functions

25 -- * Helpful testing functions

@@ -34,7 +38,6 @@ import Data.List (nubBy)

34import Data.Maybe (fromJust)

38import Data.Maybe (fromJust)

35import Data.Proxy (Proxy (..))

39import Data.Proxy (Proxy (..))

36import Data.Typeable (Typeable, typeRep, typeRepFingerprint)

40import Data.Typeable (Typeable, typeRep, typeRepFingerprint)

37−import Data.Word (Word64)

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

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

39import GHC.Exts (inline, sortWith)

42import GHC.Exts (inline, sortWith)

40import GHC.Fingerprint (Fingerprint (..))

43import GHC.Fingerprint (Fingerprint (..))

@@ -57,7 +60,7 @@ data TypeRepMap (f :: k -> Type) = TypeRepMap

57instance Show (TypeRepMap f) where

60instance Show (TypeRepMap f) where

58 show = show . toFps

61 show = show . toFps

60−-- | Returnes the list of 'Fingerprint's from 'TypeRepMap'.

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

61toFps :: TypeRepMap f -> [Fingerprint]

64toFps :: TypeRepMap f -> [Fingerprint]

62toFps TypeRepMap{..} = zipWith Fingerprint

65toFps TypeRepMap{..} = zipWith Fingerprint

63 (Unboxed.toList fingerprintAs)

66 (Unboxed.toList fingerprintAs)

@@ -70,20 +73,52 @@ fromAny = unsafeCoerce

70empty :: TypeRepMap f

73empty :: TypeRepMap f

71empty = TypeRepMap mempty mempty mempty

74empty = TypeRepMap mempty mempty mempty

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

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

78+one x = insert x empty

79+{-# INLINE one #-}

80+

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

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

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

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

75insert x = fromListPairs . addX . toPairList

83insert x = fromListPairs . addX . toPairList

76 where

84 where

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

78− toPairList trMap = zip (toFps trMap) (V.toList $ anys trMap)

79−

80 pairX :: (Fingerprint, Any)

85 pairX :: (Fingerprint, Any)

81 pairX@(fpX, _) = (calcFp x, unsafeCoerce x)

86 pairX@(fpX, _) = (calcFp x, unsafeCoerce x)

83 addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]

88 addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]

84− addX l = pairX : filter ((/= fpX) . fst) l

89+ addX l = pairX : deleteByFst fpX l

85{-# INLINE insert #-}

90{-# INLINE insert #-}

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

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

94+

95+{- | Deletes value from list.

96+

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

98+>>> size trMap

99+1

100+>>> member @Bool trMap

101+False

102+>>> member @Char trMap

103+True

104+-}

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

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

107+{-# INLINE delete #-}

108+

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

110+

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

112+True

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

114+False

115+-}

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

117+member trMap = case lookup @a trMap of

118+ Nothing -> False

119+ Just _ -> True

120+{-# INLINE member #-}

121+

87{- | Looks up the value at the type.

122{- | Looks up the value at the type.

123

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

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

@@ -91,11 +126,10 @@ insert x = fromListPairs . addX . toPairList

91Just (Identity 11)

126Just (Identity 11)

92>>> x :: Maybe (Identity ())

127>>> x :: Maybe (Identity ())

93Nothing

128Nothing

94−

95-}

129-}

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

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

97lookup tVect = fromAny . (anys tVect V.!)

131lookup tVect = fromAny . (anys tVect V.!)

98− <$> cachedBinarySearch (typeRepFingerprint $ typeRep $ Proxy @a)

132+ <$> cachedBinarySearch (typeFp @a)

99 (fingerprintAs tVect)

133 (fingerprintAs tVect)

100 (fingerprintBs tVect)

134 (fingerprintBs tVect)

101{-# INLINE lookup #-}

135{-# INLINE lookup #-}

@@ -128,6 +162,23 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)

128 len = let !(I# l) = Unboxed.length fpAs in l

162 len = let !(I# l) = Unboxed.length fpAs in l

129{-# INLINE cachedBinarySearch #-}

163{-# INLINE cachedBinarySearch #-}

130

164

165+----------------------------------------------------------------------------

166+-- Internal functions

167+----------------------------------------------------------------------------

168+

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

170+typeFp = typeRepFingerprint $ typeRep $ Proxy @a

171+{-# INLINE typeFp #-}

172+

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

174+toPairList trMap = zip (toFps trMap) (V.toList $ anys trMap)

175+

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

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

178+

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

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

181+

131----------------------------------------------------------------------------

182----------------------------------------------------------------------------

132-- Functions for testing and benchmarking

183-- Functions for testing and benchmarking

133----------------------------------------------------------------------------

184----------------------------------------------------------------------------

@@ -165,10 +216,7 @@ fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f

165fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)

216fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)

166 where

217 where

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

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

168− (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubPairs kvs

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

169−

170−nubPairs :: (Eq a) => [(a, b)] -> [(a, b)]

171−nubPairs = nubBy ((==) `on` fst)

172

220

173----------------------------------------------------------------------------

221----------------------------------------------------------------------------

174-- Tree-like conversion

222-- Tree-like conversion

src/Data/TypeRep/Map.hs+3

@@ -6,8 +6,11 @@ module Data.TypeRep.Map

7 -- 'TypeRepMap' interface

8 , empty

9+ , one

9 , insert

10 , insert

11+ , delete

10 , lookup

12 , lookup

13+ , member

11 , size

14 , size

13 -- * Helpful testing functions

16 -- * Helpful testing functions

test/Test/TypeRep/MapProperty.hs+11−3

@@ -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, fromList, insert, lookup)

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

20import qualified Hedgehog.Gen as Gen

21import qualified Hedgehog.Range as Range

@@ -39,6 +39,16 @@ test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do

39 let b = IntProxy proxy (i + 1)

40 lookup @n @IntProxy (insert b $ insert a m) === Just b

42+test_DeleteMember :: PropertyTest

43+test_DeleteMember = prop "member k . delete k == False" $ do

44+ m <- forAll genMap

45+ TF (proxy :: IntProxy n) <- forAll genTF

46+ shouldInsert <- forAll Gen.bool

47+

48+ if shouldInsert then

49+ member @n (delete @n $ insert proxy m) === False

50+ else

51+ member @n (delete @n m) === False

43----------------------------------------------------------------------------

53----------------------------------------------------------------------------

44-- Generators

54-- Generators

@@ -47,11 +57,9 @@ test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do

47data IntProxy (n :: Nat) = IntProxy (Proxy n) Int

57data IntProxy (n :: Nat) = IntProxy (Proxy n) Int

48 deriving (Show, Eq)

58 deriving (Show, Eq)

50−

51genMap :: MonadGen m => m (TypeRepMap IntProxy)

60genMap :: MonadGen m => m (TypeRepMap IntProxy)

52genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF

61genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF

54−

55genTF :: MonadGen m => m (TF IntProxy)

63genTF :: MonadGen m => m (TF IntProxy)

56genTF = do

64genTF = do

57 randNat :: Integer <- Gen.integral (Range.linear 0 10000)

65 randNat :: Integer <- Gen.integral (Range.linear 0 10000)

typerep-map.cabal+13−12

@@ -1,14 +1,15 @@

1name: typerep-map

2−version: 0.1.0.0

2+version: 1.0

3−description: Efficient implementation of data type with types as keys

3+synopsis: Efficient implementation of data type with types as keys

4+description: See README.md for more details.

4−homepage: https://github.com/vrom911/typerep-map

5+homepage: https://github.com/kowainik/typerep-map

5−bug-reports: https://github.com/vrom911/typerep-map/issues

6+bug-reports: https://github.com/kowainik/typerep-map/issues

6license: MIT

7license: MIT

7license-file: LICENSE

8license-file: LICENSE

8−author: Veronika Romashkina

9+author: Kowainik, Vladislav Zavialov

9−maintainer: vrom911@gmail.com

10+maintainer: xrom.xkov@gmail.com

10−copyright: 2017 Veronika Romashkina

11+copyright: 2017-2018 Kowainik

11−category: Data Structures

12+category: Data, Data Structures, Types

12build-type: Simple

13build-type: Simple

13extra-source-files: README.md

14extra-source-files: README.md

14cabal-version: 2.0

15cabal-version: 2.0

@@ -16,6 +17,10 @@ tested-with: GHC == 8.0.2

16 , GHC == 8.2.2

17 , GHC == 8.2.2

17 , GHC == 8.4.3

18 , GHC == 8.4.3

20+source-repository head

21+ type: git

22+ location: https://github.com/kowainik/typerep-map.git

23+

19library

24library

20 hs-source-dirs: src

25 hs-source-dirs: src

21 exposed-modules: Data.TypeRep.Map

26 exposed-modules: Data.TypeRep.Map

@@ -94,7 +99,3 @@ benchmark typerep-map-benchmark

94 TypeApplications

99 TypeApplications

95 if impl(ghc >= 8.2.2)

100 if impl(ghc >= 8.2.2)

96 other-modules: DMap

101 other-modules: DMap

97−

98−source-repository head

99− type: git

100− location: https://github.com/vrom911/typerep-map.git