diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # ChangeLog +## 0.7.10 + +* Adds `Store` instances for all serializable datatypes exported by + the `time` library. See [#158]. + +[#158]: https://github.com/mgsloan/store/issues/158 + +## 0.7.9 + +* Attempts to fix build on ghc-7.8.4. See [#157]. + +[#157]: https://github.com/mgsloan/store/issues/157 + ## 0.7.8 * Adds a `Store` instance for `Natural`. See [#154][]. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -24,7 +24,6 @@ import Data.Word import GHC.Generics --- TODO: add packer #if COMPARISON_BENCH import qualified Data.Binary as Binary import qualified Data.Serialize as Cereal @@ -160,8 +159,6 @@ benchDecode :: Ctx a => a -> Benchmark benchDecode = benchDecode' "" --- TODO: comparison bench for decode - benchDecode' :: forall a. Ctx a => String -> a -> Benchmark #if COMPARISON_BENCH benchDecode' prefix x0 = @@ -234,8 +231,6 @@ poke (SSM2 x) = poke (1 :: Word8) >> poke x poke (SSM3 x) = poke (2 :: Word8) >> poke x poke (SSM4 x) = poke (3 :: Word8) >> poke x - --- TODO: add TH generation of the above, and add LargeSum / LargeProduct cases #if COMPARISON_BENCH instance Binary.Binary SmallProduct diff --git a/src/Data/Store/Impl.hs b/src/Data/Store/Impl.hs --- a/src/Data/Store/Impl.hs +++ b/src/Data/Store/Impl.hs @@ -39,8 +39,6 @@ ------------------------------------------------------------------------ -- Store class --- TODO: write down more elaborate laws - -- | The 'Store' typeclass provides efficient serialization and -- deserialization to raw pointer addresses. -- @@ -261,9 +259,6 @@ {-# INLINE gpeek #-} -- The machinery for sum types is why UndecidableInstances is necessary. - --- FIXME: check that this type level stuff dosen't get turned into --- costly runtime computation instance (FitsInByte (SumArity (a :+: b)), GStoreSizeSum 0 (a :+: b)) => GStoreSize (a :+: b) where diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -109,6 +109,7 @@ import qualified Data.Text.Foreign as T import qualified Data.Text.Internal as T import qualified Data.Time as Time +import qualified Data.Time.Clock.TAI as Time import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV @@ -120,13 +121,6 @@ import Foreign.Ptr (plusPtr, minusPtr) import Foreign.Storable (Storable, sizeOf) import GHC.Generics (Generic) -#ifdef INTEGER_GMP -import qualified GHC.Integer.GMP.Internals as I -import GHC.Types (Int (I#)) -#else -import GHC.Types (Word (W#)) -import qualified GHC.Integer.Simple.Internals as I -#endif import GHC.Real (Ratio(..)) import GHC.TypeLits import Instances.TH.Lift () @@ -139,6 +133,24 @@ import Prelude import TH.Derive +#if MIN_VERSION_time(1,8,0) +import qualified Data.Time.Clock.System as Time +#endif +#if MIN_VERSION_time(1,9,0) +import qualified Data.Time.Format.ISO8601 as Time +#endif +#if MIN_VERSION_time(1,11,0) +import qualified Data.Time.Calendar.Quarter as Time +#endif + +#ifdef INTEGER_GMP +import qualified GHC.Integer.GMP.Internals as I +import GHC.Types (Int (I#)) +#else +import GHC.Types (Word (W#)) +import qualified GHC.Integer.Simple.Internals as I +#endif + -- Conditional import to avoid warning #ifdef INTEGER_GMP #if MIN_VERSION_integer_gmp(1,0,0) @@ -301,26 +313,7 @@ f <$> peek {-# INLINE peekOrdMapWith #-} -{- ------------------------------------------------------------------------ --- Utilities for defining list-like 'Store' instances in terms of Foldable - --- | Implement 'size' for a 'Foldable' of 'Store' instances. Note that --- this assumes the extra 'Foldable' structure is discardable - this --- only serializes the elements. -sizeListLikeFoldable :: forall t a. (Foldable t, Store a) => Size (t a) -sizeListLikeFoldable = VarSize $ \t -> - case size :: Size e of - ConstSize n -> n * length x + sizeOf (undefined :: Int) - VarSize f -> foldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) -{-# INLINE sizeSequence #-} - -pokeListLikeFoldable :: forall t a. Foldable t => t a -> Poke () -pokeListLikeFoldable x = do - poke (length x) --} - ------------------------------------------------------------------------- -- Utilities for implementing 'Store' instances for list-like mutable things -- | Implementation of peek for mutable sequences. The user provides a @@ -430,14 +423,10 @@ return (SBS.SBS array) instance Store LBS.ByteString where - -- FIXME: faster conversion? Is this ever going to be a problem? - -- - -- I think on 64 bit systems, Int will have 64 bits. On 32 bit - -- systems, we'll never exceed the range of Int by this conversion. size = VarSize $ \x -> sizeOf (undefined :: Int) + fromIntegral (LBS.length x) - -- FIXME: more efficient implementation that avoids the double copy + -- TODO: more efficient implementation that avoids the double copy poke = poke . LBS.toStrict peek = fmap LBS.fromStrict peek @@ -457,9 +446,6 @@ ------------------------------------------------------------------------ -- Known size instances --- TODO: this doesn't scale nicely to 'Text'. Force it to be byte size? --- 'StaticByteSize'? - newtype StaticSize (n :: Nat) a = StaticSize { unStaticSize :: a } deriving (Eq, Show, Ord, Data, Typeable, Generic) @@ -482,7 +468,6 @@ instance KnownNat n => Store (StaticSize n BS.ByteString) where size = ConstSize (fromInteger (natVal (Proxy :: Proxy n))) poke (StaticSize x) = do - -- TODO: worth it to put an assert here? let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x pokeFromForeignPtr sourceFp sourceOffset sourceLength peek = do @@ -564,13 +549,11 @@ peek = peekSet instance (A.Ix i, Store i, Store e) => Store (A.Array i e) where - -- TODO: Speed up poke and peek size = sizeArray poke = pokeArray peek = peekArray instance (A.Ix i, A.IArray A.UArray e, Store i, Store e) => Store (A.UArray i e) where - -- TODO: Speed up poke and peek size = sizeArray poke = pokeArray peek = peekArray @@ -724,15 +707,6 @@ then peekException "Encountered negative integer when expecting a Natural" else return $ fromIntegral x --- instance Store GHC.Fingerprint.Types.Fingerprint where - -instance Store (Fixed a) where - size = contramap (\(MkFixed x) -> x) (size :: Size Integer) - poke (MkFixed x) = poke x - peek = MkFixed <$> peek - --- instance Store a => Store (Tree a) where - ------------------------------------------------------------------------ -- Other instances @@ -752,30 +726,15 @@ -- Similarly, manual implementation due to no Generic instance for -- Complex and Identity in GHC-7.10 and earlier. -instance Store a => Store (Complex a) where - size = combineSize (\(x :+ _) -> x) (\(_ :+ y) -> y) - poke (x :+ y) = poke (x, y) - peek = uncurry (:+) <$> peek - -instance Store a => Store (Identity a) where - size = contramap (\(Identity x) -> x) size - poke (Identity x) = poke x - peek = Identity <$> peek - -instance Store Time.Day where - size = contramap Time.toModifiedJulianDay (size :: Size Integer) - poke = poke . Time.toModifiedJulianDay - peek = Time.ModifiedJulianDay <$> peek - instance Store Time.DiffTime where - size = contramap (realToFrac :: Time.DiffTime -> Pico) (size :: Size Pico) - poke = (poke :: Pico -> Poke ()) . realToFrac - peek = Time.picosecondsToDiffTime <$> peek + size = contramap (realToFrac :: Time.DiffTime -> Pico) size + poke = poke . (realToFrac :: Time.DiffTime -> Pico) + peek = (realToFrac :: Pico -> Time.DiffTime) <$> peek -instance Store Time.UTCTime where - size = combineSize Time.utctDay Time.utctDayTime - poke (Time.UTCTime day time) = poke (day, time) - peek = uncurry Time.UTCTime <$> peek +instance Store Time.NominalDiffTime where + size = contramap (realToFrac :: Time.NominalDiffTime -> Pico) size + poke = poke . (realToFrac :: Time.NominalDiffTime -> Pico) + peek = (realToFrac :: Pico -> Time.NominalDiffTime) <$> peek instance Store () instance Store a => Store (Dual a) @@ -786,19 +745,48 @@ instance Store a => Store (Maybe a) instance Store a => Store (Const a b) --- FIXME: have TH deriving handle unboxed fields? - ------------------------------------------------------------------------ -- Instances generated by TH $($(derive [d| - -- TODO - -- instance Deriving (Store ()) + instance Store a => Deriving (Store (Complex a)) + instance Store a => Deriving (Store (Identity a)) + instance Deriving (Store All) instance Deriving (Store Any) instance Deriving (Store Void) instance Deriving (Store Bool) instance (Store a, Store b) => Deriving (Store (Either a b)) + + instance Deriving (Store (Fixed a)) + + instance Deriving (Store Time.AbsoluteTime) + instance Deriving (Store Time.Day) + instance Deriving (Store Time.LocalTime) + instance Deriving (Store Time.TimeOfDay) + instance Deriving (Store Time.TimeZone) + instance Deriving (Store Time.UTCTime) + instance Deriving (Store Time.UniversalTime) + instance Deriving (Store Time.ZonedTime) + instance Deriving (Store Time.TimeLocale) + +#if MIN_VERSION_time(1,8,0) + instance Deriving (Store Time.SystemTime) +#endif + +#if MIN_VERSION_time(1,9,0) + instance Deriving (Store Time.CalendarDiffDays) + instance Deriving (Store Time.CalendarDiffTime) + instance Deriving (Store Time.FormatExtension) +#endif + +#if MIN_VERSION_time(1,11,0) + instance Deriving (Store Time.DayOfWeek) + instance Deriving (Store Time.FirstWeekType) + instance Deriving (Store Time.Quarter) + instance Deriving (Store Time.QuarterOfYear) +#endif + |])) -- TODO: higher arities? Limited now by Generics instances for tuples @@ -832,7 +820,6 @@ $(deriveManyStorePrimVector) $(reifyManyWithoutInstances ''Store [''ModName, ''NameSpace, ''PkgName] (const True) >>= --- mapM (\name -> deriveStore [] (ConT name) .dtCons =<< reifyDataType name)) mapM (\name -> return (deriveGenericInstance [] (ConT name)))) -- Explicit definition needed because in template-haskell <= 2.9 (GHC @@ -877,5 +864,4 @@ #endif $(reifyManyWithoutInstances ''Store [''Info] (const True) >>= --- mapM (\name -> deriveStore [] (ConT name) .dtCons =<< reifyDataType name)) mapM (\name -> return (deriveGenericInstance [] (ConT name)))) diff --git a/src/Data/Store/TH/Internal.hs b/src/Data/Store/TH/Internal.hs --- a/src/Data/Store/TH/Internal.hs +++ b/src/Data/Store/TH/Internal.hs @@ -195,18 +195,6 @@ pokeTag ix = noBindS [| poke (ix :: $(conT tagType)) |] pokeField (fn, _) = noBindS [| poke $(varE fn) |] --- FIXME: make this work even when there are too many fields - --- FIXME: make the ConstSize stuff explicit in the API. Have an option --- that always errors at runtime if it isn't ConstSize? - --- TODO: It would be really awesome, though a bit tricky, to know at --- compile time if we have a static size. - --- TODO: make sure that this tends to optimize even with tons of fields. --- It should also optimize when some fields are known to be , but others --- are unknown (determined by polymorphic var) - {- What the generated code looks like data Foo = Foo Int Double Float diff --git a/src/Data/Store/TypeHash/Internal.hs b/src/Data/Store/TypeHash/Internal.hs --- a/src/Data/Store/TypeHash/Internal.hs +++ b/src/Data/Store/TypeHash/Internal.hs @@ -64,7 +64,6 @@ instance Lift TypeHash where lift = staticByteStringExp . unStaticSize . unTypeHash --- TODO: move into th-reify-many reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)] diff --git a/src/Data/Store/Version.hs b/src/Data/Store/Version.hs --- a/src/Data/Store/Version.hs +++ b/src/Data/Store/Version.hs @@ -105,7 +105,6 @@ Nothing -> return () Just expectedHash -> do let shownType = showsQualTypeRep (vcRenames vc) 0 (typeRep proxy) "" - -- FIXME: sanitize expected and handle null path <- storeVersionedPath expectedHash if hashb64 == expectedHash then writeVersionInfo path shownType info diff --git a/store.cabal b/store.cabal --- a/store.cabal +++ b/store.cabal @@ -4,14 +4,14 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2b5f970ccccd93023ea3a855fe64f3795f9150e050cc73dd8abadc088320a0a4 +-- hash: 49d04753317b8547f1c577aa466486464ac89127477c99f27fa87ff973f90176 name: store -version: 0.7.9 +version: 0.7.10 synopsis: Fast binary serialization category: Serialization, Data -homepage: https://github.com/fpco/store#readme -bug-reports: https://github.com/fpco/store/issues +homepage: https://github.com/mgsloan/store#readme +bug-reports: https://github.com/mgsloan/store/issues maintainer: Michael Sloan copyright: 2016 FP Complete license: MIT @@ -23,7 +23,7 @@ source-repository head type: git - location: https://github.com/fpco/store + location: https://github.com/mgsloan/store flag comparison-bench manual: True diff --git a/test/Data/StoreSpec.hs b/test/Data/StoreSpec.hs --- a/test/Data/StoreSpec.hs +++ b/test/Data/StoreSpec.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString.Short as SBS import Data.Complex (Complex(..)) import Data.Containers (mapFromList, setFromList) +import Data.Fixed (Pico) import Data.Generics (listify) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) @@ -33,9 +34,6 @@ import qualified Data.List.NonEmpty as NE import Data.Map (Map) import Data.Monoid -#if !MIN_VERSION_primitive(0,7,0) -import Data.Primitive.Types (Addr) -#endif import Data.Proxy (Proxy(..)) import Data.Sequence (Seq) import Data.Sequences (fromList) @@ -49,6 +47,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time +import qualified Data.Time.Clock.TAI as Time import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Primitive as PV @@ -66,12 +65,26 @@ import Network.Socket import Numeric.Natural (Natural) import Prelude -import System.Clock (TimeSpec) +import System.Clock (TimeSpec(..)) import System.Posix.Types import Test.Hspec hiding (runIO) import Test.SmallCheck.Series import TH.Utilities (unAppsT) +#if !MIN_VERSION_primitive(0,7,0) +import Data.Primitive.Types (Addr) +#endif + +#if MIN_VERSION_time(1,8,0) +import qualified Data.Time.Clock.System as Time +#endif +#if MIN_VERSION_time(1,9,0) +import qualified Data.Time.Format.ISO8601 as Time +#endif +#if MIN_VERSION_time(1,11,0) +import qualified Data.Time.Calendar.Quarter as Time +#endif + #if !MIN_VERSION_smallcheck(1,2,0) import Data.Void (Void) #endif @@ -79,9 +92,6 @@ ------------------------------------------------------------------------ -- Instances for base types --- TODO: should be possible to do something clever where it only defines --- instances that don't already exist. For now, just doing it manually. - addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++ @@ -158,32 +168,6 @@ series = fmap PV.fromList series |] concat <$> mapM f (filter (\ty -> length (unAppsT ty) == 1) tys)) -{- --- Instances for TH are not currently needed, because the tests for --- serialization roundtripping are disabled due to Bytes' Eq instance, --- see issue #150. - --- Needs to be done manually because in GHC 7.8's TH, NameFlavour uses --- unboxed values and cannot use generic deriving. So we skip having an --- instance for it. -instance Monad m => Serial m Name where series = fmap mkName series - -instance Monad m => Serial m Bytes where - series = fmap ((\(BS.PS p o l) -> Bytes p (fromIntegral o) (fromIntegral l)) . BS.pack) series - --- Serial instances for (Generic a) types. - --- FIXME: generating for TH instances is probably just adding --- unnecessary compiletime + runtime overhead. -$(do thNames <- reifyManyWithoutInstances - ''Serial - [''Info, ''Loc, ''ModName, ''PkgName, ''NameSpace, ''OccName] - (`notElem` [''NameFlavour]) - let ns = [ ''Any, ''All ] ++ thNames - f n = [d| instance Monad m => Serial m $(conT n) |] - concat <$> mapM f ns) --} - $(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) @@ -256,6 +240,9 @@ instance Monad m => Serial m Time.DiffTime where series = Time.picosecondsToDiffTime <$> series +instance Monad m => Serial m Time.NominalDiffTime where + series = (realToFrac :: Integer -> Time.NominalDiffTime) <$> series + instance Monad m => Serial m Time.UTCTime where series = uncurry Time.UTCTime <$> (series >< series) @@ -271,6 +258,9 @@ series = generate (\_ -> []) #endif +instance Monad m => Serial m TimeSpec where + series = uncurry TimeSpec <$> (series >< series) + -- We define our own Serial instance for 'Ratio' because of newtype SerialRatio a = SerialRatio (Ratio a) @@ -331,7 +321,34 @@ #if MIN_VERSION_base(4,10,0) , [t| CTimer |] #endif - , [t| TimeSpec |] + +-- Assume the TH generated instances for Time work, to avoid defining +-- Serial instances. Also some lack Show / Eq. + + , [t| Time.AbsoluteTime |] + , [t| Time.Day |] + , [t| Time.LocalTime |] + , [t| Time.TimeOfDay |] + , [t| Time.TimeZone |] + , [t| Time.UTCTime |] + , [t| Time.UniversalTime |] + , [t| Time.ZonedTime |] + , [t| Time.TimeLocale |] +#if MIN_VERSION_time(1,8,0) + , [t| Time.SystemTime |] +#endif +#if MIN_VERSION_time(1,9,0) + , [t| Time.FormatExtension |] + , [t| Time.CalendarDiffDays |] + , [t| Time.CalendarDiffTime |] +#endif +#if MIN_VERSION_time(1,11,0) + , [t| Time.DayOfWeek |] + , [t| Time.FirstWeekType |] + , [t| Time.Quarter |] + , [t| Time.QuarterOfYear |] +#endif + ] omitTys <- (omitTys0 ++) <$> mapM (\ty -> [t| PV.Vector $(pure ty) |]) omitTys0 let f ty = isMonoType ty && ty `notElem` omitTys && null (listify isThName ty)