5ad2178 · typerep-map · git.iko.soy

.travis.yml+2−1

compare with main

unifiedsplit

@@ -49,7 +49,7 @@ matrix:

49 - cabal-install-head

50

51 - ghc: 8.4.3

52− env: STACK_YAML="$HOME/build/vrom911/typerep-map/stack.yaml"

52+ env: STACK_YAML="$HOME/build/kowainik/typerep-map/stack.yaml"

53 os: linux

54 addons:

55 apt:

@@ -64,6 +64,7 @@ install:

64 cabal new-update

65 cabal new-build --enable-tests --enable-benchmarks

66 else

67+ echo "$TRAVIS_BUILD_DIR"

67 mkdir -p ~/.local/bin

68 mkdir -p ~/.local/bin

68 export PATH="$HOME/.local/bin:$PATH"

69 export PATH="$HOME/.local/bin:$PATH"

69 travis_retry curl -L 'https://www.stackage.org/stack/linux-x86_64' | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

70 travis_retry curl -L 'https://www.stackage.org/stack/linux-x86_64' | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

benchmark/Map.hs+1−1

@@ -26,7 +26,7 @@ import Data.Proxy (Proxy (..))

26import Data.Typeable (Typeable)

27import GHC.TypeLits

28

29−import Data.TypeRep.Map (TypeRepMap (..), empty, insert, keys, lookup)

29+import Data.TypeRep.CMap (TypeRepMap (..), empty, insert, keys, lookup)

30

31benchMap :: Benchmark

32benchMap = bgroup "map"

benchmark/OptimalVector.hs+4−4

@@ -25,7 +25,7 @@ import Data.Proxy (Proxy (..))

25import Data.Typeable (Typeable)

26import GHC.TypeLits

27

28−import Data.TypeRep.OptimalVector

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

29

30benchVectorOpt :: Benchmark

31benchVectorOpt = bgroup "vector optimal"

@@ -34,7 +34,7 @@ benchVectorOpt = bgroup "vector optimal"

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

35 ]

36

37−tenLookups :: TypeRepVector (Proxy :: Nat -> *)

37+tenLookups :: TypeRepMap (Proxy :: Nat -> *)

38 -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40

39 , Proxy 50, Proxy 60, Proxy 70, Proxy 80

40 )

@@ -44,14 +44,14 @@ tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)

44 lp = fromJust $ lookup tmap

45

46-- TypeRepMap of 10000 elements

47−bigMap :: TypeRepVector (Proxy :: Nat -> *)

47+bigMap :: TypeRepMap (Proxy :: Nat -> *)

48bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []

49

50buildBigMap :: forall a . (KnownNat a) => Int -> Proxy (a :: Nat) -> [TF (Proxy :: Nat -> *)] -> [TF (Proxy :: Nat -> *)]

51buildBigMap 1 x = (TF x :)

52buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))

53

54−rknf :: TypeRepVector f -> ()

54+rknf :: TypeRepMap f -> ()

55rknf tVect = rnf (fingerprintAs tVect, fingerprintBs tVect)

56

57prepareBenchVectorOpt :: IO ()

src/Data/TypeRep/CMap.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# LANGUAGE ExplicitForAll #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+

6+module Data.TypeRep.CMap

7+ ( TypeRepMap (..)

8+ , empty

9+ , insert

10+ , keys

11+ , lookup

12+ , size

13+ ) where

14+

15+import Prelude hiding (lookup)

16+

17+import Data.Proxy (Proxy (..))

18+import Data.Typeable (TypeRep, Typeable, typeRep)

19+import GHC.Base (Any)

20+import Unsafe.Coerce (unsafeCoerce)

21+

22+import qualified Data.Map.Lazy as LMap

23+

24+-- | Map-like data structure with types served as the keys.

25+newtype TypeRepMap (f :: k -> *) = TypeRepMap

26+ { unMap :: LMap.Map TypeRep Any

27+ }

28+

29+-- | Empty structure.

30+empty :: TypeRepMap f

31+empty = TypeRepMap mempty

32+

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

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

35+insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce val) . unMap

36+

37+-- | Looks up the value at the type.

38+-- >>> let x = lookup $ insert (11 :: Int) empty

39+-- >>> x :: Maybe Int

40+-- Just 11

41+-- >>> x :: Maybe ()

42+-- Nothing

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

44+lookup = fmap unsafeCoerce . LMap.lookup (typeRep (Proxy :: Proxy a)) . unMap

45+

46+size :: TypeRepMap f -> Int

47+size = LMap.size . unMap

48+

49+keys :: TypeRepMap f -> [TypeRep]

50+keys = LMap.keys . unMap

src/Data/TypeRep/Map.hs+86−16

@@ -1,38 +1,58 @@

