dccb742 · typerep-map · git.iko.soy

git.iko.soy/typerep-map

on main help sign in

[#31] Add Semigroup and Monoid instances (#34)

dccb742Dmitrii Kovanikov8 years ago

.travis.yml+1−1

compare with main

unifiedsplit

@@ -9,7 +9,7 @@ cache:

9 - "$HOME/.cabal"

10 - "$HOME/.ghc"

11 - "$HOME/.stack"

12− - ".stack-work"

12+ - "$HOME/build/kowainik/typerep-map/.stack-work"

14matrix:

CHANGELOG.md+6−4

@@ -1,10 +1,12 @@

1Change log

2==========

4−typerep-map uses [PVP Versioning][1].

4+`typerep-map` uses [PVP Versioning][1].

5The change log is available [on GitHub][2].

7−[1]: https://pvp.haskell.org

8−[2]: https://github.com/vrom911/typerep-map/releases

9−# 0.1.0.0

7+# 0.1.0

10* Initially created.

9* Initially created.

10+

11+[1]: https://pvp.haskell.org

12+[2]: https://github.com/kowainik/typerep-map/blob/master/CHANGELOG.md

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

@@ -2,6 +2,7 @@

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE InstanceSigs #-}

5{-# LANGUAGE KindSignatures #-}

6{-# LANGUAGE KindSignatures #-}

6{-# LANGUAGE MagicHash #-}

7{-# LANGUAGE MagicHash #-}

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

@@ -50,6 +51,7 @@ import Data.Maybe (fromJust)

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

51import Data.Primitive.Array (Array, indexArray, mapArray')

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

52import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)

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

53import Data.Proxy (Proxy (..))

54+import Data.Semigroup (Semigroup (..))

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

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

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

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

55import GHC.Exts (inline, sortWith)

57import GHC.Exts (inline, sortWith)

@@ -73,15 +75,27 @@ data TypeRepMap (f :: k -> Type) = TypeRepMap

73instance Show (TypeRepMap f) where

75instance Show (TypeRepMap f) where

74 show = show . toFingerprints

76 show = show . toFingerprints

78+-- | Uses 'union' to combine 'TypeRepMap's.

79+instance Semigroup (TypeRepMap f) where

80+ (<>) :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f

81+ (<>) = union

82+ {-# INLINE (<>) #-}

83+

84+instance Monoid (TypeRepMap f) where

85+ mempty = TypeRepMap mempty mempty mempty

86+ mappend = (<>)

87+ {-# INLINE mempty #-}

88+ {-# INLINE mappend #-}

89+

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

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

77toFingerprints :: TypeRepMap f -> [Fingerprint]

91toFingerprints :: TypeRepMap f -> [Fingerprint]

78toFingerprints TypeRepMap{..} =

92toFingerprints TypeRepMap{..} =

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

93 zipWith Fingerprint (GHC.toList fingerprintAs) (GHC.toList fingerprintBs)

81−

82-- | Empty structure.

95-- | Empty structure.

83empty :: TypeRepMap f

96empty :: TypeRepMap f

84−empty = TypeRepMap mempty mempty mempty

97+empty = mempty

98+{-# INLINE empty #-}

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

100-- | Construct a 'TypeRepMap' with a single element.

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

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

test/Test/TypeRep/MapProperty.hs+44−4

@@ -1,6 +1,7 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE KindSignatures #-}

3−{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE PolyKinds #-}

5{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

6{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

@@ -9,22 +10,31 @@ module Test.TypeRep.MapProperty where

9import Prelude hiding (lookup)

10import Prelude hiding (lookup)

11import Data.Proxy (Proxy (..))

12import Data.Proxy (Proxy (..))

13+import Data.Semigroup (Semigroup (..))

12import GHC.Stack (HasCallStack)

14import GHC.Stack (HasCallStack)

13import GHC.TypeLits (Nat, SomeNat (..), someNatVal)

15import GHC.TypeLits (Nat, SomeNat (..), someNatVal)

14import Hedgehog (MonadGen, PropertyT, forAll, property, (===))

16import Hedgehog (MonadGen, PropertyT, forAll, property, (===))

15import Test.Tasty (TestName, TestTree)

17import Test.Tasty (TestName, TestTree)

16import Test.Tasty.Hedgehog (testProperty)

18import Test.Tasty.Hedgehog (testProperty)

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

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

20import qualified Hedgehog.Gen as Gen

22import qualified Hedgehog.Gen as Gen

21import qualified Hedgehog.Range as Range

23import qualified Hedgehog.Range as Range

25+----------------------------------------------------------------------------

26+-- Common utils

27+----------------------------------------------------------------------------

28+

23type PropertyTest = [TestTree]

29type PropertyTest = [TestTree]

25prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest

31prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest

26prop testName = pure . testProperty testName . property

32prop testName = pure . testProperty testName . property

34+----------------------------------------------------------------------------

35+-- Map modification properties

36+----------------------------------------------------------------------------

37+

28test_InsertLookup :: PropertyTest

38test_InsertLookup :: PropertyTest

29test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do

39test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do

30 m <- forAll genMap

40 m <- forAll genMap

@@ -50,6 +60,36 @@ test_DeleteMember = prop "member k . delete k == False" $ do

50 else

60 else

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

61 member @n (delete @n m) === False

63+----------------------------------------------------------------------------

64+-- Semigroup and Monoid laws

65+----------------------------------------------------------------------------

66+

67+-- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's

68+-- not a good idea to write such `Eq` instance for `TypeRepMap` itself because

69+-- it doesn't compare values so it's not true equality. But this should be

70+-- enough for tests.

71+newtype FpMap f = FpMap (TypeRepMap f)

72+ deriving (Show, Semigroup, Monoid)

73+

74+instance Eq (FpMap f) where

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

76+ as1 == as2 && bs1 == bs2

77+

78+test_SemigroupAssoc :: PropertyTest

79+test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do

80+ x <- FpMap <$> forAll genMap

81+ y <- FpMap <$> forAll genMap

82+ z <- FpMap <$> forAll genMap

83+

84+ (x <> (y <> z)) === ((x <> y) <> z)

85+

86+test_MonoidIdentity :: PropertyTest

87+test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do

88+ x <- FpMap <$> forAll genMap

89+

90+ x <> mempty === x

91+ mempty <> x === x

92+

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

93----------------------------------------------------------------------------

54-- Generators

94-- Generators

55----------------------------------------------------------------------------

95----------------------------------------------------------------------------

typerep-map.cabal+3−3

@@ -1,5 +1,5 @@

1name: typerep-map

2−version: 1.0

2+version: 0.1.0

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

4description: See README.md for more details.

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

@@ -26,10 +26,10 @@ library

26 exposed-modules: Data.TypeRep.Map

27 Data.TypeRep.TMap

28 ghc-options: -Wall

29− build-depends: base

29+ build-depends: base >= 4.9 && < 5

30 , containers

31 , ghc-prim

32− , primitive

32+ , primitive >= 0.6.4

33 default-extensions: OverloadedStrings

34 RecordWildCards

35 ScopedTypeVariables