safecopy 0.6.3 → 0.10.4.3
raw patch · 9 files changed
Files
- CHANGELOG.md +63/−0
- safecopy.cabal +72/−46
- src/Data/SafeCopy.hs +44/−4
- src/Data/SafeCopy/Derive.hs +132/−31
- src/Data/SafeCopy/Instances.hs +108/−17
- src/Data/SafeCopy/Internal.hs +7/−0
- src/Data/SafeCopy/SafeCopy.hs +351/−62
- test/generic.hs +281/−0
- test/instances.hs +114/−0
+ CHANGELOG.md view
@@ -0,0 +1,63 @@+0.10.4.3+--------++_Andreas Abel, 2025-08-27_++- Remove old code for GHC 7+- Tested with GHC 8.0 - 9.14 alpha1++0.10.4+======++Add a Typeable a superclass to SafeCopy. The previous version in effect+had the Typeable constraint anyway, this means less need to specify it.+The SafeCopy' type alias is now identical to SafeCopy. This should not+break any code except perhaps some GADT types that use "deriving Typeable".+These may need a standalone deriving instance.++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+ - Travis config for ghc-8.2.1+ - SafeCopy instance for Data.List.NonEmpty.NonEmpty++0.9.1+=====++ - fixed tests to work with QuickCheck-2.8.2+ - add SafeCopy instance for Word+ - updates for template-haskell 2.11+ - export some internal TH derivation helpers++0.9.0+=====++This version changes the way `Float` and `Double` are serialized to a+more compact format. Old data should be migrated automatically. As a+result, however, the `Float` and `Double` data serialized by this version can not be read+by older versions of `safecopy`.++This change originated as a modification to the way `cereal` 0.5 serializes `Float` and `Double`.++[https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced](https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced)++[https://github.com/GaloisInc/cereal/issues/35](https://github.com/GaloisInc/cereal/issues/35)
safecopy.cabal view
@@ -1,70 +1,96 @@--- safecopy.cabal auto-generated by cabal init. For additional--- options, see--- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.--- The name of the package.+Cabal-version: 1.18 Name: safecopy---- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version: 0.6.3---- A short (one-line) description of the package.+Version: 0.10.4.3 Synopsis: Binary serialization with version control.---- A longer description of the package. Description: An extension to Data.Serialize with built-in version control.---- URL for the project homepage or repository.-Homepage: http://acid-state.seize.it/safecopy---- The license under which the package is released.+Homepage: https://github.com/acid-state/safecopy License: PublicDomain---- The package author(s). Author: David Himmelstrup, Felipe Lessa---- An email address to which users can send suggestions, bug reports,--- and patches.-Maintainer: Lemmih <lemmih@gmail.com>---- A copyright notice.+Maintainer: Lemmih <lemmih@gmail.com>, David Fox <dsf@seereason.com> -- Copyright:- Category: Data, Parsing- Build-type: Simple --- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files:+Extra-doc-files: CHANGELOG.md --- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.6+tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2 Source-repository head- type: darcs- location: http://hub.darcs.net/Lemmih/safecopy+ type: git+ location: https://github.com/acid-state/safecopy.git Library- -- Modules exported by the library.+ Default-language: Haskell2010 Exposed-modules: Data.SafeCopy+ Data.SafeCopy.Internal Hs-Source-Dirs: src/ - -- Packages needed in order to build this package.- Build-depends: base >=4 && <5, array, cereal >= 0.3.1.0, bytestring, containers >= 0.3,- old-time, template-haskell, text, time+ -- Lower bounds are chosen to match LTS 7.24 (GHC 8.0)+ Build-depends: base >= 4.9 && < 5+ , array >= 0.5.1.1 && < 0.6+ , cereal >= 0.5.4.0 && < 0.6+ , bytestring >= 0.10.8.1 && < 0.13+ , generic-data >= 0.3.0.0 && < 2+ , containers >= 0.5.7.1 && < 1+ , old-time >= 1.1.0.3 && < 1.2+ , template-haskell >= 2.11.0.0 && < 2.25+ , text >= 1.2.2.2 && < 1.3 || >= 2.0 && < 2.2+ , time >= 1.6.0.1 && < 2+ , transformers >= 0.5.2.0 && < 0.7+ , vector >= 0.11.0.0 && < 0.14 - -- Modules not exported by this package.- Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy,+ Other-modules: Data.SafeCopy.Instances+ Data.SafeCopy.SafeCopy Data.SafeCopy.Derive - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.- -- Build-tools:- GHC-Options: -Wall - if(impl(ghc >= 7.2.1))- cpp-options: -DDEFAULT_SIGNATURES+ cpp-options: -DDEFAULT_SIGNATURES -DSAFE_HASKELL++Test-suite instances+ Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-is: instances.hs+ Hs-Source-Dirs: test/+ GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N+ Build-depends: base+ , array+ , cereal+ , containers+ , safecopy+ , template-haskell+ , time+ , vector+ -- new dependencies:+ , lens >= 4.7 && < 6+ , lens-action+ , tasty+ , tasty-quickcheck++Test-suite generic+ Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-is: generic.hs+ Hs-Source-Dirs: test/+ GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N+ Build-depends: base+ , bytestring+ , cereal+ , safecopy+ , HUnit
src/Data/SafeCopy.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+#ifdef SAFE_HASKELL+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.SafeCopy@@ -11,6 +16,8 @@ -- can change the definition and binary format of a type nested deep within -- other types without problems. --+-- = Migration+-- -- Consider this scenario. You want to store your contact list on disk -- and so write the following code: --@@ -44,8 +51,8 @@ -- getCopy = contain $ Contacts_v0 \<$\> safeGet -- --data Contact = Contact { name :: Name--- , address :: Address--- , phone :: Phone }+-- , address :: Address+-- , phone :: Phone } --instance SafeCopy Contact where -- putCopy Contact{..} = contain $ do safePut name; safePut address; safePut phone -- getCopy = contain $ Contact \<$\> safeGet \<*\> safeGet \<*\> safeGet@@ -69,29 +76,62 @@ -- With this, you reflect on your code and you are happy. You feel confident in the safety of -- your data and you know you can remove @Contacts_v0@ once you no longer wish to support -- that legacy format.+--+-- = Retiring Migrations+--+-- There may come a time when you have to remove @Contacts_v0@.+-- Perhaps it uses types you want to remove from your build to+-- decrease its size. Perhaps it has constraints such as @Enum@ which+-- are imposed on your new @Contacts@ type via the @SafeCopy@+-- instance.+--+-- In any case, if you are using @safecopy@ incombination with+-- @acid-state@, some care must be taken when removing @Contacts_v0@.+-- The following steps must be taken to add a new type and remove the old:+--+-- 1. Add the migration as described above.+-- 2. Run the server with the new migration on /all important data/. This+-- will cause the type to be modified in the running program.+-- 3. /Restart/ the server with the new migration on /all important data/. This+-- causes checkpoints to be written that only contain the new type.+-- 4. Remove the old type from your source code, changing the @kind@ of+-- the new type from @extension@ to @base@. Build and deploy.+--+-- If you omit any of these steps it is a certainty that you will+-- proceed happily with your development thinking all is grand, and+-- then when you go to deploy your live system the migration will fail.+ module Data.SafeCopy ( safeGet , safePut- , SafeCopy(version, kind, getCopy, putCopy, errorTypeName)+ , SafeCopy(version, kind, getCopy, putCopy, objectProfile, errorTypeName)+ , SafeCopy'+ , Profile(..) , Prim(..) , Migrate(..)+ , Reverse(..) , Kind , extension+ , extended_extension+ , extended_base+ , base , Contained , contain , Version -- * Template haskell functions , deriveSafeCopy+ , deriveSafeCopyIndexedType , deriveSafeCopySimple+ , deriveSafeCopySimpleIndexedType , deriveSafeCopyHappstackData+ , deriveSafeCopyHappstackDataIndexedType -- * Rarely used functions , getSafeGet , getSafePut , primitive- , base ) where import Data.SafeCopy.Instances ()
src/Data/SafeCopy/Derive.hs view
@@ -1,20 +1,16 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.SafeCopy.Derive- (- deriveSafeCopy- , deriveSafeCopySimple- , deriveSafeCopyHappstackData- ) where+{-# LANGUAGE TemplateHaskell, CPP #-} -import Data.Serialize (getWord8, putWord8)+module Data.SafeCopy.Derive where++import Data.Serialize (getWord8, putWord8, label) import Data.SafeCopy.SafeCopy -import Language.Haskell.TH hiding (Kind(..))-import Control.Applicative+import Language.Haskell.TH hiding (Kind) import Control.Monad import Data.Maybe (fromMaybe)-import Data.Typeable (Typeable, typeOf)+#ifdef __HADDOCK__ import Data.Word (Word8) -- Haddock+#endif -- | Derive an instance of 'SafeCopy'. --@@ -104,6 +100,9 @@ deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec] deriveSafeCopy = internalDeriveSafeCopy Normal +deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]+deriveSafeCopyIndexedType = internalDeriveSafeCopyIndexedType Normal+ -- | Derive an instance of 'SafeCopy'. The instance derived by -- this function is simpler than the one derived by -- 'deriveSafeCopy' in that we always use 'safePut' and@@ -156,6 +155,9 @@ deriveSafeCopySimple :: Version a -> Name -> Name -> Q [Dec] deriveSafeCopySimple = internalDeriveSafeCopy Simple +deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]+deriveSafeCopySimpleIndexedType = internalDeriveSafeCopyIndexedType Simple+ -- | Derive an instance of 'SafeCopy'. The instance derived by -- this function should be compatible with the instance derived -- by the module @Happstack.Data.SerializeTH@ of the@@ -203,40 +205,132 @@ deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec] deriveSafeCopyHappstackData = internalDeriveSafeCopy HappstackData +deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]+deriveSafeCopyHappstackDataIndexedType = internalDeriveSafeCopyIndexedType HappstackData+ data DeriveType = Normal | Simple | HappstackData forceTag :: DeriveType -> Bool forceTag HappstackData = True forceTag _ = False +#if MIN_VERSION_template_haskell(2,17,0)+tyVarName :: TyVarBndr s -> Name+tyVarName (PlainTV n _) = n+tyVarName (KindedTV n _ _) = n+#else+tyVarName :: TyVarBndr -> Name+tyVarName (PlainTV n) = n+tyVarName (KindedTV n _) = n+#endif+ internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec]-internalDeriveSafeCopy deriveType versionId kindName tyName- = do info <- reify tyName- case info of- TyConI (DataD context _name tyvars cons _derivs)- | 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)- TyConI (NewtypeD context _name tyvars con _derivs)- -> worker context tyvars [(0, con)]- _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)- where worker context tyvars cons- = let ty = foldl appT (conT tyName) [ varT var | PlainTV var <- tyvars ]- in (:[]) <$> instanceD (cxt $ [classP ''SafeCopy [varT var] | PlainTV var <- tyvars] ++ map return context)+internalDeriveSafeCopy deriveType versionId kindName tyName = do+ info <- reify tyName+ internalDeriveSafeCopy' deriveType versionId kindName tyName info++internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec]+internalDeriveSafeCopy' deriveType versionId kindName tyName info = do+ case info of+ TyConI (DataD context _name tyvars _kind cons _derivs)+ | 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)++ TyConI (NewtypeD context _name tyvars _kind con _derivs) ->+ worker context tyvars [(0, con)]++ FamilyI _ insts -> do+ decs <- forM insts $ \inst ->+ case inst of+#if MIN_VERSION_template_haskell(2,15,0)+ DataInstD context _ nty _kind cons _derivs ->+ worker' (return nty) context [] (zip [0..] cons)++ NewtypeInstD context _ nty _kind con _derivs ->+ worker' (return nty) context [] [(0, con)]+#else+ DataInstD context _name ty _kind cons _derivs ->+ worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)++ NewtypeInstD context _name ty _kind con _derivs ->+ worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]+#endif+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)+ return $ concat decs+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)+ where+ worker = worker' (conT tyName)+ worker' tyBase context tyvars cons =+ let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]+ safeCopyClass args = foldl appT (conT ''SafeCopy) args+ in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons- , mkGetCopy deriveType tyName cons+ , mkGetCopy deriveType (show tyName) cons , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] , valD (varP 'kind) (normalB (varE kindName)) [] , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []] ] +internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]+internalDeriveSafeCopyIndexedType deriveType versionId kindName tyName tyIndex' = do+ info <- reify tyName+ internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info++internalDeriveSafeCopyIndexedType' :: DeriveType -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec]+internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info = do+ tyIndex <- mapM conT tyIndex'+ case info of+ FamilyI _ insts -> do+ decs <- forM insts $ \inst ->+ case inst of+#if MIN_VERSION_template_haskell(2,15,0)+ DataInstD context _ nty _kind cons _derivs+ | nty == foldl AppT (ConT tyName) tyIndex ->+ worker' (return nty) context [] (zip [0..] cons)+#else+ DataInstD context _name ty _kind cons _derivs+ | ty == tyIndex ->+ worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)+#endif+ | otherwise ->+ return []++#if MIN_VERSION_template_haskell(2,15,0)+ NewtypeInstD context _ nty _kind con _derivs+ | nty == foldl AppT (ConT tyName) tyIndex ->+ worker' (return nty) context [] [(0, con)]+#else+ NewtypeInstD context _name ty _kind con _derivs+ | ty == tyIndex ->+ worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]+#endif+ | otherwise ->+ return []+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)+ return $ concat decs+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)+ where+ typeNameStr = unwords $ map show (tyName:tyIndex')+ worker' tyBase context tyvars cons =+ let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]+ safeCopyClass args = foldl appT (conT ''SafeCopy) args+ in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context)+ (conT ''SafeCopy `appT` ty)+ [ mkPutCopy deriveType cons+ , mkGetCopy deriveType typeNameStr cons+ , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []+ , valD (varP 'kind) (normalB (varE kindName)) []+ , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []]+ ]+ mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ mkPutCopy deriveType cons = funD 'putCopy $ map mkPutClause cons where manyConstructors = length cons > 1 || forceTag deriveType mkPutClause (conNumber, con)- = do putVars <- replicateM (conSize con) (newName "arg")+ = do putVars <- mapM (\n -> newName ("a" ++ show n)) [1..conSize con] (putFunsDecs, putFuns) <- case deriveType of Normal -> mkSafeFunctions "safePut_" 'getSafePut con _ -> return ([], const 'safePut)@@ -248,9 +342,11 @@ [ noBindS $ varE 'return `appE` tupE [] ]) clause [putClause] (normalB putCopyBody) [] -mkGetCopy :: DeriveType -> Name -> [(Integer, Con)] -> DecQ-mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` getCopyBody) []+mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ+mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` mkLabel) [] where+ mkLabel = varE 'label `appE` litE (stringL labelString) `appE` getCopyBody+ labelString = tyName ++ ":" getCopyBody = case cons of [(_, con)] | not (forceTag deriveType) -> mkGetBody con@@ -289,10 +385,13 @@ return ( bindS (varP funVar) (varE baseFun) : ds , (t, funVar) : fs ) where found = any ((== t) . fst) fs+ finish+ :: [(Type, Type)] -- "dictionary" from synonyms(or not) to real types+ -> ([StmtQ], [(Type, Name)]) -- statements+ -> ([StmtQ], Type -> Name) -- function body and name-generator finish typeList (ds, fs) = (reverse ds, getName) where getName typ = fromMaybe err $ lookup typ typeList >>= flip lookup fs err = error "mkSafeFunctions: never here"- -- We can't use a Data.Map because Type isn't a member of Ord =/... -- | Follow type synonyms. This allows us to see, for example, -- that @[Char]@ and @String@ are the same type and we just need@@ -313,7 +412,9 @@ conSize (NormalC _name args) = length args conSize (RecC _name recs) = length recs conSize InfixC{} = 2-conSize ForallC{} = error "Found complex constructor. Cannot derive SafeCopy for it."+conSize ForallC{} = error "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it."+conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."+conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." conName :: Con -> Name conName (NormalC name _args) = name@@ -330,7 +431,7 @@ typeName :: Type -> String typeName (VarT name) = nameBase name typeName (ConT name) = nameBase name-typeName (TupleT n) = '(' : replicate (n-1) ',' ++ ")"+typeName (TupleT n) = "Tuple" ++ show n typeName ArrowT = "Arrow" typeName ListT = "List" typeName (AppT t u) = typeName t ++ typeName u
src/Data/SafeCopy/Instances.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Data.SafeCopy.Instances where import Data.SafeCopy.SafeCopy -import Control.Applicative import Control.Monad import qualified Data.Array as Array import qualified Data.Array.Unboxed as UArray@@ -17,6 +20,7 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.Ix+import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import Data.Ratio (Ratio, (%), numerator, denominator) import qualified Data.Sequence as Sequence@@ -31,10 +35,16 @@ import Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime) import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..)) import qualified Data.Tree as Tree-import Data.Typeable+import Data.Typeable hiding (Proxy) import Data.Word+import Numeric.Natural (Natural) import System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..)) import qualified System.Time as OT+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU instance SafeCopy a => SafeCopy (Prim a) where kind = primitive@@ -45,14 +55,22 @@ = contain $ unsafeUnPack (putCopy e) instance SafeCopy a => SafeCopy [a] where- getCopy = contain $- do n <- get- getSafeGet >>= replicateM n- putCopy lst- = contain $- do put (length lst)- getSafePut >>= forM_ lst+ getCopy = contain $ do+ n <- get+ g <- getSafeGet+ go g [] n+ where+ go :: Get a -> [a] -> Int -> Get [a]+ go _ as 0 = return (reverse as)+ go g as i = do x <- g+ x `seq` go g (x:as) (i - 1)+ putCopy lst = contain $ do put (length lst)+ getSafePut >>= forM_ lst+ errorTypeName = typeName1 +instance SafeCopy a => SafeCopy (NonEmpty.NonEmpty a) where+ getCopy = contain $ fmap NonEmpty.fromList safeGet+ putCopy = contain . safePut . NonEmpty.toList errorTypeName = typeName1 instance SafeCopy a => SafeCopy (Maybe a) where@@ -148,16 +166,60 @@ getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Integer where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName-instance SafeCopy Float where+instance SafeCopy Natural where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName++-- | cereal changed the formats for Float/Double in 0.5.*+--+-- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced+-- https://github.com/GaloisInc/cereal/issues/35+newtype CerealFloat040 = CerealFloat040 { unCerealFloat040 :: Float} deriving (Show)+instance SafeCopy CerealFloat040 where+ getCopy = contain (CerealFloat040 <$> liftM2 encodeFloat get get)+ putCopy (CerealFloat040 float) = contain (put (decodeFloat float))+ errorTypeName = typeName++instance Migrate Float where+ type MigrateFrom Float = CerealFloat040+ migrate (CerealFloat040 d) = d++instance SafeCopy Float where+ version = Version 1+ kind = extension+ getCopy = contain get+ putCopy = contain . put+ errorTypeName = typeName++-- | cereal changed the formats for Float/Double in 0.5.*+--+-- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced+-- https://github.com/GaloisInc/cereal/issues/35+newtype CerealDouble040 = CerealDouble040 { unCerealDouble040 :: Double} deriving (Show)+instance SafeCopy CerealDouble040 where+ getCopy = contain (CerealDouble040 <$> liftM2 encodeFloat get get)+ putCopy (CerealDouble040 double) = contain (put (decodeFloat double))+ errorTypeName = typeName++instance Migrate Double where+ type MigrateFrom Double = CerealDouble040+ migrate (CerealDouble040 d) = d+ instance SafeCopy Double where- getCopy = contain get; putCopy = contain . put; errorTypeName = typeName+ version = Version 1+ kind = extension+ getCopy = contain get+ putCopy = contain . put+ errorTypeName = typeName++ instance SafeCopy L.ByteString where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy B.ByteString where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Char where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName+instance SafeCopy Word where+ getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Word8 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Word16 where@@ -183,7 +245,7 @@ putCopy r = contain $ do safePut (numerator r) safePut (denominator r) errorTypeName = typeName1-instance (HasResolution a, Fractional (Fixed a)) => SafeCopy (Fixed a) where+instance (HasResolution a, Fractional (Fixed a), Typeable a) => SafeCopy (Fixed a) where getCopy = contain $ fromRational <$> safeGet putCopy = contain . safePut . toRational errorTypeName = typeName1@@ -348,8 +410,8 @@ pico <- get wday <- safeGet yday <- get- tzname <- get- tz <- safeGet+ tzname <- safeGet+ tz <- get dst <- get return (CalendarTime year month day hour mins sec pico wday yday tzname tz dst) putCopy t = contain $ do put (ctYear t)@@ -368,8 +430,37 @@ typeName :: Typeable a => Proxy a -> String typeName proxy = show (typeOf (undefined `asProxyType` proxy)) +#if MIN_VERSION_base(4,10,0)+typeName1 :: (Typeable c) => Proxy (c a) -> String+typeName2 :: (Typeable c) => Proxy (c a b) -> String+#else typeName1 :: (Typeable1 c) => Proxy (c a) -> String-typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy))- typeName2 :: (Typeable2 c) => Proxy (c a b) -> String+#endif++typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy)) typeName2 proxy = show (typeOf2 (undefined `asProxyType` proxy))++getGenericVector :: (SafeCopy a, VG.Vector v a) => Contained (Get (v a))+getGenericVector = contain $ do n <- get+ getSafeGet >>= VG.replicateM n++putGenericVector :: (SafeCopy a, VG.Vector v a) => v a -> Contained Put+putGenericVector v = contain $ do put (VG.length v)+ getSafePut >>= VG.forM_ v++instance SafeCopy a => SafeCopy (V.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector++instance (SafeCopy a, VP.Prim a) => SafeCopy (VP.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector++instance (SafeCopy a, VS.Storable a) => SafeCopy (VS.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector++instance (SafeCopy a, VU.Unbox a) => SafeCopy (VU.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector
+ src/Data/SafeCopy/Internal.hs view
@@ -0,0 +1,7 @@+module Data.SafeCopy.Internal (+ module Data.SafeCopy.SafeCopy+ , module Data.SafeCopy.Derive+ ) where++import Data.SafeCopy.SafeCopy+import Data.SafeCopy.Derive
src/Data/SafeCopy/SafeCopy.hs view
@@ -1,10 +1,15 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE CPP #-}-#ifdef DEFAULT_SIGNATURES+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}-#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- |@@ -21,11 +26,24 @@ -- module Data.SafeCopy.SafeCopy where -import Data.Serialize- import Control.Monad+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) -- | The central mechanism for dealing with version control. --@@ -41,22 +59,30 @@ -- all taken care of internally in the library. migrate :: MigrateFrom a -> a +-- | This is a wrapper type used migrating backwards in the chain of compatible types.+newtype Reverse a = Reverse { unReverse :: a }+ -- | The kind of a data type determines how it is tagged (if at all). -- -- Primitives kinds (see 'primitive') are not tagged with a version -- id and hence cannot be extended later. ----- Extensions (see 'extension') tells the system that there exists+-- Extensions (see 'extension') tell the system that there exists -- a previous version of the data type which should be migrated if -- needed. ----- There is also a default kind which is neither primitive nor is+-- There is also a default kind which is neither primitive nor -- an extension of a previous type. data Kind a where Primitive :: Kind a Base :: Kind a Extends :: (Migrate a) => Proxy (MigrateFrom a) -> Kind a+ Extended :: (Migrate (Reverse a)) => Kind a -> Kind a +isPrimitive :: Kind a -> Bool+isPrimitive Primitive = True+isPrimitive _ = False+ -- | Wrapper for data that was saved without a version tag. newtype Prim a = Prim { getPrimitive :: a } @@ -67,7 +93,7 @@ -- even though 'getCopy' and 'putCopy' can't be used directly. -- To serialize/parse a data type using 'SafeCopy', see 'safeGet' -- and 'safePut'.-class SafeCopy a where+class Typeable a => SafeCopy a where -- | The version of the type. -- -- Only used as a key so it must be unique (this is checked at run-time)@@ -91,7 +117,7 @@ -- | This method defines how a value should be parsed without worrying about -- previous versions or migrations. This function cannot be used directly.- -- One should use 'safeGet', instead.+ -- One should use 'safePut, instead. putCopy :: a -> Contained Put -- | Internal function that should not be overrided.@@ -104,43 +130,247 @@ -- lifetime, instead of everytime 'safeGet' or 'safePut' is -- used. internalConsistency :: Consistency a- internalConsistency =- let ret = computeConsistency proxy- proxy = proxyFromConsistency ret- in ret+ internalConsistency = computeConsistency Proxy - -- | The name of the type. This is only used in error- -- message strings.- -- Feel free to leave undefined in your instances.+ -- | Version profile.+ objectProfile :: Profile a+ objectProfile = mkProfile Proxy++ -- | The name of the type. This is only used in error message+ -- strings. errorTypeName :: Proxy a -> String- errorTypeName _ = "<unkown type>" -#ifdef DEFAULT_SIGNATURES- default getCopy :: Serialize a => Contained (Get a)- getCopy = contain get+ default errorTypeName :: Typeable a => Proxy a -> String+ errorTypeName _ = show (typeRep (Proxy @a)) - default putCopy :: Serialize a => a -> Contained Put- putCopy = contain . put-#endif+ default putCopy :: (GPutCopy (Rep a) DatatypeInfo, Constructors a) => a -> Contained Put+ putCopy a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a + default getCopy :: (GGetCopy (Rep a) DatatypeInfo, Constructors a) => Contained (Get a)+ getCopy = contain (to <$> ggetCopy (ConstructorCount (fromIntegral (gconNum @a)))) -constructGetterFromVersion :: SafeCopy a => Version a -> Proxy a -> Get a-constructGetterFromVersion diskVersion a_proxy- | version == diskVersion = unsafeUnPack getCopy- | otherwise = case kindFromProxy a_proxy of- Primitive -> fail $ errorMsg "Cannot migrate from primitive types."- Base ->- fail $- errorMsg $- "Cannot find getter associated with this version number: " ++ show diskVersion- Extends b_proxy- -> fmap migrate (constructGetterFromVersion (castVersion diskVersion) b_proxy)+class GPutCopy f p where+ gputCopy :: p -> f p -> Put +instance GPutCopy a p => GPutCopy (M1 D c a) p where+ gputCopy p (M1 a) = gputCopy p a+ {-# INLINE gputCopy #-}++instance (GPutCopy f p, GPutCopy g p) => GPutCopy (f :+: g) p where+ gputCopy p (L1 x) = gputCopy @f p x+ gputCopy p (R1 x) = gputCopy @g p x+ {-# INLINE gputCopy #-}++-- | A constraint that combines 'SafeCopy' and 'Typeable'.+type SafeCopy' a = SafeCopy a+{-# DEPRECATED SafeCopy' "SafeCopy' is now equivalent to SafeCopy " #-}++-- To get the current safecopy behavior we need to emulate the+-- template haskell code here - collect the (a -> Put) values for all+-- the fields and then run them in order.o+instance (GPutFields a p, p ~ DatatypeInfo) => GPutCopy (M1 C c a) p where+ gputCopy p (M1 x) =+ (when (_size p >= 2) (putWord8 (fromIntegral (_code p)))) *>+ -- This is how I tried it first, and it works well but the+ -- result is not the same as deriveSafeCopy.+ -- mconcat (fmap join (gputFields p x))+ -- join (mconcat <$> sequence (fmap snd (gputFields p x)))+ (do putter <- (mconcat . snd) <$> (evalRWST (gputFields p x) () mempty)+ putter)+ {-# INLINE gputCopy #-}++-- | gputFields traverses the fields of a constructor and returns a put+-- for the safecopy versions and a put for the field values.+class GPutFields f p where+ gputFields :: p -> f p -> RWST () [Put] (Set TypeRep) PutM ()++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+ {-# INLINE gputFields #-}++instance SafeCopy a => GPutFields (K1 R a) p where+ gputFields _ (K1 a) = do+ getSafePutGeneric putCopy a+ {-# INLINE gputFields #-}++-- This corresponds to ggetFields, but does it match deriveSafeCopy?+instance GPutFields U1 p where+ gputFields _ _ =+ return ()+{-+-- 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)+-}+ {-# INLINE gputFields #-}++instance GPutFields V1 p where+ gputFields _ _ = undefined+ {-# INLINE gputFields #-}++------------------------------------------------------------------------++class GGetCopy f p where+ ggetCopy :: p -> Get (f a)++-- | The M1 type has a fourth type parameter p:+--+-- newtype M1 i (c :: Meta) (f :: k -> *) (p :: k) = M1 {unM1 :: f p}+--+-- Note that the type of the M1 field is @f p@, so in order to express this+-- type we add a parameter of type p that we can apply to values of type f.+instance (GGetCopy f p, p ~ DatatypeInfo) => GGetCopy (M1 D d f) p where+ ggetCopy p+ | _size p >= 2 = do+ !code <- getWord8+ M1 <$> ggetCopy (ConstructorInfo (_size p) code)+ | otherwise = M1 <$> ggetCopy (ConstructorInfo (_size p) 0)+ {-# INLINE ggetCopy #-}++instance (GGetCopy f p, GGetCopy g p, p ~ DatatypeInfo) => GGetCopy (f :+: g) p where+ ggetCopy p = do+ -- choose the left or right branch of the constructor types+ -- based on whether the code is in the left or right half of the+ -- remaining constructor count.+ let sizeL = _size p `shiftR` 1+ sizeR = _size p - sizeL+ 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+ M1 <$> join (evalStateT (ggetFields p) mempty)+ {-# INLINE ggetCopy #-}++-- append constructor fields+class GGetFields f p where+ ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (f a))++instance (GGetFields f p, GGetFields g p) => GGetFields (f :*: g) p where+ ggetFields p = do+ 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+ getter <- ggetFields p+ return (M1 <$> getter)+ {-# INLINE ggetFields #-}++instance SafeCopy a => GGetFields (K1 R a) p where+ ggetFields _ = do+ getter <- getSafeGetGeneric+ return (K1 <$> getter)+ {-# INLINE ggetFields #-}++instance GGetFields U1 p where+ ggetFields _p = pure (pure U1)+ {-# INLINE ggetFields #-}++instance GGetFields V1 p where+ ggetFields _p = undefined+ {-# INLINE ggetFields #-}++data DatatypeInfo =+ ConstructorCount {_size :: Word8}+ | ConstructorInfo {_size :: Word8, _code :: Word8}+ deriving Show++-- | Whereas the other 'getSafeGet' is only run when we know we need a+-- version, this one is run for every field and must decide whether to+-- read a version or not. It constructs a Map TypeRep Int32 and reads+-- when the new TypeRep is not in the map.+getSafeGetGeneric ::+ forall a. SafeCopy a+ => StateT (Map TypeRep Int32) Get (Get a)+getSafeGetGeneric+ = checkConsistency proxy $+ case kindFromProxy proxy of+ Primitive -> return $ unsafeUnPack getCopy+ a_kind -> do let rep = typeRep (Proxy :: Proxy a)+ reps <- State.get+ v <- maybe (lift get) pure (Map.lookup rep reps)+ case constructGetterFromVersion (unsafeCoerce v) a_kind of+ Right getter -> State.modify (Map.insert rep v) >> return getter+ Left msg -> fail msg+ where proxy = Proxy :: Proxy a++-- | This version returns (Put, Put), the collected version tags and+-- the collected serialized fields. The original 'getSafePut' result+-- type prevents doing this because each fields may have a different+-- type. Maybe you can show me a better way+getSafePutGeneric ::+ forall a. SafeCopy a+ => (a -> Contained Put)+ -> a+ -> RWST () [Put] (Set TypeRep) PutM ()+getSafePutGeneric cput a+ = unpureCheckConsistency proxy $+ case kindFromProxy proxy of+ Primitive -> tell [unsafeUnPack (cput $ asProxyType a proxy)]+ _ -> do reps <- RWS.get+ let typ = typeOf a+ when (not (member typ reps)) $ do+ lift (put (versionFromProxy proxy))+ RWS.modify (Set.insert typ)+ tell [unsafeUnPack (cput $ asProxyType a proxy)]+ where proxy = Proxy :: Proxy a++type GSafeCopy a = (SafeCopy a, Generic a, GPutCopy (Rep a) DatatypeInfo, Constructors a)++-- | Generic only version of safePut. Instead of calling 'putCopy' it+-- calls 'putCopyDefault', a copy of the implementation of the+-- 'SafeCopy' default method for 'putCopy'.+safePutGeneric :: forall a. GSafeCopy a => a -> Put+safePutGeneric a = do+ putter <- (mconcat . snd) <$> evalRWST (getSafePutGeneric putCopyDefault a) () mempty+ putter++-- | See 'safePutGeneric'. A copy of the code in the default+-- 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++-- constructGetterFromVersion :: SafeCopy a => Version a -> Kind (MigrateFrom (Reverse a)) -> Get (Get a)+constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a)+constructGetterFromVersion diskVersion orig_kind =+ worker False diskVersion orig_kind where- errorMsg msg =+ worker :: forall a. SafeCopy a => Bool -> Version a -> Kind a -> Either String (Get a)+ worker fwd thisVersion thisKind+ | version == thisVersion = return $ unsafeUnPack getCopy+ | otherwise =+ case thisKind of+ Primitive -> Left $ errorMsg thisKind "Cannot migrate from primitive types."+ Base -> Left $ errorMsg thisKind versionNotFound+ Extends b_proxy -> do+ previousGetter <- worker fwd (castVersion diskVersion) (kindFromProxy b_proxy)+ return $ fmap migrate previousGetter+ Extended{} | fwd -> Left $ errorMsg thisKind versionNotFound+ Extended a_kind -> do+ let rev_proxy :: Proxy (MigrateFrom (Reverse a))+ rev_proxy = Proxy+ forwardGetter :: Either String (Get a)+ forwardGetter = fmap (fmap (unReverse . migrate)) $ worker True (castVersion thisVersion) (kindFromProxy rev_proxy)+ previousGetter :: Either String (Get a)+ previousGetter = worker fwd (castVersion thisVersion) a_kind+ case forwardGetter of+ Left{} -> previousGetter+ Right val -> Right val+ versionNotFound = "Cannot find getter associated with this version number: " ++ show diskVersion+ errorMsg fail_kind msg = concat [ "safecopy: "- , errorTypeName a_proxy+ , errorTypeName (proxyFromKind fail_kind) , ": " , msg ]@@ -164,8 +394,10 @@ = checkConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ unsafeUnPack getCopy- _ -> do v <- get- return $ constructGetterFromVersion v proxy+ a_kind -> do v <- get+ case constructGetterFromVersion v a_kind of+ Right getter -> return getter+ Left msg -> fail msg where proxy = Proxy :: Proxy a -- | Serialize a data type by first writing out its version tag. This is much@@ -180,19 +412,29 @@ -- 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) return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) where proxy = Proxy :: Proxy a +-- | The extended_extension kind lets the system know that there is+-- at least one previous and one future version of this type.+extended_extension :: (Migrate a, Migrate (Reverse a)) => Kind a+extended_extension = Extended extension++-- | The extended_base kind lets the system know that there is+-- at least one future version of this type.+extended_base :: (Migrate (Reverse a)) => Kind a+extended_base = Extended base+ -- | The extension kind lets the system know that there is -- at least one previous version of this type. A given data type -- can only extend a single other data type. However, it is -- perfectly fine to build chains of extensions. The migrations -- between each step is handled automatically.-extension :: (SafeCopy a, Migrate a) => Kind a+extension :: Migrate a => Kind a extension = Extends Proxy -- | The default kind. Does not extend any type.@@ -233,7 +475,7 @@ -- parsers/putters. -- | To ensure that no-one reads or writes values without handling versions--- correct, it is necessary to restrict access to 'getCopy' and 'putCopy'.+-- correctly, it is necessary to restrict access to 'getCopy' and 'putCopy'. -- This is where 'Contained' enters the picture. It allows you to put -- values in to a container but not to take them out again. newtype Contained a = Contained {unsafeUnPack :: a}@@ -245,45 +487,83 @@ ------------------------------------------------- -- Consistency checking +data Profile a =+ PrimitiveProfile |+ InvalidProfile String |+ Profile+ { profileCurrentVersion :: Int32+ , profileSupportedVersions :: [Int32]+ } deriving (Show)++mkProfile :: SafeCopy a => Proxy a -> Profile a+mkProfile a_proxy =+ case computeConsistency a_proxy of+ NotConsistent msg -> InvalidProfile msg+ Consistent | isPrimitive (kindFromProxy a_proxy) -> PrimitiveProfile+ Consistent ->+ Profile{ profileCurrentVersion = unVersion (versionFromProxy a_proxy)+ , profileSupportedVersions = availableVersions a_proxy+ }+ data Consistency a = Consistent | NotConsistent String availableVersions :: SafeCopy a => Proxy a -> [Int32]-availableVersions a_proxy- = case kindFromProxy a_proxy of- Primitive -> []- Base -> [unVersion (versionFromProxy a_proxy)]- Extends b_proxy ->unVersion (versionFromProxy a_proxy) : availableVersions b_proxy+availableVersions a_proxy =+ worker True (kindFromProxy a_proxy)+ where+ worker :: SafeCopy b => Bool -> Kind b -> [Int32]+ worker fwd b_kind =+ case b_kind of+ Primitive -> []+ Base -> [unVersion (versionFromKind b_kind)]+ Extends b_proxy -> unVersion (versionFromKind b_kind) : worker False (kindFromProxy b_proxy)+ Extended sub_kind | fwd -> worker False (getForwardKind sub_kind)+ Extended sub_kind -> worker False sub_kind +getForwardKind :: (Migrate (Reverse a)) => Kind a -> Kind (MigrateFrom (Reverse a))+getForwardKind _ = kind+ -- Extend chains must end in a Base kind. Ending in a Primitive is an error. validChain :: SafeCopy a => Proxy a -> Bool-validChain a_proxy- = case kindFromProxy a_proxy of- Primitive -> True- Base -> True- Extends b_proxy -> check b_proxy- where check :: SafeCopy b => Proxy b -> Bool- check b_proxy- = case kindFromProxy b_proxy of+validChain a_proxy =+ worker (kindFromProxy a_proxy)+ where+ worker Primitive = True+ worker Base = True+ worker (Extends b_proxy) = check (kindFromProxy b_proxy)+ worker (Extended a_kind) = worker a_kind+ check :: SafeCopy b => Kind b -> Bool+ check b_kind+ = case b_kind of Primitive -> False Base -> True- Extends c_proxy -> check c_proxy+ Extends c_proxy -> check (kindFromProxy c_proxy)+ 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 an 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 #-}-computeConsistency :: SafeCopy a => Proxy a -> Consistency a+computeConsistency :: forall a. SafeCopy a => Proxy a -> Consistency a computeConsistency proxy -- Match a few common cases before falling through to the general case. -- This allows use to generate nearly all consistencies at compile-time. | isObviouslyConsistent (kindFromProxy proxy) = Consistent | versions /= nub versions- = NotConsistent $ "Duplicate version tags: " ++ show versions+ = NotConsistent $ "Duplicate version tags for " ++ show (typeRep (Proxy @a)) ++ ": " ++ show versions | not (validChain proxy) = NotConsistent "Primitive types cannot be extended as they have no version tag." | otherwise@@ -302,11 +582,20 @@ proxyFromConsistency :: Consistency a -> Proxy a proxyFromConsistency _ = Proxy +proxyFromKind :: Kind a -> Proxy a+proxyFromKind _ = Proxy+ consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a consistentFromProxy _ = internalConsistency versionFromProxy :: SafeCopy a => Proxy a -> Version a versionFromProxy _ = version++versionFromKind :: (SafeCopy a) => Kind a -> Version a+versionFromKind _ = version++versionFromReverseKind :: (SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a))+versionFromReverseKind _ = version kindFromProxy :: SafeCopy a => Proxy a -> Kind a kindFromProxy _ = kind
+ test/generic.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS -Wno-missing-signatures #-}++import GHC.Generics+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+import Data.SafeCopy+import Data.SafeCopy.Internal+import Data.Serialize (runGet, runPut, Serialize)+import Text.Printf+import Test.HUnit (Test(..), assertEqual, runTestTT)+--import Generic.Data as G hiding (unpack)++-- Debugging+import Data.Typeable hiding (Proxy)+--import Debug.Trace+import Data.ByteString (ByteString, unpack)+import Data.Char (chr)+import Data.Word (Word8, Word32)++-- Test types+data Foo = Foo Int Char deriving (Generic, Show, Eq)+data Bar = Bar Float Foo deriving (Generic, Show, Eq)+data Baz = Baz1 Int | Baz2 Bool deriving (Generic, Show, Eq)++#if 0+safePutTest :: forall a. (SafeCopy' a, Generic a, GPutCopy (Rep a) DatatypeInfo, GConstructors (Rep a)) => a -> Put+safePutTest a =+ case runPut p1 == runPut p2 of+ True -> p1+ False -> trace ("safePutTest failed for " ++ show (typeRep (Proxy :: Proxy a)) ++ "\n custom: " ++ showBytes (runPut p1) ++ "\n generic: " ++ showBytes (runPut p2)) p1+ where+ p1 = safePut a+ p2 = safePutGeneric a+#endif++----------------------------------------------++-- Compare a value to the result of encoding and then decoding it.+roundTrip :: forall a. (SafeCopy a, Typeable a, Eq a, Show a) => a -> Test+roundTrip x = do+ -- putStrLn ("\n========== " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a)) ++ " ==========")+ let d = runPut (safePut x) -- Use custom putCopy/getCopy implementation if present+ a :: Either String a+ a = runGet safeGet d+ TestCase (assertEqual ("roundTrip " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a))) (Right x) a)++-- Test whether two values of different types have the same encoded+-- representation. This is used here on types of similar shape to+-- test whether the generic SafeCopy instance matches the template+-- haskell instance.+compareBytes ::+ forall expected actual. (SafeCopy expected, Typeable expected,+ SafeCopy actual, Typeable actual)+ => expected -> actual -> Test+compareBytes e a =+ TestCase (assertEqual ("compareBytes " ++ show (typeRep (Proxy :: Proxy expected)) ++ " " +++ show (typeRep (Proxy :: Proxy actual)))+ (showBytes (runPut $ safePut e))+ (showBytes (runPut $ safePut a)))++showBytes :: ByteString -> String+showBytes b = mconcat (fmap f (unpack b))+ where f :: Word8 -> String+ f 192 = "[G|"+ f 193 = "[C|"+ f 194 = "[T|"+ f 195 = "]_ "+ f 196 = " _<"+ f 197 = ">_ "+ f c | c >= 32 && c < 127 = [' ', chr (fromIntegral c), ' ']+ f c | c == 0 = " __"+ f c = printf " %02x" c++-----------------------------+-- Test Types and Values+-----------------------------++foo = Foo maxBound 'x'+bar = Bar 1.5 foo+baz1 = Baz1 3+baz2 = Baz2 True++-- These instances will use the generic putCopy and getCopy+instance SafeCopy Foo where version = 3; kind = base+instance SafeCopy Bar where version = 4; kind = base+instance SafeCopy Baz where version = 5; kind = base++-- Copies of the types above with generated SafeCopy instances+data FooTH = FooTH Int Char deriving (Generic, Serialize, Show, Eq)+data BarTH = BarTH Float FooTH deriving (Generic, Serialize, Show, Eq)+data BazTH = Baz1TH Int | Baz2TH Bool deriving (Generic, Serialize, Show, Eq)++fooTH = FooTH maxBound 'x'+barTH = BarTH 1.5 fooTH+baz1TH = Baz1TH 3+baz2TH = Baz2TH True++-- For comparison, these instances have the generated implementations+-- of putCopy and getCopy+#if 1+$(deriveSafeCopy 3 'base ''FooTH)+$(deriveSafeCopy 4 'base ''BarTH)+$(deriveSafeCopy 5 'base ''BazTH)+#else+instance SafeCopy FooTH where+ putCopy (FooTH a1_aeVVN a2_aeVVO)+ = contain+ (do safePut_Int_aeVVP <- getSafePut+ safePut_Char_aeVVQ <- getSafePut+ safePut_Int_aeVVP a1_aeVVN+ safePut_Char_aeVVQ a2_aeVVO+ return ())+ getCopy+ = contain+ ((Data.Serialize.Get.label "Main.FooTH:")+ (do safeGet_Int_aeVVR <- getSafeGet+ safeGet_Char_aeVVS <- getSafeGet+ ((return FooTH <*> safeGet_Int_aeVVR) <*> safeGet_Char_aeVVS)))+ version = 3+ kind = base+ errorTypeName _ = "Main.FooTH"++instance SafeCopy BarTH where+ putCopy (BarTH a1_aeVXE a2_aeVXF)+ = contain+ (do safePut_Float_aeVXG <- getSafePut+ safePut_FooTH_aeVXH <- getSafePut+ safePut_Float_aeVXG a1_aeVXE+ safePut_FooTH_aeVXH a2_aeVXF+ return ())+ getCopy+ = contain+ ((Data.Serialize.Get.label "Main.BarTH:")+ (do safeGet_Float_aeVXI <- getSafeGet+ safeGet_FooTH_aeVXJ <- getSafeGet+ ((return BarTH <*> safeGet_Float_aeVXI) <*> safeGet_FooTH_aeVXJ)))+ version = 4+ kind = base+ errorTypeName _ = "Main.BarTH"++instance SafeCopy BazTH where+ putCopy (Baz1TH a1_aeVZv)+ = contain+ (do Data.Serialize.Put.putWord8 0+ safePut_Int_aeVZw <- getSafePut+ safePut_Int_aeVZw a1_aeVZv+ return ())+ putCopy (Baz2TH a1_aeVZx)+ = contain+ (do Data.Serialize.Put.putWord8 1+ safePut_Bool_aeVZy <- getSafePut+ safePut_Bool_aeVZy a1_aeVZx+ return ())+ getCopy+ = contain+ ((Data.Serialize.Get.label "Main.BazTH:")+ (do tag_aeVZz <- Data.Serialize.Get.getWord8+ case tag_aeVZz of+ 0 -> do safeGet_Int_aeVZA <- getSafeGet+ (return Baz1TH <*> safeGet_Int_aeVZA)+ 1 -> do safeGet_Bool_aeVZB <- getSafeGet+ (return Baz2TH <*> safeGet_Bool_aeVZB)+ _ -> fail+ ("Could not identify tag \""+ +++ (show tag_aeVZz+ +++ "\" for type \"Main.BazTH\" that has only 2 constructors. Maybe your data is corrupted?"))))+ version = 5+ kind = base+ errorTypeName _ = "Main.BazTH"+#endif++data File+ = File { _fileChksum :: Checksum -- ^ The checksum of the file's contents+ , _fileMessages :: [String] -- ^ Messages received while manipulating the file+ , _fileExt :: String -- ^ Name is formed by appending this to checksum+ } deriving (Generic, Eq, Ord, Show)++data FileSource+ = TheURI String+ | ThePath FilePath+ deriving (Generic, Eq, Ord, Show)++type Checksum = String++$(deriveSafeCopy 10 'base ''File)+$(deriveSafeCopy 11 'base ''FileSource)++file1 = File ("checksum") [] ".jpg"+file2 = File ("checksum") [] ".jpg"+file3 = File ("checksum") [] ".jpg"++----------------------------------------------+-- Demonstration of the ordering issue+----------------------------------------------++data T1 = T1 Char T2 T3 deriving (Generic, Show)+data T2 = T2 Char deriving (Generic, Show)+data T3 = T3 Char deriving (Generic, Show)+data T4 = T4 Word32 Word32 Word32 deriving (Generic, Show)++t1 = T1 'a' (T2 'b') (T3 'c')+t2 = (T2 'b')+t3 = (T3 'c')+t4 = T4 100 200 300++$(deriveSafeCopy 4 'base ''T2)+$(deriveSafeCopy 5 'base ''T3)+$(deriveSafeCopy 3 'base ''T1)+$(deriveSafeCopy 6 'base ''T4)++data T1G = T1G Char T2G T3G deriving (Generic, Show)+data T2G = T2G Char deriving (Generic, Show)+data T3G = T3G Char deriving (Generic, Show)+data T4G = T4G Word32 Word32 Word32 deriving (Generic, Show)++t1g = T1G 'a' (T2G 'b') (T3G 'c')+t2g = (T2G 'b')+t3g = (T3G 'c')+t4g = T4G 100 200 300++instance SafeCopy T1G where version = 3; kind = base+instance SafeCopy T2G where version = 4; kind = base+instance SafeCopy T3G where version = 5; kind = base+instance SafeCopy T4G where version = 6; kind = base++orderTests :: Test+orderTests =+ let -- When I thought to myself "what should the output be type Baz"+ -- without reference to reality, this is what I came up with.+ _expected :: ByteString+ _expected = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "a" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\ENQ" <> "\NUL\NUL\NUL\NUL" <> "c")+ -- T1 Char 'a' T2 Char 'b' T3 Char 'c'+ -- But this is reality - the type, followed by its three field+ -- types, followed by its three field values.+ actual :: ByteString+ actual = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\ENQ" <> "a" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\NUL" <> "c") in+ -- T1 Char T2 T3 'a' Char 'b' Char 'c'+ TestList+ [ TestCase (assertEqual "actual template haskell safeput output" (showBytes actual) (showBytes (runPut (safePut t1))))+ , TestCase (assertEqual "what the new implementation does" (showBytes actual) (showBytes (runPut (safePut t1g))))+ ]++main = do+ runTestTT+ (TestList+ [ orderTests+ , roundTrip ()+ , roundTrip ("hello" :: String)+ , roundTrip foo+ , roundTrip fooTH+ , roundTrip bar+ , roundTrip barTH+ , roundTrip baz1+ , roundTrip baz1TH+ , roundTrip baz2+ , roundTrip baz2TH+ , roundTrip (Just 'x')+ , roundTrip (Nothing :: Maybe Char)+ , roundTrip ('a', (123 :: Int), ("hello" :: String))+ , roundTrip file1+ , roundTrip file2+ , roundTrip file3+ , compareBytes fooTH foo+ , compareBytes barTH bar+ , compareBytes baz1TH baz1+ , compareBytes baz2TH baz2+ ])
+ test/instances.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Applicative+import Control.Lens (transformOn, transformOnOf)+import Control.Lens.Traversal (Traversal')+import Control.Lens.Action ((^!!), act)+import Data.Array (Array)+import Data.Array.Unboxed (UArray)+import Data.Data.Lens (template)+import Data.Fixed (Fixed, E1)+import Data.List+import Data.SafeCopy+import Data.Serialize (runPut, runGet)+import Data.Time (UniversalTime(..), ZonedTime(..))+import Data.Tree (Tree)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Test.Tasty+import Test.Tasty.QuickCheck hiding (Fixed, (===))+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++deriving instance (Arbitrary a) => Arbitrary (Prim a)+deriving instance (Eq a) => Eq (Prim a)+deriving instance (Show a) => Show (Prim a)++deriving instance Eq ZonedTime++-- | Equality on the 'Right' value, showing the unequal value on failure;+-- or explicit failure using the 'Left' message without equality testing.+(===) :: (Eq a, Show a) => Either String a -> a -> Property+Left e === _ = printTestCase e False+Right a === b = printTestCase (show a) $ a == b++-- | An instance for 'SafeCopy' makes a type isomorphic to a bytestring+-- serialization, which is to say that @decode . encode = id@, i.e.+-- @decode@ is the inverse of @encode@ if we ignore bottom.+prop_inverse :: (SafeCopy a, Arbitrary a, Eq a, Show a) => a -> Property+prop_inverse a = (decode . encode) a === a where+ encode = runPut . safePut+ decode = runGet safeGet++-- | Test the 'prop_inverse' property against all 'SafeCopy' instances+-- (that also satisfy the rest of the constraints) defaulting any type+-- variables to 'Int'.+do let a = conT ''Int++ -- types we skip because the Int defaulting doesn't type check+ excluded <- sequence+ [ [t| Fixed $a |]+ ]++ -- instead we include these hand-defaulted types+ included <- sequence+ [ [t| Fixed E1 |]+ ]++ -- types whose samples grow exponentially and need a lower maxSize+ downsized <- sequence+ [ [t| Array $a $a |]+ , [t| UArray $a $a |]+ , [t| Tree $a |]+ ]++ safecopy <- reify ''SafeCopy+ preds <- 'prop_inverse ^!! act reify . (template :: Traversal' Info Pred)+ classes <-+ case preds of+ [ForallT _ cxt' _] ->+ mapM reify [ name | AppT (ConT name) _ <- cxt' ]+ _ -> error "FIXME: fix this code to handle this case."+ def <- a++ let instances (ClassI _ decs) = [ typ | InstanceD _ _ (AppT _ typ) _ <- decs ]+ instances _ = []+ types = map instances classes++ defaulting (VarT _) = def+ defaulting t = t+ defaulted = transformOn (traverse.traverse) defaulting types+ wanted = transformOn traverse defaulting $ instances safecopy++ common = foldl1 intersect defaulted+ untested = wanted \\ common+ exclusive = filter (`notElem` excluded) common++ downsize typ | typ `elem` downsized = [| mapSize (`div` 5) |]+ | otherwise = [| id |]++ unqualifying (Name occ _) = Name occ NameS+ name = pprint . transformOnOf template template unqualifying++ prop typ =+ [| testProperty $(litE . stringL $ name typ)+ ($(downsize typ) (prop_inverse :: $(return typ) -> Property)) |]++ props = listE . map prop++ mapM_ (\typ -> reportWarning $ "not tested: " ++ name typ) untested++ [d| inversions :: [TestTree]+ inversions = $(props included) ++ $(props exclusive) |]++main :: IO ()+main = defaultMain $ testGroup "SafeCopy instances"+ [ testGroup "decode is the inverse of encode" inversions+ ]