typerep-map 0.1.0 → 0.2.0
raw patch · 10 files changed
+142/−77 lines, 10 filesdep ~basesetup-changednew-uploader
Dependency ranges changed: base
Files
- CHANGELOG.md +10/−0
- Setup.hs +0/−2
- benchmark/CacheMap.hs +6/−5
- benchmark/DMap.hs +10/−9
- src/Data/TMap.hs +10/−1
- src/Data/TypeRepMap.hs +4/−0
- src/Data/TypeRepMap/Internal.hs +86/−46
- test/Test/TypeRep/CacheMap.hs +6/−4
- test/Test/TypeRep/MapProperty.hs +8/−7
- typerep-map.cabal +2/−3
CHANGELOG.md view
@@ -4,6 +4,16 @@ `typerep-map` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. +# 0.2.0++* [#43](https://github.com/kowainik/typerep-map/issues/43):+ Implement `IsList` instance for `TypeRepMap`.+ Add `hoistA` function.+* [#39](https://github.com/kowainik/typerep-map/issues/39):+ Implement `hoistWithKey` function.+ Add `map` function for `TMap`.+* Drop support for `ghc-8.0.2`.+ # 0.1.0 * Initially created.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
benchmark/CacheMap.hs view
@@ -19,9 +19,10 @@ import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable)+import GHC.Exts (fromList) import GHC.TypeLits -import Data.TypeRepMap.Internal (TF (..), TypeRepMap (..), fromList, lookup)+import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), lookup) benchCacheMap :: Benchmark benchCacheMap = bgroup "vector optimal cache"@@ -46,7 +47,7 @@ buildBigMap :: forall a . (KnownNat a) => Int -> Proxy (a :: Nat)- -> [TF (Proxy :: Nat -> *)]- -> [TF (Proxy :: Nat -> *)]-buildBigMap 1 x = (TF x :)-buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))+ -> [WrapTypeable (Proxy :: Nat -> *)]+ -> [WrapTypeable (Proxy :: Nat -> *)]+buildBigMap 1 x = (WrapTypeable x :)+buildBigMap n x = (WrapTypeable x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))
benchmark/DMap.hs view
@@ -21,7 +21,6 @@ import Control.DeepSeq (rnf) import Control.Exception-import Data.Functor.Identity (Identity (..)) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Type.Equality ((:~:) (..))@@ -34,6 +33,8 @@ import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) import Data.Some (Some (This)) +type TypeRepMap = DMap TypeRep+ benchDMap :: Benchmark benchDMap = bgroup "dependent map" [ bench "lookup" $ nf tenLookups bigMap@@ -41,29 +42,29 @@ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1) ] -tenLookups :: DMap TypeRep Identity+tenLookups :: TypeRepMap (Proxy :: Nat -> *) -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 , Proxy 50, Proxy 60, Proxy 70, Proxy 80 ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where lp :: forall (a :: Nat) . Typeable a => Proxy a- lp = runIdentity $ fromJust $ lookup (typeRep @(Proxy a)) tmap+ lp = fromJust $ lookup (typeRep @a) tmap -- TypeRepMap of 10000 elements-bigMap :: DMap TypeRep Identity+bigMap :: TypeRepMap (Proxy :: Nat -> *) bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty buildBigMap :: forall a . (KnownNat a) => Int -> Proxy (a :: Nat)- -> DMap TypeRep Identity- -> DMap TypeRep Identity-buildBigMap 1 x = insert (typeRep @(Proxy a)) $ Identity x-buildBigMap n x = insert (typeRep @(Proxy a)) (Identity x)+ -> TypeRepMap (Proxy :: Nat -> *)+ -> TypeRepMap (Proxy :: Nat -> *)+buildBigMap 1 x = insert (typeRep @a) x+buildBigMap n x = insert (typeRep @a) x . buildBigMap (n - 1) (Proxy @(a + 1)) -rknf :: DMap TypeRep f -> ()+rknf :: TypeRepMap f -> () rknf = rnf . map (\(This t) -> typeRepFingerprint t) . keys prepareBenchDMap :: IO ()
src/Data/TMap.hs view
@@ -33,6 +33,7 @@ , delete , unionWith , union+ , map -- * Query , lookup@@ -40,7 +41,7 @@ , size ) where -import Prelude hiding (lookup)+import Prelude hiding (lookup, map) import Data.Functor.Identity (Identity (..)) import Data.Typeable (Typeable)@@ -146,3 +147,11 @@ size :: TMap -> Int size = F.size {-# INLINE size #-}++-- | Map a function over the values.+map :: (forall a. Typeable a => a -> a) -> TMap -> TMap+map f = F.hoistWithKey (fIdentity f)+ where+ fIdentity :: forall a. Typeable a => (a -> a) -> Identity a -> Identity a+ fIdentity = coerce+{-# INLINE map #-}
src/Data/TypeRepMap.hs view
@@ -52,6 +52,8 @@ , insert , delete , hoist+ , hoistA+ , hoistWithKey , unionWith , union @@ -60,6 +62,8 @@ , member , size + -- * 'IsList'+ , WrapTypeable (..) ) where import Data.TypeRepMap.Internal
src/Data/TypeRepMap/Internal.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-}+{-# LANGUAGE ViewPatterns #-} -- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-} @@ -22,7 +23,7 @@ import Prelude hiding (lookup) -import Control.Arrow ((&&&))+import Control.Monad.Zip (mzip) import Data.Function (on) import Data.IntMap.Strict (IntMap) import Data.Kind (Type)@@ -30,14 +31,14 @@ import Data.Maybe (fromJust) import Data.Primitive.Array (Array, indexArray, mapArray') import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)-import Data.Proxy (Proxy (..)) import Data.Semigroup (Semigroup (..))-import Data.Typeable (Typeable, typeRep, typeRepFingerprint) import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))-import GHC.Exts (inline, sortWith)+import GHC.Exts (IsList (..), inline, sortWith) import GHC.Fingerprint (Fingerprint (..)) import GHC.Prim (eqWord#, ltWord#) import GHC.Word (Word64 (..))+import Type.Reflection (TypeRep, Typeable, typeRep, withTypeable)+import Type.Reflection.Unsafe (typeRepFingerprint) import Unsafe.Coerce (unsafeCoerce) import qualified Data.IntMap.Strict as IM@@ -70,6 +71,7 @@ { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ first components of key fingerprints , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ second components of key fingerprints , anys :: {-# UNPACK #-} !(Array Any) -- ^ values stored in the map+ , keys :: {-# UNPACK #-} !(Array Any) -- ^ typerep keys } -- ^ an unsafe constructor for 'TypeRepMap' @@ -84,7 +86,7 @@ {-# INLINE (<>) #-} instance Monoid (TypeRepMap f) where- mempty = TypeRepMap mempty mempty mempty+ mempty = TypeRepMap mempty mempty mempty mempty mappend = (<>) {-# INLINE mempty #-} {-# INLINE mappend #-}@@ -127,13 +129,13 @@ -} insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f-insert x = fromListPairs . addX . toPairList+insert x = fromTriples . addX . toTriples where- pairX :: (Fingerprint, Any)- pairX@(fpX, _) = (calcFp x, toAny x)+ tripleX :: (Fingerprint, Any, Any)+ tripleX@(fpX, _, _) = (calcFp @a, toAny x, unsafeCoerce $ typeRep @a) - addX :: [(Fingerprint, Any)] -> [(Fingerprint, Any)]- addX l = pairX : deleteByFst fpX l+ addX :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)]+ addX l = tripleX : deleteByFst fpX l {-# INLINE insert #-} -- Extract the kind of a type. We use it to work around lack of syntax for@@ -154,7 +156,7 @@ True -} delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeRepMap f-delete = fromListPairs . deleteByFst (typeFp @a) . toPairList+delete = fromTriples . deleteByFst (typeFp @a) . toTriples {-# INLINE delete #-} {- | Map over the elements of a 'TypeRepMap'.@@ -171,19 +173,40 @@ Just "a" -} hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g-hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ mapArray' (toAny . f . fromAny) ans+hoist f (TypeRepMap as bs ans ks) = TypeRepMap as bs (mapArray' (toAny . f . fromAny) ans) ks {-# INLINE hoist #-} +hoistA :: (Applicative t) => (forall x. f x -> t (g x)) -> TypeRepMap f -> t (TypeRepMap g)+hoistA f (TypeRepMap as bs (toList -> ans) ks) = (\l -> TypeRepMap as bs (fromList $ map toAny l) ks)+ <$> traverse (f . fromAny) ans+{-# INLINE hoistA #-}++hoistWithKey :: forall f g. (forall x. Typeable x => f x -> g x) -> TypeRepMap f -> TypeRepMap g+hoistWithKey f (TypeRepMap as bs ans ks) = TypeRepMap as bs newAns ks+ where+ newAns = mapArray' mapAns (mzip ans ks)+ mapAns (a, k) = toAny $ withTr (unsafeCoerce k) $ fromAny a++ withTr :: forall x. TypeRep x -> f x -> g x+ withTr t = withTypeable t f+{-# INLINE hoistWithKey #-}+ -- | The union of two 'TypeRepMap's using a combining function. unionWith :: (forall x. f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f-unionWith f m1 m2 = fromListPairs- $ Map.toList+unionWith f m1 m2 = fromTriples+ $ toTripleList $ Map.unionWith combine- (Map.fromList $ toPairList m1)- (Map.fromList $ toPairList m2)+ (fromTripleList $ toTriples m1)+ (fromTripleList $ toTriples m2) where- combine :: Any -> Any -> Any- combine a b = toAny $ f (fromAny a) (fromAny b)+ combine :: (Any, Any) -> (Any, Any) -> (Any, Any)+ combine (av, ak) (bv, _) = (toAny $ f (fromAny av) (fromAny bv), ak)++ fromTripleList :: Ord a => [(a, b, c)] -> Map.Map a (b, c)+ fromTripleList = Map.fromList . map (\(a, b, c) -> (a, (b, c)))++ toTripleList :: Map.Map a (b, c) -> [(a, b, c)]+ toTripleList = map (\(a, (b, c)) -> (a, b, c)) . Map.toList {-# INLINE unionWith #-} -- | The (left-biased) union of two 'TypeRepMap's. It prefers the first map when@@ -259,56 +282,73 @@ fromAny = unsafeCoerce typeFp :: forall a . Typeable a => Fingerprint-typeFp = typeRepFingerprint $ typeRep $ Proxy @a+typeFp = typeRepFingerprint $ typeRep @a {-# INLINE typeFp #-} -toPairList :: TypeRepMap f -> [(Fingerprint, Any)]-toPairList tm = zip (toFingerprints tm) (GHC.toList $ anys tm)+toTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)]+toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ anys tm) (GHC.toList $ keys tm) -deleteByFst :: Eq a => a -> [(a, b)] -> [(a, b)]-deleteByFst x = filter ((/= x) . fst)+deleteByFst :: Eq a => a -> [(a, b, c)] -> [(a, b, c)]+deleteByFst x = filter ((/= x) . fst3) -nubByFst :: (Eq a) => [(a, b)] -> [(a, b)]-nubByFst = nubBy ((==) `on` fst)+nubByFst :: (Eq a) => [(a, b, c)] -> [(a, b, c)]+nubByFst = nubBy ((==) `on` fst3) +fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a+ ---------------------------------------------------------------------------- -- Functions for testing and benchmarking ---------------------------------------------------------------------------- -- | Existential wrapper around 'Typeable' indexed by @f@ type parameter.--- Useful for 'TypeRepMap' structure creation form list of 'TF's.-data TF f where- TF :: Typeable a => f a -> TF f+-- Useful for 'TypeRepMap' structure creation form list of 'WrapTypeable's.+data WrapTypeable f where+ WrapTypeable :: Typeable a => f a -> WrapTypeable f -instance Show (TF f) where- show (TF tf) = show $ calcFp tf+instance Show (WrapTypeable f) where+ show (WrapTypeable (_ :: f a)) = show $ calcFp @a -{- | Creates 'TypeRepMap' from a list of 'TF's.+{- | ->>> size $ fromList [TF $ Identity True, TF $ Identity 'a']+prop> fromList . toList == 'id'++Creates 'TypeRepMap' from a list of 'WrapTypeable's.++>>> size $ fromList [WrapTypeable $ Identity True, WrapTypeable $ Identity 'a'] 2 + -}-fromList :: forall f . [TF f] -> TypeRepMap f-fromList = fromListPairs . map (fp &&& an)- where- fp :: TF f -> Fingerprint- fp (TF x) = calcFp x+instance IsList (TypeRepMap f) where+ type Item (TypeRepMap f) = WrapTypeable f - an :: TF f -> Any- an (TF x) = toAny x+ fromList :: [WrapTypeable f] -> TypeRepMap f+ fromList = fromTriples . map (\x -> (fp x, an x, k x))+ where+ fp :: WrapTypeable f -> Fingerprint+ fp (WrapTypeable (_ :: f a)) = calcFp @a -fromF :: Typeable a => f a -> Proxy a-fromF _ = Proxy+ an :: WrapTypeable f -> Any+ an (WrapTypeable x) = toAny x -calcFp :: Typeable a => f a -> Fingerprint-calcFp = typeRepFingerprint . typeRep . fromF+ k :: WrapTypeable f -> Any+ k (WrapTypeable (_ :: f a)) = unsafeCoerce $ typeRep @a -fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f-fromListPairs kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans)+ toList :: TypeRepMap f -> [WrapTypeable f]+ toList = map toWrapTypeable . toTriples+ where+ toWrapTypeable :: (Fingerprint, Any, Any) -> WrapTypeable f+ toWrapTypeable (_, an, k) = withTypeable (unsafeCoerce k) $ fromAny an++calcFp :: forall a . Typeable a => Fingerprint+calcFp = typeRepFingerprint $ typeRep @a++fromTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f+fromTriples kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans) (GHC.fromList ks) where (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps- (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubByFst kvs+ (fps, ans, ks) = unzip3 $ fromSortedList $ sortWith fst3 $ nubByFst kvs ---------------------------------------------------------------------------- -- Tree-like conversion
test/Test/TypeRep/CacheMap.hs view
@@ -3,19 +3,20 @@ import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..))+import GHC.Exts (fromList) import Test.Tasty.Hspec (Spec, describe, it, shouldBe) -import Data.TypeRepMap.Internal (TF (..), fromList) import Data.TMap (TMap, empty, insert, lookup, one, size, union)+import Data.TypeRepMap.Internal (WrapTypeable (..)) -- Simple test for 'lookup', 'insert' and 'size' functions. spec_insertLookup :: Spec spec_insertLookup = do describe "Lookup Test" $ do it "returns the inserted element" $- lookup (fromList [TF $ Identity 'a']) `shouldBe` Just 'a'+ lookup (fromList [WrapTypeable $ Identity 'a']) `shouldBe` Just 'a' it "returns the second inserted value of the same type" $- lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just 'b'+ lookup (fromList [WrapTypeable (Identity 'b'), WrapTypeable (Identity 'a')]) `shouldBe` Just 'b' describe "Size Test" $ do it "is empty" $@@ -28,7 +29,8 @@ size mapOf10 `shouldBe` 10 describe "Union test" $ do- let m = fromList [TF $ Identity 'a', TF $ Identity True] `union` fromList [TF $ Identity 'b']+ let m = fromList [WrapTypeable $ Identity 'a', WrapTypeable $ Identity True] `union`+ fromList [WrapTypeable $ Identity 'b'] it "lookup works on union as expected" $ do lookup m `shouldBe` Just 'a' lookup m `shouldBe` Just True
test/Test/TypeRep/MapProperty.hs view
@@ -11,13 +11,14 @@ import Data.Proxy (Proxy (..)) import Data.Semigroup (Semigroup (..))+import GHC.Exts (fromList) 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.TypeRepMap.Internal (TF (..), TypeRepMap (..), delete, fromList, insert, lookup, member)+import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range@@ -38,21 +39,21 @@ test_InsertLookup :: PropertyTest test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do m <- forAll genMap- TF (proxy :: IntProxy n) <- forAll genTF+ WrapTypeable (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+ WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF let b = IntProxy proxy (i + 1) lookup @n @IntProxy (insert b $ insert a m) === Just b test_DeleteMember :: PropertyTest test_DeleteMember = prop "member k . delete k == False" $ do m <- forAll genMap- TF (proxy :: IntProxy n) <- forAll genTF+ WrapTypeable (proxy :: IntProxy n) <- forAll genTF shouldInsert <- forAll Gen.bool if shouldInsert then@@ -72,7 +73,7 @@ deriving (Show, Semigroup, Monoid) instance Eq (FpMap f) where- FpMap (TypeRepMap as1 bs1 _) == FpMap (TypeRepMap as2 bs2 _) =+ FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) = as1 == as2 && bs1 == bs2 test_SemigroupAssoc :: PropertyTest@@ -100,10 +101,10 @@ genMap :: MonadGen m => m (TypeRepMap IntProxy) genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF -genTF :: MonadGen m => m (TF IntProxy)+genTF :: MonadGen m => m (WrapTypeable 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+ Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt Nothing -> error "Invalid test generator"
typerep-map.cabal view
@@ -1,5 +1,5 @@ name: typerep-map-version: 0.1.0+version: 0.2.0 synopsis: Efficient implementation of a dependent map with types as keys description: A dependent map from type representations to values of these types.@@ -28,8 +28,7 @@ extra-doc-files: README.md , CHANGELOG.md cabal-version: 2.0-tested-with: GHC == 8.0.2- , GHC == 8.2.2+tested-with: GHC == 8.2.2 , GHC == 8.4.3 source-repository head