From 34a60b98815637dab35225ddbf95f249323ab800 Mon Sep 17 00:00:00 2001 From: jcmartin Date: Mon, 18 Nov 2024 19:49:36 -0800 Subject: [PATCH 1/5] Added instances for Data.Vector.Strict. Handling of DoNotUnbox types of Data.Vector.Unbox. --- src/Data/Store/Internal.hs | 23 +++++++++++++++++++++++ src/Data/Store/TH/Internal.hs | 12 ++++++++++-- 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs index 9969c0b..3eba3b6 100644 --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -6,11 +6,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes#-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -116,6 +118,11 @@ import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as MSV +import qualified Data.Vector.Unboxed as UV +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as SCV +import qualified Data.Vector.Strict.Mutable as MSCV +#endif import Data.Void import Data.Word import Foreign.C.Types () @@ -379,6 +386,13 @@ instance Store a => Store (V.Vector a) where poke = pokeSequence peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write +#ifdef MIN_VERSION_vector(0,13,2) +instance Store a => Store (SCV.Vector a) where + size = sizeSequence + poke = pokeSequence + peek = SCV.unsafeFreeze =<< peekMutableSequence MSCV.new MSCV.write +#endif + instance Storable a => Store (SV.Vector a) where size = VarSize $ \x -> sizeOf (undefined :: Int) + @@ -777,6 +791,15 @@ instance Store a => Store (Last a) instance Store a => Store (Maybe a) instance Store a => Store (Const a b) +#if MIN_VERSION_vector(0,13,2) +instance Store a => Store (UV.DoNotUnboxLazy a) +deriving instance Generic (UV.DoNotUnboxLazy a) +instance Store a => Store (UV.DoNotUnboxStrict a) +deriving instance Generic (UV.DoNotUnboxStrict a) +instance Store a => Store (UV.DoNotUnboxNormalForm a) +deriving instance Generic (UV.DoNotUnboxNormalForm a) +#endif + ------------------------------------------------------------------------ -- Instances generated by TH diff --git a/src/Data/Store/TH/Internal.hs b/src/Data/Store/TH/Internal.hs index cbb06f1..087b3d5 100644 --- a/src/Data/Store/TH/Internal.hs +++ b/src/Data/Store/TH/Internal.hs @@ -363,8 +363,12 @@ deriveManyStoreUnboxVector = do Nothing -> do reportWarning $ "No Unbox instance found for " ++ pprint headTy return ([], ty) - Just (TypeclassInstance cs (AppT _ ty') _) -> - return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty') + Just (TypeclassInstance cs (AppT _ ty') _) -> case ty' of + AppT (ConT conName) arg -> + if nameBase conName `elem` doNotUnboxConstructors + then return ([AppT (ConT ''Store) arg], AppT (ConT ''UV.Vector) ty') + else return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty') + _ -> return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty') Just _ -> fail "Impossible case" deriveStore preds ty' cons _ -> fail "impossible case in deriveManyStoreUnboxVector" @@ -404,6 +408,10 @@ getUnboxInfo = do skippedUnboxConstructors :: [String] skippedUnboxConstructors = ["MV_UnboxAs", "V_UnboxAs", "MV_UnboxViaPrim", "V_UnboxViaPrim"] +-- See issue #179 +doNotUnboxConstructors :: [String] +doNotUnboxConstructors = ["DoNotUnboxLazy","DoNotUnboxStrict","DoNotUnboxNormalForm"] + ------------------------------------------------------------------------ -- Utilities From 70d922114bcc5ab88c747fd77f7d7908a43d73ec Mon Sep 17 00:00:00 2001 From: jcmartin Date: Mon, 18 Nov 2024 20:13:31 -0800 Subject: [PATCH 2/5] Added tests for Strict Vector and new DoNotUnbox types introduced in vector-0.13.2.0 --- src/Data/Store/Internal.hs | 2 +- test/Allocations.hs | 7 +++++++ test/Data/StoreSpec.hs | 38 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 46 insertions(+), 1 deletion(-) diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs index 3eba3b6..923fcd1 100644 --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -386,7 +386,7 @@ instance Store a => Store (V.Vector a) where poke = pokeSequence peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write -#ifdef MIN_VERSION_vector(0,13,2) +#if MIN_VERSION_vector(0,13,2) instance Store a => Store (SCV.Vector a) where size = sizeSequence poke = pokeSequence diff --git a/test/Allocations.hs b/test/Allocations.hs index dfe8083..c999f05 100644 --- a/test/Allocations.hs +++ b/test/Allocations.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -14,6 +15,9 @@ import qualified Data.Set as Set import qualified Data.Map.Strict as Map import qualified Data.Store as Store import qualified Data.Vector as Boxed +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector as BoxedStrict +#endif import qualified Data.Vector.Serialize () import qualified Data.Vector.Storable as Storable import Text.Printf @@ -29,6 +33,9 @@ weighing :: Weigh () weighing = do fortype "[Int]" (\n -> replicate n 0 :: [Int]) fortype "Boxed Vector Int" (\n -> Boxed.replicate n 0 :: Boxed.Vector Int) +#if MIN_VERSION_vector(0,13,2) + fortype "Boxed Strict Vector Int" (\n -> BoxedStrict.replicate n 0 :: BoxedStrict.Vector Int) +#endif fortype "Storable Vector Int" (\n -> Storable.replicate n 0 :: Storable.Vector Int) fortype "Set Int" (Set.fromDistinctAscList . ints) diff --git a/test/Data/StoreSpec.hs b/test/Data/StoreSpec.hs index b3b9cd5..a630804 100644 --- a/test/Data/StoreSpec.hs +++ b/test/Data/StoreSpec.hs @@ -53,6 +53,9 @@ import qualified Data.Vector as V import qualified Data.Vector.Primitive as PV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Unboxed as UV +#if MIN_VERSION_vector(0,13,2) +import qualified Data.Vector.Strict as SCV +#endif import Data.Word import Foreign.C.Types import Foreign.Ptr @@ -178,6 +181,21 @@ $(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ] f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] concat <$> mapM f ns) +-- Instances for DoNotUnbox types introduced in vector-0.13.2.0 +#if MIN_VERSION_vector(0,13,2) +$(do let ns = [ ''UV.DoNotUnboxLazy, ''UV.DoNotUnboxStrict, ''UV.DoNotUnboxNormalForm ] + f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] + concat <$> mapM f ns) + +deriving instance Eq a => Eq (UV.DoNotUnboxLazy a) +deriving instance Eq a => Eq (UV.DoNotUnboxNormalForm a) +deriving instance Eq a => Eq (UV.DoNotUnboxStrict a) + +deriving instance Show a => Show (UV.DoNotUnboxLazy a) +deriving instance Show a => Show (UV.DoNotUnboxNormalForm a) +deriving instance Show a => Show (UV.DoNotUnboxStrict a) +#endif + instance Monad m => Serial m Any where series = fmap Any series @@ -202,6 +220,11 @@ instance (Monad m, Serial m a, Storable a) => Serial m (SV.Vector a) where instance (Monad m, Serial m a) => Serial m (V.Vector a) where series = fmap V.fromList series +#if MIN_VERSION_vector(0,13,2) +instance (Monad m, Serial m a) => Serial m (SCV.Vector a) where + series = fmap SCV.fromList series +#endif + instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where series = fmap mapFromList series @@ -395,6 +418,12 @@ spec = do $(smallcheckManyStore verbose 4 [ [t| SV.Vector Int8 |] , [t| V.Vector Int8 |] +#if MIN_VERSION_vector(0,13,2) + , [t| SCV.Vector Int8 |] + , [t| UV.DoNotUnboxLazy Int8 |] + , [t| UV.DoNotUnboxStrict Int8 |] + , [t| UV.DoNotUnboxNormalForm Int8 |] +#endif , [t| SerialRatio Int8 |] , [t| Complex Int8 |] , [t| Dual Int8 |] @@ -406,6 +435,12 @@ spec = do , [t| Either Int8 Int8 |] , [t| SV.Vector Int64 |] , [t| V.Vector Int64 |] +#if MIN_VERSION_vector(0,13,2) + , [t| SCV.Vector Int64 |] + , [t| UV.DoNotUnboxLazy Int64 |] + , [t| UV.DoNotUnboxStrict Int64 |] + , [t| UV.DoNotUnboxNormalForm Int64 |] +#endif , [t| SerialRatio Int64 |] , [t| Complex Int64 |] , [t| Dual Int64 |] @@ -445,6 +480,9 @@ spec = do assertRoundtrip False $ BS.drop 3 $ BS.take 3 "Hello world!" assertRoundtrip False $ SV.drop 3 $ SV.take 3 (SV.fromList [1..10] :: SV.Vector Int32) assertRoundtrip False $ UV.drop 3 $ UV.take 3 (UV.fromList [1..10] :: UV.Vector Word8) +#if MIN_VERSION_vector(0,13,2) + assertRoundtrip False $ SCV.drop 3 $ SCV.take 3 (SCV.fromList [1..10] :: SCV.Vector Word8) +#endif (return () :: IO ()) it "StaticSize roundtrips" $ do let x :: StaticSize 17 BS.ByteString From c6ee3145bfd2291cd619219bb80bea6181c182b6 Mon Sep 17 00:00:00 2001 From: jcmartin Date: Mon, 18 Nov 2024 20:15:21 -0800 Subject: [PATCH 3/5] Bump version from 0.7.18 to 0.7.19 --- package.yaml | 2 +- store.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index 2d1e60c..cbeb4d4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: store -version: "0.7.18" +version: "0.7.19" synopsis: Fast binary serialization maintainer: Michael Sloan license: MIT diff --git a/store.cabal b/store.cabal index f58557e..6775481 100644 --- a/store.cabal +++ b/store.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: store -version: 0.7.18 +version: 0.7.19 synopsis: Fast binary serialization category: Serialization, Data homepage: https://github.com/mgsloan/store#readme From e031b89f81495334c6dc27bb108dda076a31c10d Mon Sep 17 00:00:00 2001 From: jcmartin Date: Mon, 18 Nov 2024 20:18:25 -0800 Subject: [PATCH 4/5] Update changelog to reflect new compatibility with vector-0.13.2.0 --- ChangeLog.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 92b9d7c..cf2c487 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # ChangeLog +## 0.7.19 + +* Adds support for `vector-0.13.2.0`. See [#179][]. + +[#174]: https://github.com/mgsloan/store/issues/179 + ## 0.7.16 * Adds support for `vector-0.13.0.0`. See [#174][]. From 1bf59ea022cb8a526b8782a431040ee55476c513 Mon Sep 17 00:00:00 2001 From: jcmartin Date: Mon, 18 Nov 2024 23:38:10 -0800 Subject: [PATCH 5/5] Removed the orphan instances of Generic and instead use deriving newtype --- src/Data/Store/Internal.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs index 923fcd1..bdd9099 100644 --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -792,12 +793,9 @@ instance Store a => Store (Maybe a) instance Store a => Store (Const a b) #if MIN_VERSION_vector(0,13,2) -instance Store a => Store (UV.DoNotUnboxLazy a) -deriving instance Generic (UV.DoNotUnboxLazy a) -instance Store a => Store (UV.DoNotUnboxStrict a) -deriving instance Generic (UV.DoNotUnboxStrict a) -instance Store a => Store (UV.DoNotUnboxNormalForm a) -deriving instance Generic (UV.DoNotUnboxNormalForm a) +deriving newtype instance Store a => Store (UV.DoNotUnboxLazy a) +deriving newtype instance Store a => Store (UV.DoNotUnboxStrict a) +deriving newtype instance Store a => Store (UV.DoNotUnboxNormalForm a) #endif ------------------------------------------------------------------------