[#8] Add property tests for insert lookup (#16)

* Add property tests for insert lookup

Remove Tree structure and convert sorted list directly
to the list with the required order.

Fix work with 8.0.2

* Add insert.insert test, fix CI

.travis.yml

@@ -16,7 +16,7 @@ matrix:
   include:
 
   - ghc: 8.0.2
-    env: GHCVER='8.0.2' CABALVER='head'
+    env: GHCVER='8.0.2' CABALVER='head' ALLOWNEWER='--allow-newer'
     os: linux
     addons:
       apt:
@@ -77,7 +77,7 @@ install:
 script:
   - |
     if [ -z "$STACK_YAML" ]; then
-      cabal new-test
+      cabal new-test $ALLOWNEWER
     else
       stack build --test --bench --no-terminal
     fi

internal/Data/TypeRep/CacheMap.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns   #-}
+{-# LANGUAGE DataKinds      #-}
 {-# LANGUAGE GADTs          #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MagicHash      #-}
@@ -20,12 +21,17 @@ module Data.TypeRep.CacheMap
          -- * Helpful testing functions
        , TF (..)
        , fromList
+       , toFps
        ) where
 
 import Prelude hiding (lookup)
 
 import Control.Arrow ((&&&))
+import Data.Function (on)
+import Data.IntMap.Strict (IntMap)
 import Data.Kind (Type)
+import Data.List (nubBy)
+import Data.Maybe (fromJust)
 import Data.Proxy (Proxy (..))
 import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
 import Data.Word (Word64)
@@ -36,6 +42,7 @@ import GHC.Prim (eqWord#, ltWord#)
 import GHC.Word (Word64 (..))
 import Unsafe.Coerce (unsafeCoerce)
 
+import qualified Data.IntMap.Strict as IM
 import qualified Data.Vector as V
 import qualified Data.Vector.Unboxed as Unboxed
 
@@ -45,6 +52,14 @@ data TypeRepMap (f :: k -> Type) = TypeRepMap
     , anys          :: V.Vector Any
     }
 
+instance Show (TypeRepMap f) where
+    show = show . toFps
+
+toFps :: TypeRepMap f -> [Fingerprint]
+toFps TypeRepMap{..} = zipWith Fingerprint
+                               (Unboxed.toList fingerprintAs)
+                               (Unboxed.toList fingerprintBs)
+
 fromAny :: Any -> f a
 fromAny = unsafeCoerce
 
@@ -57,10 +72,7 @@ insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
 insert x = fromListPairs . addX . toPairList
   where
     toPairList :: TypeRepMap f -> [(Fingerprint, Any)]
-    toPairList (TypeRepMap as bs ans) = zip (zipWith Fingerprint
-                                                    (Unboxed.toList as)
-                                                    (Unboxed.toList bs))
-                                            (V.toList ans)
+    toPairList trMap = zip (toFps trMap) (V.toList $ anys trMap)
 
     pairX :: (Fingerprint, Any)
     pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
@@ -114,7 +126,10 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
 ----------------------------------------------------------------------------
 
 data TF f where
-  TF :: Typeable a => f a -> TF f
+    TF :: Typeable a => f a -> TF f
+
+instance Show (TF f) where
+    show (TF tf) = show $ calcFp tf
 
 fromF :: Typeable a => f a -> Proxy a
 fromF _ = Proxy
@@ -126,7 +141,7 @@ fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f
 fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
   where
     (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps
-    (fps, ans) = unzip $ breadthFirst $ fromListToTree $ sortWith fst kvs
+    (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubPairs kvs
 
 fromList :: forall f . [TF f] -> TypeRepMap f
 fromList = fromListPairs . map (fp &&& an)
@@ -137,34 +152,22 @@ fromList = fromListPairs . map (fp &&& an)
     an :: TF f -> Any
     an (TF x) = unsafeCoerce x
 
+nubPairs :: (Eq a) => [(a, b)] -> [(a, b)]
+nubPairs = nubBy ((==) `on` fst)
+
 ----------------------------------------------------------------------------
--- Tree
+-- Tree-like conversion
 ----------------------------------------------------------------------------
 
-data Tree a = Leaf | Node a (Tree a) (Tree a)
-    deriving (Show)
-
-fromListToTree :: [a] -> Tree a
-fromListToTree [] = Leaf
-fromListToTree xs =
-    let len = length xs
-    in case splitAt (len `div` 2) xs of
-           ([], [])     -> Leaf
-           (ls, [])     -> Node (last ls) (fromListToTree $ init ls) Leaf
-           ([], (r:rs)) -> Node r Leaf $ fromListToTree rs
-           (ls, r:rs)   -> Node r (fromListToTree ls) (fromListToTree rs)
-
-breadthFirst :: Tree a -> [a]
-breadthFirst tree = bf [tree]
+fromSortedList :: forall a . [a] -> [a]
+fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)
   where
-    bf :: [Tree a] -> [a]
-    bf [] = []
-    bf xs = mapValue xs ++ bf (concatMap children xs)
-
-    mapValue :: [Tree a] -> [a]
-    mapValue []                = []
-    mapValue (Leaf : xs)       = mapValue xs
-    mapValue (Node a _ _ : xs) = a : mapValue xs
-
-    children Leaf         = []
-    children (Node _ l r) = [l, r]
+    -- state monad could be used here, but it's another dependency
+    go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)
+    go i first result vector =
+      if i >= IM.size vector
+      then (result, first)
+      else do
+          let (newResult, newFirst) = go (2 * i + 1) first result vector
+          let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult
+          go (2 * i + 2) (newFirst + 1) withCur vector

test/Test/TypeRep/MapProperty.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE DataKinds      #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds      #-}
+
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+
+module Test.TypeRep.MapProperty where
+
+import Prelude hiding (lookup)
+
+import Data.Proxy (Proxy (..))
+import GHC.Stack (HasCallStack)
+import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
+import Hedgehog (MonadGen, PropertyT, forAll, property, (===))
+import Test.Tasty (TestName, TestTree)
+import Test.Tasty.Hedgehog (testProperty)
+
+import Data.TypeRep.CacheMap (TF (..), TypeRepMap, fromList, insert, lookup)
+
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+type PropertyTest = [TestTree]
+
+prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest
+prop testName = pure . testProperty testName . property
+
+test_InsertLookup :: PropertyTest
+test_InsertLookup =  prop "lookup k (insert k v m) == Just v" $ do
+    m <- forAll genMap
+    TF (proxy :: IntProxy n) <- forAll genTF
+
+    lookup @n @IntProxy (insert proxy m) === Just proxy
+
+test_InsertInsert :: PropertyTest
+test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do
+    m <- forAll genMap
+    TF a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
+    let b = IntProxy proxy (i + 1)
+    lookup @n @IntProxy (insert b $ insert a m) === Just b
+
+
+----------------------------------------------------------------------------
+-- Generators
+----------------------------------------------------------------------------
+
+data IntProxy (n :: Nat) = IntProxy (Proxy n) Int
+    deriving (Show, Eq)
+
+
+genMap :: MonadGen m => m (TypeRepMap IntProxy)
+genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF
+
+
+genTF :: MonadGen m => m (TF IntProxy)
+genTF = do
+    randNat :: Integer <- Gen.integral (Range.linear 0 10000)
+    randInt <- Gen.int Range.constantBounded
+    case someNatVal randNat of
+        Just (SomeNat proxyNat) -> pure $ TF $ IntProxy proxyNat randInt
+        Nothing                 -> error "Invalid test generator"

typerep-map.cabal

@@ -52,16 +52,23 @@ test-suite typerep-map-test
   main-is:             Test.hs
   other-modules:       Test.TypeRep.CMap
                      , Test.TypeRep.CacheMap
+                     , Test.TypeRep.MapProperty
                      , Test.TypeRep.Vector
                      , Test.TypeRep.VectorOpt
   build-depends:       base
+                     , ghc-typelits-knownnat
+                     , hedgehog
                      , typerep-map
                      , typerep-map-internal
                      , tasty
                      , tasty-discover >= 4.1.1
+                     , tasty-hedgehog
                      , tasty-hspec
   build-tool-depends:  tasty-discover:tasty-discover
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
+  default-extensions:  ScopedTypeVariables
+                       TypeApplications
+
   default-language:    Haskell2010
 
 benchmark typerep-map-benchmark
@@ -76,11 +83,11 @@ benchmark typerep-map-benchmark
                      , OptimalVector
   build-depends:       base
                      , criterion
-                     , typerep-map-internal
                      , deepseq
                      , dependent-map
                      , dependent-sum
                      , ghc-typelits-knownnat
+                     , typerep-map-internal
   default-extensions:  OverloadedStrings
                        RecordWildCards
                        ScopedTypeVariables