git.iko.soy/typerep-map
on main help sign in
[#8] Add property tests for insert lookup (#16)
e346251Veronika Romashkina
.travis.yml+2−2
compare with main
unifiedsplit
@@ -16,7 +16,7 @@ matrix:
16 include:
16 include:
17
17
18 - ghc: 8.0.2
18 - ghc: 8.0.2
19− env: GHCVER='8.0.2' CABALVER='head'
19+ env: GHCVER='8.0.2' CABALVER='head' ALLOWNEWER='--allow-newer'
20 os: linux
20 os: linux
21 addons:
21 addons:
22 apt:
22 apt:
@@ -77,7 +77,7 @@ install:
77script:
77script:
78 - |
78 - |
79 if [ -z "$STACK_YAML" ]; then
79 if [ -z "$STACK_YAML" ]; then
80− cabal new-test
80+ cabal new-test $ALLOWNEWER
81 else
81 else
82 stack build --test --bench --no-terminal
82 stack build --test --bench --no-terminal
83 fi
83 fi
internal/Data/TypeRep/CacheMap.hs+36−33
@@ -1,4 +1,5 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE MagicHash #-}
5{-# LANGUAGE MagicHash #-}
@@ -20,12 +21,17 @@ module Data.TypeRep.CacheMap
20 -- * Helpful testing functions
21 -- * Helpful testing functions
21 , TF (..)
22 , TF (..)
22 , fromList
23 , fromList
24+ , toFps
23 ) where
25 ) where
24
26
25import Prelude hiding (lookup)
27import Prelude hiding (lookup)
26
28
27import Control.Arrow ((&&&))
29import Control.Arrow ((&&&))
30+import Data.Function (on)
31+import Data.IntMap.Strict (IntMap)
28import Data.Kind (Type)
32import Data.Kind (Type)
33+import Data.List (nubBy)
34+import Data.Maybe (fromJust)
29import Data.Proxy (Proxy (..))
35import Data.Proxy (Proxy (..))
30import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
36import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
31import Data.Word (Word64)
37import Data.Word (Word64)
@@ -36,6 +42,7 @@ import GHC.Prim (eqWord#, ltWord#)
36import GHC.Word (Word64 (..))
42import GHC.Word (Word64 (..))
37import Unsafe.Coerce (unsafeCoerce)
43import Unsafe.Coerce (unsafeCoerce)
38
44
45+import qualified Data.IntMap.Strict as IM
39import qualified Data.Vector as V
46import qualified Data.Vector as V
40import qualified Data.Vector.Unboxed as Unboxed
47import qualified Data.Vector.Unboxed as Unboxed
41
48
@@ -45,6 +52,14 @@ data TypeRepMap (f :: k -> Type) = TypeRepMap
45 , anys :: V.Vector Any
52 , anys :: V.Vector Any
46 }
53 }
47
54
55+instance Show (TypeRepMap f) where
56+ show = show . toFps
57+
58+toFps :: TypeRepMap f -> [Fingerprint]
59+toFps TypeRepMap{..} = zipWith Fingerprint
60+ (Unboxed.toList fingerprintAs)
61+ (Unboxed.toList fingerprintBs)
62+
48fromAny :: Any -> f a
63fromAny :: Any -> f a
49fromAny = unsafeCoerce
64fromAny = unsafeCoerce
50
65
@@ -57,10 +72,7 @@ insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
57insert x = fromListPairs . addX . toPairList
72insert x = fromListPairs . addX . toPairList
58 where
73 where
59 toPairList :: TypeRepMap f -> [(Fingerprint, Any)]
74 toPairList :: TypeRepMap f -> [(Fingerprint, Any)]
60− toPairList (TypeRepMap as bs ans) = zip (zipWith Fingerprint
75+ toPairList trMap = zip (toFps trMap) (V.toList $ anys trMap)
61− (Unboxed.toList as)
62− (Unboxed.toList bs))
63− (V.toList ans)
64
76
65 pairX :: (Fingerprint, Any)
77 pairX :: (Fingerprint, Any)
66 pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
78 pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
@@ -114,7 +126,10 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
114----------------------------------------------------------------------------
126----------------------------------------------------------------------------
115
127
116data TF f where
128data TF f where
117− TF :: Typeable a => f a -> TF f
129+ TF :: Typeable a => f a -> TF f
130+
131+instance Show (TF f) where
132+ show (TF tf) = show $ calcFp tf
118
133
119fromF :: Typeable a => f a -> Proxy a
134fromF :: Typeable a => f a -> Proxy a
120fromF _ = Proxy
135fromF _ = Proxy
@@ -126,7 +141,7 @@ fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f
126fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
141fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
127 where
142 where
128 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps
143 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps
129− (fps, ans) = unzip $ breadthFirst $ fromListToTree $ sortWith fst kvs
144+ (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubPairs kvs
130
145
131fromList :: forall f . [TF f] -> TypeRepMap f
146fromList :: forall f . [TF f] -> TypeRepMap f
132fromList = fromListPairs . map (fp &&& an)
147fromList = fromListPairs . map (fp &&& an)
@@ -137,34 +152,22 @@ fromList = fromListPairs . map (fp &&& an)
137 an :: TF f -> Any
152 an :: TF f -> Any
138 an (TF x) = unsafeCoerce x
153 an (TF x) = unsafeCoerce x
139
154
155+nubPairs :: (Eq a) => [(a, b)] -> [(a, b)]
156+nubPairs = nubBy ((==) `on` fst)
157+
140----------------------------------------------------------------------------
158----------------------------------------------------------------------------
141−-- Tree
159+-- Tree-like conversion
142----------------------------------------------------------------------------
160----------------------------------------------------------------------------
143
161
144−data Tree a = Leaf | Node a (Tree a) (Tree a)
162+fromSortedList :: forall a . [a] -> [a]
145− deriving (Show)
163+fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)
146−
147−fromListToTree :: [a] -> Tree a
148−fromListToTree [] = Leaf
149−fromListToTree xs =
150− let len = length xs
151− in case splitAt (len `div` 2) xs of
152− ([], []) -> Leaf
153− (ls, []) -> Node (last ls) (fromListToTree $ init ls) Leaf
154− ([], (r:rs)) -> Node r Leaf $ fromListToTree rs
155− (ls, r:rs) -> Node r (fromListToTree ls) (fromListToTree rs)
156−
157−breadthFirst :: Tree a -> [a]
158−breadthFirst tree = bf [tree]
159 where
164 where
160− bf :: [Tree a] -> [a]
165+ -- state monad could be used here, but it's another dependency
161− bf [] = []
166+ go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)
162− bf xs = mapValue xs ++ bf (concatMap children xs)
167+ go i first result vector =
163−
168+ if i >= IM.size vector
164− mapValue :: [Tree a] -> [a]
169+ then (result, first)
165− mapValue [] = []
170+ else do
166− mapValue (Leaf : xs) = mapValue xs
171+ let (newResult, newFirst) = go (2 * i + 1) first result vector
167− mapValue (Node a _ _ : xs) = a : mapValue xs
172+ let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult
168−
173+ go (2 * i + 2) (newFirst + 1) withCur vector
169− children Leaf = []
170− children (Node _ l r) = [l, r]
test/Test/TypeRep/MapProperty.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE PolyKinds #-}
4+
5+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
6+
7+module Test.TypeRep.MapProperty where
8+
9+import Prelude hiding (lookup)
10+
11+import Data.Proxy (Proxy (..))
12+import GHC.Stack (HasCallStack)
13+import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
14+import Hedgehog (MonadGen, PropertyT, forAll, property, (===))
15+import Test.Tasty (TestName, TestTree)
16+import Test.Tasty.Hedgehog (testProperty)
17+
18+import Data.TypeRep.CacheMap (TF (..), TypeRepMap, fromList, insert, lookup)
19+
20+import qualified Hedgehog.Gen as Gen
21+import qualified Hedgehog.Range as Range
22+
23+type PropertyTest = [TestTree]
24+
25+prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest
26+prop testName = pure . testProperty testName . property
27+
28+test_InsertLookup :: PropertyTest
29+test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do
30+ m <- forAll genMap
31+ TF (proxy :: IntProxy n) <- forAll genTF
32+
33+ lookup @n @IntProxy (insert proxy m) === Just proxy
34+
35+test_InsertInsert :: PropertyTest
36+test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do
37+ m <- forAll genMap
38+ TF a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
39+ let b = IntProxy proxy (i + 1)
40+ lookup @n @IntProxy (insert b $ insert a m) === Just b
41+
42+
43+----------------------------------------------------------------------------
44+-- Generators
45+----------------------------------------------------------------------------
46+
47+data IntProxy (n :: Nat) = IntProxy (Proxy n) Int
48+ deriving (Show, Eq)
49+
50+
51+genMap :: MonadGen m => m (TypeRepMap IntProxy)
52+genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF
53+
54+
55+genTF :: MonadGen m => m (TF IntProxy)
56+genTF = do
57+ randNat :: Integer <- Gen.integral (Range.linear 0 10000)
58+ randInt <- Gen.int Range.constantBounded
59+ case someNatVal randNat of
60+ Just (SomeNat proxyNat) -> pure $ TF $ IntProxy proxyNat randInt
61+ Nothing -> error "Invalid test generator"
typerep-map.cabal+8−1
@@ -52,16 +52,23 @@ test-suite typerep-map-test
52 main-is: Test.hs
52 main-is: Test.hs
53 other-modules: Test.TypeRep.CMap
53 other-modules: Test.TypeRep.CMap
54 , Test.TypeRep.CacheMap
54 , Test.TypeRep.CacheMap
55+ , Test.TypeRep.MapProperty
55 , Test.TypeRep.Vector
56 , Test.TypeRep.Vector
56 , Test.TypeRep.VectorOpt
57 , Test.TypeRep.VectorOpt
57 build-depends: base
58 build-depends: base
59+ , ghc-typelits-knownnat
60+ , hedgehog
58 , typerep-map
61 , typerep-map
59 , typerep-map-internal
62 , typerep-map-internal
60 , tasty
63 , tasty
61 , tasty-discover >= 4.1.1
64 , tasty-discover >= 4.1.1
65+ , tasty-hedgehog
62 , tasty-hspec
66 , tasty-hspec
63 build-tool-depends: tasty-discover:tasty-discover
67 build-tool-depends: tasty-discover:tasty-discover
64 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
68 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
69+ default-extensions: ScopedTypeVariables
70+ TypeApplications
71+
65 default-language: Haskell2010
72 default-language: Haskell2010
66
73
67benchmark typerep-map-benchmark
74benchmark typerep-map-benchmark
@@ -76,11 +83,11 @@ benchmark typerep-map-benchmark
76 , OptimalVector
83 , OptimalVector
77 build-depends: base
84 build-depends: base
78 , criterion
85 , criterion
79− , typerep-map-internal
80 , deepseq
86 , deepseq
81 , dependent-map
87 , dependent-map
82 , dependent-sum
88 , dependent-sum
83 , ghc-typelits-knownnat
89 , ghc-typelits-knownnat
90+ , typerep-map-internal
84 default-extensions: OverloadedStrings
91 default-extensions: OverloadedStrings
85 RecordWildCards
92 RecordWildCards
86 ScopedTypeVariables
93 ScopedTypeVariables