safecopy 0.10.0 → 0.10.1
raw patch · 5 files changed
+50/−89 lines, 5 filesdep −semigroupsdep ~base
Dependencies removed: semigroups
Dependency ranges changed: base
Files
- CHANGELOG.md +19/−0
- safecopy.cabal +5/−12
- src/Data/SafeCopy/Derive.hs +0/−43
- src/Data/SafeCopy/Instances.hs +0/−8
- src/Data/SafeCopy/SafeCopy.hs +26/−26
CHANGELOG.md view
@@ -1,3 +1,22 @@+0.10.0+======++This version replaces the default implementation of getCopy and putCopy+with a full implementation using GHC.Generics. Before these functions+simply serialized and deserialized their argument. Now they function+identically to the instances generated by deriveSafeCopy. This means+that embedded values with SafeCopy instances will be migrated properly,+and that you can replace template haskell with standalone deriving+instances such as "deriving instance SafeCopy Foo where kind = extension;+version = 3".++The one caveat is that the new default implementation of getCopy and+putCopy adds the constraint "Typeable a", so that it can build a set of+the subtypes that appear in a. This will only affect code that already+used the default instance, not code that used deriveSafeCopy or custom+SafeCopy instances. If you do run into this you can add a custom SafeCopy+instance with the old implementations mentioned above.+ 0.9.4 ===== - Support ghc-8.4.1
safecopy.cabal view
@@ -3,7 +3,7 @@ -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. -- The name of the package. Name: safecopy-Version: 0.10.0+Version: 0.10.1 Synopsis: Binary serialization with version control. Description: An extension to Data.Serialize with built-in version control. Homepage: https://github.com/acid-state/safecopy@@ -15,7 +15,7 @@ Build-type: Simple Extra-source-files: CHANGELOG.md Cabal-version: >=1.8-tested-with: GHC==8.0.2, GHC==8.2.1, GHC==8.4.1, GHC==8.6.5+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 Source-repository head type: git@@ -30,22 +30,19 @@ Hs-Source-Dirs: src/ -- Packages needed in order to build this package.- Build-depends: base >=4.5 && <5,+ Build-depends: base >=4.9 && <5, array < 0.6, cereal >= 0.5 && < 0.6, bytestring < 0.11, generic-data >= 0.3, containers >= 0.3 && < 0.7, old-time < 1.2,- template-haskell < 2.15,+ template-haskell < 2.16, text < 1.3, time < 1.10, transformers < 0.6, vector >= 0.10 && < 0.13 - if !impl(ghc > 8.0)- Build-Depends: semigroups >= 0.18 && < 0.19- -- Modules not exported by this package. Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy, Data.SafeCopy.Derive@@ -55,11 +52,7 @@ GHC-Options: -Wall - if(impl(ghc >= 7.2.1))- cpp-options: -DDEFAULT_SIGNATURES-- if(impl(ghc >= 7.1))- cpp-options: -DSAFE_HASKELL+ cpp-options: -DDEFAULT_SIGNATURES -DSAFE_HASKELL Test-suite instances Type: exitcode-stdio-1.0
src/Data/SafeCopy/Derive.hs view
@@ -10,14 +10,7 @@ import Data.Serialize (getWord8, putWord8, label) import Data.SafeCopy.SafeCopy -#if MIN_VERSION_template_haskell(2,8,0) import Language.Haskell.TH hiding (Kind)-#else-import Language.Haskell.TH hiding (Kind(..))-#endif-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad import Data.Maybe (fromMaybe) #ifdef __HADDOCK__@@ -228,9 +221,7 @@ tyVarName :: TyVarBndr -> Name tyVarName (PlainTV n) = n-#if MIN_VERSION_template_haskell(2,10,0) tyVarName (KindedTV n _) = n-#endif internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec] internalDeriveSafeCopy deriveType versionId kindName tyName = do@@ -240,37 +231,21 @@ internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec] internalDeriveSafeCopy' deriveType versionId kindName tyName info = do case info of-#if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD context _name tyvars _kind cons _derivs)-#else- TyConI (DataD context _name tyvars cons _derivs)-#endif | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ ". The datatype must have less than 256 constructors." | otherwise -> worker context tyvars (zip [0..] cons) -#if MIN_VERSION_template_haskell(2,11,0) TyConI (NewtypeD context _name tyvars _kind con _derivs) ->-#else- TyConI (NewtypeD context _name tyvars con _derivs) ->-#endif worker context tyvars [(0, con)] FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of-#if MIN_VERSION_template_haskell(2,11,0) DataInstD context _name ty _kind cons _derivs ->-#else- DataInstD context _name ty cons _derivs ->-#endif worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) -#if MIN_VERSION_template_haskell(2,11,0) NewtypeInstD context _name ty _kind con _derivs ->-#else- NewtypeInstD context _name ty con _derivs ->-#endif worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) return $ concat decs@@ -279,11 +254,7 @@ worker = worker' (conT tyName) worker' tyBase context tyvars cons = let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]-#if MIN_VERSION_template_haskell(2,10,0) safeCopyClass args = foldl appT (conT ''SafeCopy) args-#else- safeCopyClass args = classP ''SafeCopy args-#endif in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons@@ -305,21 +276,13 @@ FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of-#if MIN_VERSION_template_haskell(2,11,0) DataInstD context _name ty _kind cons _derivs-#else- DataInstD context _name ty cons _derivs-#endif | ty == tyIndex -> worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) | otherwise -> return [] -#if MIN_VERSION_template_haskell(2,11,0) NewtypeInstD context _name ty _kind con _derivs-#else- NewtypeInstD context _name ty con _derivs-#endif | ty == tyIndex -> worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] | otherwise ->@@ -331,11 +294,7 @@ typeNameStr = unwords $ map show (tyName:tyIndex') worker' tyBase context tyvars cons = let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]-#if MIN_VERSION_template_haskell(2,10,0) safeCopyClass args = foldl appT (conT ''SafeCopy) args-#else- safeCopyClass args = classP ''SafeCopy args-#endif in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons@@ -433,10 +392,8 @@ conSize (RecC _name recs) = length recs conSize InfixC{} = 2 conSize ForallC{} = error "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it."-#if MIN_VERSION_template_haskell(2,11,0) conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."-#endif conName :: Con -> Name conName (NormalC name _args) = name
src/Data/SafeCopy/Instances.hs view
@@ -35,15 +35,9 @@ import Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime) import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..)) import qualified Data.Tree as Tree-#if MIN_VERSION_base(4,7,0) import Data.Typeable hiding (Proxy)-#else-import Data.Typeable-#endif import Data.Word-#if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural)-#endif import System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..)) import qualified System.Time as OT import qualified Data.Vector as V@@ -172,10 +166,8 @@ getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Integer where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName-#if MIN_VERSION_base(4,8,0) instance SafeCopy Natural where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName-#endif -- | cereal change the formats for Float/Double in 0.5.* --
src/Data/SafeCopy/SafeCopy.hs view
@@ -1,21 +1,15 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE CPP #-}-#ifdef DEFAULT_SIGNATURES {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-#endif ----------------------------------------------------------------------------- -- |@@ -32,27 +26,24 @@ -- module Data.SafeCopy.SafeCopy where -import Data.Serialize- import Control.Monad-import Data.Int (Int32)-import Data.List--#ifdef DEFAULT_SIGNATURES import Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.State as State (evalStateT, modify, StateT) import qualified Control.Monad.Trans.State as State (get) import Control.Monad.Trans.RWS as RWS (evalRWST, modify, RWST, tell) import qualified Control.Monad.Trans.RWS as RWS (get) import Data.Bits (shiftR)+import Data.Int (Int32)+import Data.List import Data.Map as Map (Map, lookup, insert)+import Data.Serialize import Data.Set as Set (insert, member, Set) import Data.Typeable (Typeable, TypeRep, typeOf, typeRep) import Data.Word (Word8) import GHC.Generics import Generic.Data as G (Constructors, gconIndex, gconNum) import Unsafe.Coerce (unsafeCoerce)-#endif -- | The central mechanism for dealing with version control. --@@ -148,10 +139,10 @@ -- | The name of the type. This is only used in error message -- strings. errorTypeName :: Proxy a -> String+ default errorTypeName :: Typeable a => Proxy a -> String errorTypeName _ = show (typeRep (Proxy @a)) -#ifdef DEFAULT_SIGNATURES default putCopy :: (GPutCopy (Rep a) DatatypeInfo, Constructors a) => a -> Contained Put putCopy a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a @@ -194,6 +185,7 @@ instance (GPutFields f p, GPutFields g p) => GPutFields (f :*: g) p where gputFields p (a :*: b) = gputFields p a >> gputFields p b+ {-# INLINE gputFields #-} instance GPutFields f p => GPutFields (M1 S c f) p where gputFields p (M1 a) = gputFields p a@@ -204,17 +196,16 @@ getSafePutGeneric putCopy a {-# INLINE gputFields #-} -#if 1 -- This corresponds to ggetFields, but does it match deriveSafeCopy? instance GPutFields U1 p where gputFields _ _ = return ()-#else+{- -- This outputs the version tag for (), which is 1. instance (GPutFields (K1 R ()) p) => GPutFields U1 p where gputFields p _ = gputFields p (K1 () :: K1 R () p)-#endif+-} {-# INLINE gputFields #-} instance GPutFields V1 p where@@ -250,6 +241,7 @@ case _code p < sizeL of True -> L1 <$> ggetCopy @f (ConstructorInfo sizeL (_code p)) False -> R1 <$> ggetCopy @g (ConstructorInfo sizeR (_code p - sizeL))+ {-# INLINE ggetCopy #-} instance GGetFields f p => GGetCopy (M1 C c f) p where ggetCopy p = do@@ -265,6 +257,7 @@ fgetter <- ggetFields @f p ggetter <- ggetFields @g p return ((:*:) <$> fgetter <*> ggetter)+ {-# INLINE ggetFields #-} instance GGetFields f p => GGetFields (M1 S c f) p where ggetFields p = do@@ -320,7 +313,7 @@ -> a -> RWST () [Put] (Set TypeRep) PutM () getSafePutGeneric cput a- = checkConsistency proxy $+ = unpureCheckConsistency proxy $ case kindFromProxy proxy of Primitive -> tell [unsafeUnPack (cput $ asProxyType a proxy)] _ -> do reps <- RWS.get@@ -345,7 +338,6 @@ -- implementation of the putCopy method. putCopyDefault :: forall a. GSafeCopy a => a -> Contained Put putCopyDefault a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a-#endif -- constructGetterFromVersion :: SafeCopy a => Version a -> Kind (MigrateFrom (Reverse a)) -> Get (Get a) constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a)@@ -419,7 +411,7 @@ -- when serializing multiple values with the same version. See 'getSafeGet'. getSafePut :: forall a. SafeCopy a => PutM (a -> Put) getSafePut- = checkConsistency proxy $+ = unpureCheckConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) _ -> do put (versionFromProxy proxy)@@ -548,10 +540,18 @@ Extended sub_kind -> check sub_kind -- Verify that the SafeCopy instance is consistent.-checkConsistency :: (SafeCopy a, Monad m) => Proxy a -> m b -> m b+checkConsistency :: (SafeCopy a, Fail.MonadFail m) => Proxy a -> m b -> m b checkConsistency proxy ks = case consistentFromProxy proxy of- NotConsistent msg -> fail msg+ NotConsistent msg -> Fail.fail msg+ Consistent -> ks++-- | PutM doesn't have reasonable 'fail' implementation.+-- It just throws unpure exception anyway.+unpureCheckConsistency :: SafeCopy a => Proxy a -> b -> b+unpureCheckConsistency proxy ks+ = case consistentFromProxy proxy of+ NotConsistent msg -> error $ "unpureCheckConsistency: " ++ msg Consistent -> ks {-# INLINE computeConsistency #-}