diff --git a/.travis.yml b/.travis.yml index a7e0bff..9273d0b 100644 --- a/.travis.yml +++ b/.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 diff --git a/internal/Data/TypeRep/CacheMap.hs b/internal/Data/TypeRep/CacheMap.hs index b0f8908..cc3366b 100644 --- a/internal/Data/TypeRep/CacheMap.hs +++ b/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 diff --git a/test/Test/TypeRep/MapProperty.hs b/test/Test/TypeRep/MapProperty.hs new file mode 100644 index 0000000..6a63883 --- /dev/null +++ b/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" diff --git a/typerep-map.cabal b/typerep-map.cabal index c13d446..d3991af 100644 --- a/typerep-map.cabal +++ b/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