1−{-# LANGUAGE ExplicitForAll #-}

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE GADTs #-}

2{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE MagicHash #-}

3{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE PolyKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeFamilies #-}

5

9

6module Data.TypeRep.Map

10module Data.TypeRep.Map

11+ ( -- * Map type

7− ( TypeRepMap (..)

12+ TypeRepMap (..)

13+

14+ -- 'TypeRepMap' interface

8 , empty

15 , empty

9 , insert

16 , insert

10− , keys

11 , lookup

17 , lookup

12 , size

18 , size

19+

20+ -- * Helpful testing functions

21+ , TF (..)

22+ , fromList

13 ) where

23 ) where

14

24

15import Prelude hiding (lookup)

25import Prelude hiding (lookup)

16

26

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

28+import Data.Kind (Type)

17import Data.Proxy (Proxy (..))

29import Data.Proxy (Proxy (..))

18−import Data.Typeable (TypeRep, Typeable, typeRep)

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

31+import Data.Word (Word64)

19−import GHC.Base (Any)

32+import GHC.Base (Any, Int (..), Int#, uncheckedIShiftRA#, (+#), (-#), (<#))

33+import GHC.Exts (inline, sortWith)

34+import GHC.Fingerprint (Fingerprint (..))

20import Unsafe.Coerce (unsafeCoerce)

35import Unsafe.Coerce (unsafeCoerce)

21

36

22−import qualified Data.Map.Lazy as LMap

37+import qualified Data.Vector as V

38+import qualified Data.Vector.Unboxed as Unboxed

23

39

24−-- | Map-like data structure with types served as the keys.

25−newtype TypeRepMap (f :: k -> *) = TypeRepMap

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

26− { unMap :: LMap.Map TypeRep Any

41+ { fingerprintAs :: Unboxed.Vector Word64

42+ , fingerprintBs :: Unboxed.Vector Word64

43+ , anys :: V.Vector Any

27 }

44 }

28

45

46+fromAny :: Any -> f a

47+fromAny = unsafeCoerce

48+

29-- | Empty structure.

49-- | Empty structure.

30empty :: TypeRepMap f

50empty :: TypeRepMap f

31−empty = TypeRepMap mempty

51+empty = TypeRepMap mempty mempty mempty

32

52

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

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

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

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

35−insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce val) . unMap

55+insert = undefined

36

56

37-- | Looks up the value at the type.

57-- | Looks up the value at the type.

38-- >>> let x = lookup $ insert (11 :: Int) empty

58-- >>> let x = lookup $ insert (11 :: Int) empty

@@ -41,10 +61,60 @@ insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce

41-- >>> x :: Maybe ()

61-- >>> x :: Maybe ()

42-- Nothing

62-- Nothing

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

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

44−lookup = fmap unsafeCoerce . LMap.lookup (typeRep (Proxy :: Proxy a)) . unMap

64+lookup tVect = fromAny . (anys tVect V.!)

65+ <$> binarySearch (typeRepFingerprint $ typeRep $ Proxy @a)

66+ (fingerprintAs tVect)

67+ (fingerprintBs tVect)

45

68

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

46size :: TypeRepMap f -> Int

70size :: TypeRepMap f -> Int

47−size = LMap.size . unMap

71+size = Unboxed.length . fingerprintAs

72+

73+-- | Returns the index is found.

74+binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int

75+binarySearch (Fingerprint a b) fpAs fpBs =

76+ let

77+ !(I# len) = Unboxed.length fpAs

78+ checkfpBs :: Int# -> Maybe Int

79+ checkfpBs i =

80+ case i <# len of

81+ 0# -> Nothing

82+ _ ->

83+ if a /= Unboxed.unsafeIndex fpAs (I# i)

84+ then Nothing

85+ else if b == Unboxed.unsafeIndex fpBs (I# i)

86+ then Just (I# i)

87+ else checkfpBs (i +# 1#)

88+ in

89+ inline (checkfpBs (binSearchHelp (-1#) len))

90+ where

91+ binSearchHelp :: Int# -> Int# -> Int#

92+ binSearchHelp l r = case l <# (r -# 1#) of

93+ 0# -> r

94+ _ ->

95+ let m = uncheckedIShiftRA# (l +# r) 1# in

96+ if Unboxed.unsafeIndex fpAs (I# m) < a

97+ then binSearchHelp m r

98+ else binSearchHelp l m

99+

100+----------------------------------------------------------------------------

101+-- Functions for testing and benchmarking

102+----------------------------------------------------------------------------

103+

104+data TF f where

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

106+

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

108+fromF _ = Proxy

109+

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

111+fromList tfs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)

112+ where

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

114+ (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs

115+

116+ fp :: TF f -> Fingerprint

117+ fp (TF x) = typeRepFingerprint $ typeRep $ fromF x

48

118

49−keys :: TypeRepMap f -> [TypeRep]

119+ an :: TF f -> Any

50−keys = LMap.keys . unMap

120+ an (TF x) = unsafeCoerce x

src/Data/TypeRep/OptimalVector.hsdeleted−114

@@ -1,114 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−

3−{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE ExplicitForAll #-}

5−{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE KindSignatures #-}

7−{-# LANGUAGE MagicHash #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−

13−

14−module Data.TypeRep.OptimalVector

15− ( TypeRepVector (..)

16− , TF (..)

17− , empty

18− , insert

19− , lookup

20− , size

21− , fromList

22− ) where

23−

24−import Prelude hiding (lookup)

25−

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

27−import Data.Proxy (Proxy (..))

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

29−import Data.Word (Word64)

30−import GHC.Base hiding (empty)

31−import GHC.Exts (sortWith)

32−import GHC.Fingerprint (Fingerprint (..))

33−import Unsafe.Coerce (unsafeCoerce)

34−import Debug.Trace

35−

36−import qualified Data.Vector as V

37−import qualified Data.Vector.Unboxed as Unboxed

38−

39−data TypeRepVector f = TypeRepVect

40− { fingerprintAs :: Unboxed.Vector Word64

41− , fingerprintBs :: Unboxed.Vector Word64

42− , anys :: V.Vector Any

43− }

44−

45−fromAny :: Any -> f a

46−fromAny = unsafeCoerce

47−

48−-- | Empty structure.

49−empty :: TypeRepVector f

50−empty = TypeRepVect mempty mempty mempty

51−

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

53−insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f

54−insert = undefined

55−

56−-- | Looks up the value at the type.

57−-- >>> let x = lookup $ insert (11 :: Int) empty

58−-- >>> x :: Maybe Int

59−-- Just 11

60−-- >>> x :: Maybe ()

61−-- Nothing

62−lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)

63−lookup tVect = fromAny . (anys tVect V.!)

64− <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprintAs tVect) (fingerprintBs tVect)

65−

66−-- | Returns the size of the 'TypeRepVect'.

67−size :: TypeRepVector f -> Int

68−size = Unboxed.length . fingerprintAs

69−

70−data TF f where

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

72−

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

74−fromF _ = Proxy

75−

76−fromList :: forall f . [TF f] -> TypeRepVector f

77−fromList tfs = TypeRepVect (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)

78− where

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

80− (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs

81−

82− fp :: TF f -> Fingerprint

83− fp (TF x) = typeRepFingerprint $ typeRep $ fromF x

84−

85− an :: TF f -> Any

86− an (TF x) = unsafeCoerce x

87−

88−-- | Returns the index is found.

89−binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int

90−binarySearch (Fingerprint a b) fpAs fpBs =

91− let

92− !(I# len) = Unboxed.length fpAs

93− checkfpBs :: Int# -> Maybe Int

94− checkfpBs i =

95− case i <# len of

96− 0# -> Nothing

97− _ ->

98− if a /= Unboxed.unsafeIndex fpAs (I# i)

99− then Nothing

100− else if b == Unboxed.unsafeIndex fpBs (I# i)

101− then Just (I# i)

102− else checkfpBs (i +# 1#)

103− in

104− inline (checkfpBs (binSearchHelp (-1#) len))

105− where

106− binSearchHelp :: Int# -> Int# -> Int#

107− binSearchHelp l r = case l <# (r -# 1#) of

108− 0# -> r

109− _ ->

110− let m = uncheckedIShiftRA# (l +# r) 1# in

111− if Unboxed.unsafeIndex fpAs (I# m) < a

112− then binSearchHelp m r

113− else binSearchHelp l m

114−

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

@@ -6,7 +6,7 @@ import Data.Functor.Identity (Identity (..))

6

7import Test.Tasty.Hspec

8

9−import Data.TypeRep.Map

9+import Data.TypeRep.CMap

10

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

12spec_insertLookup :: Spec

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

@@ -6,7 +6,7 @@ import Data.Functor.Identity (Identity (..))

6

7import Test.Tasty.Hspec

8

9−import Data.TypeRep.OptimalVector

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

10

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

12insertLookup :: Spec

typerep-map.cabal+6−5

@@ -18,9 +18,10 @@ tested-with: GHC == 8.0.2

18

19library

20 hs-source-dirs: src

21− exposed-modules: Data.TypeRep.Map

21+ exposed-modules: Data.TypeRep.CMap

22+ Data.TypeRep.Map

22− , Data.TypeRep.Vector

23+ Data.TypeRep.Vector

23− , Data.TypeRep.OptimalVector

24+

24 ghc-options: -Wall

25 ghc-options: -Wall

25 build-depends: base

26 build-depends: base

26 , containers

27 , containers

@@ -41,13 +42,13 @@ test-suite typerep-map-test

41 , tasty-discover >= 4.1.1

42 , tasty-discover >= 4.1.1

42 , tasty-hspec

43 , tasty-hspec

43 build-tool-depends: tasty-discover:tasty-discover

44 build-tool-depends: tasty-discover:tasty-discover

44− ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N

45+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N

45 default-language: Haskell2010

46 default-language: Haskell2010

46

47

47benchmark typerep-map-benchmark

48benchmark typerep-map-benchmark

48 type: exitcode-stdio-1.0

49 type: exitcode-stdio-1.0

49 default-language: Haskell2010

50 default-language: Haskell2010

50− ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0

51+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0

51 hs-source-dirs: benchmark

52 hs-source-dirs: benchmark

52 main-is: Main.hs

53 main-is: Main.hs

53 other-modules: Map

54 other-modules: Map