diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/benchmark/CacheMap.hs b/benchmark/CacheMap.hs --- a/benchmark/CacheMap.hs +++ b/benchmark/CacheMap.hs @@ -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)) diff --git a/benchmark/DMap.hs b/benchmark/DMap.hs --- a/benchmark/DMap.hs +++ b/benchmark/DMap.hs @@ -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 () diff --git a/src/Data/TMap.hs b/src/Data/TMap.hs --- a/src/Data/TMap.hs +++ b/src/Data/TMap.hs @@ -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 #-} diff --git a/src/Data/TypeRepMap.hs b/src/Data/TypeRepMap.hs --- a/src/Data/TypeRepMap.hs +++ b/src/Data/TypeRepMap.hs @@ -52,6 +52,8 @@ , insert , delete , hoist + , hoistA + , hoistWithKey , unionWith , union @@ -60,6 +62,8 @@ , member , size + -- * 'IsList' + , WrapTypeable (..) ) where import Data.TypeRepMap.Internal diff --git a/src/Data/TypeRepMap/Internal.hs b/src/Data/TypeRepMap/Internal.hs --- a/src/Data/TypeRepMap/Internal.hs +++ b/src/Data/TypeRepMap/Internal.hs @@ -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 diff --git a/test/Test/TypeRep/CacheMap.hs b/test/Test/TypeRep/CacheMap.hs --- a/test/Test/TypeRep/CacheMap.hs +++ b/test/Test/TypeRep/CacheMap.hs @@ -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 diff --git a/test/Test/TypeRep/MapProperty.hs b/test/Test/TypeRep/MapProperty.hs --- a/test/Test/TypeRep/MapProperty.hs +++ b/test/Test/TypeRep/MapProperty.hs @@ -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" diff --git a/typerep-map.cabal b/typerep-map.cabal --- a/typerep-map.cabal +++ b/typerep-map.cabal @@ -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