safecopy-0.10.4.2/0000755000000000000000000000000007346545000011736 5ustar0000000000000000safecopy-0.10.4.2/CHANGELOG.md0000755000000000000000000000427607346545000013563 0ustar00000000000000000.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-0.10.4.2/Setup.hs0000644000000000000000000000005607346545000013373 0ustar0000000000000000import Distribution.Simple main = defaultMain safecopy-0.10.4.2/safecopy.cabal0000644000000000000000000000537407346545000014544 0ustar0000000000000000-- 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. Name: safecopy Version: 0.10.4.2 Synopsis: Binary serialization with version control. Description: An extension to Data.Serialize with built-in version control. Homepage: https://github.com/acid-state/safecopy License: PublicDomain Author: David Himmelstrup, Felipe Lessa Maintainer: Lemmih , David Fox -- Copyright: Category: Data, Parsing Build-type: Simple Extra-source-files: CHANGELOG.md Cabal-version: >=1.10 tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 Source-repository head type: git location: git://github.com/acid-state/safecopy.git Library Default-language: Haskell2010 -- Modules exported by the library. Exposed-modules: Data.SafeCopy Data.SafeCopy.Internal Hs-Source-Dirs: src/ -- Packages needed in order to build this package. Build-depends: base >=4.9 && <5, array < 0.6, cereal >= 0.5 && < 0.6, bytestring < 0.12, generic-data >= 0.3, containers >= 0.3 && < 0.7, old-time < 1.2, template-haskell < 2.18, text < 1.3, time < 1.12, transformers < 0.6, vector >= 0.10 && < 0.13 -- Modules not exported by this package. 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 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, cereal, template-haskell, safecopy, containers, time, array, vector, lens >= 4.7 && < 5.1, lens-action, tasty, tasty-quickcheck, quickcheck-instances, 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 safecopy-0.10.4.2/src/Data/0000755000000000000000000000000007346545000013376 5ustar0000000000000000safecopy-0.10.4.2/src/Data/SafeCopy.hs0000644000000000000000000000744507346545000015455 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.SafeCopy -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- SafeCopy extends the parsing and serialization capabilities of Data.Serialize -- to include nested version control. Nested version control means that you -- can change the definition and binary format of a type nested deep within -- other types without problems. -- -- Consider this scenario. You want to store your contact list on disk -- and so write the following code: -- -- @ --type Name = String --type Address = String --data Contacts = Contacts [(Name, Address)] --instance SafeCopy Contacts where -- putCopy (Contacts list) = contain $ safePut list -- getCopy = contain $ Contacts \<$\> safeGet -- @ -- -- At this point, everything is fine. You get the awesome speed of Data.Serialize -- together with Haskell's ease of use. However, things quickly take a U-turn for the worse -- when you realize that you want to keep phone numbers as well as names and -- addresses. Being the experienced coder that you are, you see that using a 3-tuple -- isn't very pretty and you'd rather use a record. At first you fear that this -- change in structure will invalidate all your old data. Those fears are quickly quelled, -- though, when you remember how nifty SafeCopy is. With renewed enthusiasm, -- you set out and write the following code: -- -- @ --type Name = String --type Address = String --type Phone = String -- --{- We rename our old Contacts structure -} --data Contacts_v0 = Contacts_v0 [(Name, Address)] --instance SafeCopy Contacts_v0 where -- putCopy (Contacts_v0 list) = contain $ safePut list -- getCopy = contain $ Contacts_v0 \<$\> safeGet -- --data Contact = Contact { name :: Name -- , address :: Address -- , phone :: Phone } --instance SafeCopy Contact where -- putCopy Contact{..} = contain $ do safePut name; safePut address; safePut phone -- getCopy = contain $ Contact \<$\> safeGet \<*\> safeGet \<*\> safeGet -- --data Contacts = Contacts [Contact] --instance SafeCopy Contacts where -- version = 2 -- kind = extension -- putCopy (Contacts contacts) = contain $ safePut contacts -- getCopy = contain $ Contacts \<$\> safeGet -- --{- Here the magic happens: -} --instance Migrate Contacts where -- type MigrateFrom Contacts = Contacts_v0 -- migrate (Contacts_v0 contacts) = Contacts [ Contact{ name = name -- , address = address -- , phone = \"\" } -- | (name, address) <- contacts ] -- @ -- -- 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. module Data.SafeCopy ( safeGet , safePut , 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 ) where import Data.SafeCopy.Instances () import Data.SafeCopy.SafeCopy import Data.SafeCopy.Derive safecopy-0.10.4.2/src/Data/SafeCopy/0000755000000000000000000000000007346545000015107 5ustar0000000000000000safecopy-0.10.4.2/src/Data/SafeCopy/Derive.hs0000644000000000000000000004777207346545000016702 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} -- Hack for bug in older Cabal versions #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif module Data.SafeCopy.Derive where import Data.Serialize (getWord8, putWord8, label) import Data.SafeCopy.SafeCopy import Language.Haskell.TH hiding (Kind) import Control.Monad import Data.Maybe (fromMaybe) #ifdef __HADDOCK__ import Data.Word (Word8) -- Haddock #endif -- | Derive an instance of 'SafeCopy'. -- -- When serializing, we put a 'Word8' describing the -- constructor (if the data type has more than one -- constructor). For each type used in the constructor, we -- call 'getSafePut' (which immediately serializes the version -- of the type). Then, for each field in the constructor, we -- use one of the put functions obtained in the last step. -- -- For example, given the data type and the declaration below -- -- @ --data T0 b = T0 b Int --deriveSafeCopy 1 'base ''T0 -- @ -- -- we generate -- -- @ --instance (SafeCopy a, SafeCopy b) => -- SafeCopy (T0 b) where -- putCopy (T0 arg1 arg2) = contain $ do put_b <- getSafePut -- put_Int <- getSafePut -- put_b arg1 -- put_Int arg2 -- return () -- getCopy = contain $ do get_b <- getSafeGet -- get_Int <- getSafeGet -- return T0 \<*\> get_b \<*\> get_Int -- version = 1 -- kind = base -- @ -- -- And, should we create another data type as a newer version of @T0@, such as -- -- @ --data T a b = C a a | D b Int --deriveSafeCopy 2 'extension ''T -- --instance SafeCopy b => Migrate (T a b) where -- type MigrateFrom (T a b) = T0 b -- migrate (T0 b i) = D b i -- @ -- -- we generate -- -- @ --instance (SafeCopy a, SafeCopy b) => -- SafeCopy (T a b) where -- putCopy (C arg1 arg2) = contain $ do putWord8 0 -- put_a <- getSafePut -- put_a arg1 -- put_a arg2 -- return () -- putCopy (D arg1 arg2) = contain $ do putWord8 1 -- put_b <- getSafePut -- put_Int <- getSafePut -- put_b arg1 -- put_Int arg2 -- return () -- getCopy = contain $ do tag <- getWord8 -- case tag of -- 0 -> do get_a <- getSafeGet -- return C \<*\> get_a \<*\> get_a -- 1 -> do get_b <- getSafeGet -- get_Int <- getSafeGet -- return D \<*\> get_b \<*\> get_Int -- _ -> fail $ \"Could not identify tag \\\"\" ++ -- show tag ++ \"\\\" for type Main.T \" ++ -- \"that has only 2 constructors. \" ++ -- \"Maybe your data is corrupted?\" -- version = 2 -- kind = extension -- @ -- -- Note that by using getSafePut, we saved 4 bytes in the case -- of the @C@ constructor. For @D@ and @T0@, we didn't save -- anything. The instance derived by this function always use -- at most the same space as those generated by -- 'deriveSafeCopySimple', but never more (as we don't call -- 'getSafePut'/'getSafeGet' for types that aren't needed). -- -- Note that you may use 'deriveSafeCopySimple' with one -- version of your data type and 'deriveSafeCopy' in another -- version without any problems. 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 -- 'safeGet' (instead of 'getSafePut' and 'getSafeGet'). -- -- When serializing, we put a 'Word8' describing the -- constructor (if the data type has more than one constructor) -- and, for each field of the constructor, we use 'safePut'. -- -- For example, given the data type and the declaration below -- -- @ --data T a b = C a a | D b Int --deriveSafeCopySimple 1 'base ''T -- @ -- -- we generate -- -- @ --instance (SafeCopy a, SafeCopy b) => -- SafeCopy (T a b) where -- putCopy (C arg1 arg2) = contain $ do putWord8 0 -- safePut arg1 -- safePut arg2 -- return () -- putCopy (D arg1 arg2) = contain $ do putWord8 1 -- safePut arg1 -- safePut arg2 -- return () -- getCopy = contain $ do tag <- getWord8 -- case tag of -- 0 -> do return C \<*\> safeGet \<*\> safeGet -- 1 -> do return D \<*\> safeGet \<*\> safeGet -- _ -> fail $ \"Could not identify tag \\\"\" ++ -- show tag ++ \"\\\" for type Main.T \" ++ -- \"that has only 2 constructors. \" ++ -- \"Maybe your data is corrupted?\" -- version = 1 -- kind = base -- @ -- -- Using this simpler instance means that you may spend more -- bytes when serializing data. On the other hand, it is more -- straightforward and may match any other format you used in -- the past. -- -- Note that you may use 'deriveSafeCopy' with one version of -- your data type and 'deriveSafeCopySimple' in another version -- without any problems. 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 -- @happstack-data@ package. The instances use only 'safePut' -- and 'safeGet' (as do the instances created by -- 'deriveSafeCopySimple'), but we also always write a 'Word8' -- tag, even if the data type isn't a sum type. -- -- For example, given the data type and the declaration below -- -- @ --data T0 b = T0 b Int --deriveSafeCopy 1 'base ''T0 -- @ -- -- we generate -- -- @ --instance (SafeCopy a, SafeCopy b) => -- SafeCopy (T0 b) where -- putCopy (T0 arg1 arg2) = contain $ do putWord8 0 -- safePut arg1 -- safePut arg2 -- return () -- getCopy = contain $ do tag <- getWord8 -- case tag of -- 0 -> do return T0 \<*\> safeGet \<*\> safeGet -- _ -> fail $ \"Could not identify tag \\\"\" ++ -- show tag ++ \"\\\" for type Main.T0 \" ++ -- \"that has only 1 constructors. \" ++ -- \"Maybe your data is corrupted?\" -- version = 1 -- kind = base -- @ -- -- This instance always consumes at least the same space as -- 'deriveSafeCopy' or 'deriveSafeCopySimple', but may use more -- because of the useless tag. So we recomend using it only if -- you really need to read a previous version in this format, -- and not for newer versions. -- -- Note that you may use 'deriveSafeCopy' with one version of -- your data type and 'deriveSafeCopyHappstackData' in another version -- without any problems. 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 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 (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 <- mapM (\n -> newName ("a" ++ show n)) [1..conSize con] (putFunsDecs, putFuns) <- case deriveType of Normal -> mkSafeFunctions "safePut_" 'getSafePut con _ -> return ([], const 'safePut) let putClause = conP (conName con) (map varP putVars) putCopyBody = varE 'contain `appE` doE ( [ noBindS $ varE 'putWord8 `appE` litE (IntegerL conNumber) | manyConstructors ] ++ putFunsDecs ++ [ noBindS $ varE (putFuns typ) `appE` varE var | (typ, var) <- zip (conTypes con) putVars ] ++ [ noBindS $ varE 'return `appE` tupE [] ]) clause [putClause] (normalB putCopyBody) [] 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 _ -> do tagVar <- newName "tag" doE [ bindS (varP tagVar) (varE 'getWord8) , noBindS $ caseE (varE tagVar) ( [ match (litP $ IntegerL i) (normalB $ mkGetBody con) [] | (i, con) <- cons ] ++ [ match wildP (normalB $ varE 'fail `appE` errorMsg tagVar) [] ]) ] mkGetBody con = do (getFunsDecs, getFuns) <- case deriveType of Normal -> mkSafeFunctions "safeGet_" 'getSafeGet con _ -> return ([], const 'safeGet) let getBase = appE (varE 'return) (conE (conName con)) getArgs = foldl (\a t -> infixE (Just a) (varE '(<*>)) (Just (varE (getFuns t)))) getBase (conTypes con) doE (getFunsDecs ++ [noBindS getArgs]) errorMsg tagVar = infixE (Just $ strE str1) (varE '(++)) $ Just $ infixE (Just tagStr) (varE '(++)) (Just $ strE str2) where strE = litE . StringL tagStr = varE 'show `appE` varE tagVar str1 = "Could not identify tag \"" str2 = concat [ "\" for type " , show tyName , " that has only " , show (length cons) , " constructors. Maybe your data is corrupted?" ] mkSafeFunctions :: String -> Name -> Con -> Q ([StmtQ], Type -> Name) mkSafeFunctions name baseFun con = do let origTypes = conTypes con realTypes <- mapM followSynonyms origTypes finish (zip origTypes realTypes) <$> foldM go ([], []) realTypes where go (ds, fs) t | found = return (ds, fs) | otherwise = do funVar <- newName (name ++ typeName t) 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" -- | Follow type synonyms. This allows us to see, for example, -- that @[Char]@ and @String@ are the same type and we just need -- to call 'getSafePut' or 'getSafeGet' once for both. followSynonyms :: Type -> Q Type followSynonyms t@(ConT name) = maybe (return t) followSynonyms =<< recover (return Nothing) (do info <- reify name return $ case info of TyVarI _ ty -> Just ty TyConI (TySynD _ _ ty) -> Just ty _ -> Nothing) followSynonyms (AppT ty1 ty2) = liftM2 AppT (followSynonyms ty1) (followSynonyms ty2) followSynonyms (SigT ty k) = liftM (flip SigT k) (followSynonyms ty) followSynonyms t = return t conSize :: Con -> Int conSize (NormalC _name args) = length args conSize (RecC _name recs) = length recs conSize InfixC{} = 2 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 conName (RecC name _recs) = name conName (InfixC _ name _) = name conName _ = error "conName: never here" conTypes :: Con -> [Type] conTypes (NormalC _name args) = [t | (_, t) <- args] conTypes (RecC _name args) = [t | (_, _, t) <- args] conTypes (InfixC (_, t1) _ (_, t2)) = [t1, t2] conTypes _ = error "conName: never here" typeName :: Type -> String typeName (VarT name) = nameBase name typeName (ConT name) = nameBase name typeName (TupleT n) = "Tuple" ++ show n typeName ArrowT = "Arrow" typeName ListT = "List" typeName (AppT t u) = typeName t ++ typeName u typeName (SigT t _k) = typeName t typeName _ = "_" safecopy-0.10.4.2/src/Data/SafeCopy/Instances.hs0000644000000000000000000004473407346545000017406 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, UndecidableInstances, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.SafeCopy.Instances where import Data.SafeCopy.SafeCopy #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad import qualified Data.Array as Array import qualified Data.Array.Unboxed as UArray import qualified Data.Array.IArray as IArray import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as B import qualified Data.Foldable as Foldable import Data.Fixed (HasResolution, Fixed) import Data.Int 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 import Data.Serialize import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Time.Calendar (Day(..)) import Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime(..), UTCTime(..)) 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 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 getCopy = contain $ do e <- unsafeUnPack getCopy return $ Prim e putCopy (Prim e) = contain $ unsafeUnPack (putCopy e) instance SafeCopy a => SafeCopy [a] where 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 getCopy = contain $ do n <- get if n then liftM Just safeGet else return Nothing putCopy (Just a) = contain $ put True >> safePut a putCopy Nothing = contain $ put False errorTypeName = typeName1 instance (SafeCopy a, Ord a) => SafeCopy (Set.Set a) where getCopy = contain $ fmap Set.fromDistinctAscList safeGet putCopy = contain . safePut . Set.toAscList errorTypeName = typeName1 instance (SafeCopy a, SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where getCopy = contain $ fmap Map.fromDistinctAscList safeGet putCopy = contain . safePut . Map.toAscList errorTypeName = typeName2 instance (SafeCopy a) => SafeCopy (IntMap.IntMap a) where getCopy = contain $ fmap IntMap.fromDistinctAscList safeGet putCopy = contain . safePut . IntMap.toAscList errorTypeName = typeName1 instance SafeCopy IntSet.IntSet where getCopy = contain $ fmap IntSet.fromDistinctAscList safeGet putCopy = contain . safePut . IntSet.toAscList errorTypeName = typeName instance (SafeCopy a) => SafeCopy (Sequence.Seq a) where getCopy = contain $ fmap Sequence.fromList safeGet putCopy = contain . safePut . Foldable.toList errorTypeName = typeName1 instance (SafeCopy a) => SafeCopy (Tree.Tree a) where getCopy = contain $ liftM2 Tree.Node safeGet safeGet putCopy (Tree.Node root sub) = contain $ safePut root >> safePut sub errorTypeName = typeName1 iarray_getCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => Contained (Get (a i e)) iarray_getCopy = contain $ do getIx <- getSafeGet liftM3 mkArray getIx getIx safeGet where mkArray l h xs = IArray.listArray (l, h) xs {-# INLINE iarray_getCopy #-} iarray_putCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => a i e -> Contained Put iarray_putCopy arr = contain $ do putIx <- getSafePut let (l,h) = IArray.bounds arr putIx l >> putIx h safePut (IArray.elems arr) {-# INLINE iarray_putCopy #-} instance (Ix i, SafeCopy e, SafeCopy i) => SafeCopy (Array.Array i e) where getCopy = iarray_getCopy putCopy = iarray_putCopy errorTypeName = typeName2 instance (IArray.IArray UArray.UArray e, Ix i, SafeCopy e, SafeCopy i) => SafeCopy (UArray.UArray i e) where getCopy = iarray_getCopy putCopy = iarray_putCopy errorTypeName = typeName2 instance (SafeCopy a, SafeCopy b) => SafeCopy (a,b) where getCopy = contain $ liftM2 (,) safeGet safeGet putCopy (a,b) = contain $ safePut a >> safePut b errorTypeName = typeName2 instance (SafeCopy a, SafeCopy b, SafeCopy c) => SafeCopy (a,b,c) where getCopy = contain $ liftM3 (,,) safeGet safeGet safeGet putCopy (a,b,c) = contain $ safePut a >> safePut b >> safePut c instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d) => SafeCopy (a,b,c,d) where getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet putCopy (a,b,c,d) = contain $ safePut a >> safePut b >> safePut c >> safePut d instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e) => SafeCopy (a,b,c,d,e) where getCopy = contain $ liftM5 (,,,,) safeGet safeGet safeGet safeGet safeGet putCopy (a,b,c,d,e) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f) => SafeCopy (a,b,c,d,e,f) where getCopy = contain $ (,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet putCopy (a,b,c,d,e,f) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e >> safePut f instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g) => SafeCopy (a,b,c,d,e,f,g) where getCopy = contain $ (,,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet putCopy (a,b,c,d,e,f,g) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e >> safePut f >> safePut g instance SafeCopy Int where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Integer where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 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, Typeable) 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, Typeable) 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 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 getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Word32 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Word64 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Ordering where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Int8 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Int16 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Int32 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Int64 where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance (Integral a, SafeCopy a) => SafeCopy (Ratio a) where getCopy = contain $ do n <- safeGet d <- safeGet return (n % d) putCopy r = contain $ do safePut (numerator r) safePut (denominator r) errorTypeName = typeName1 instance (HasResolution a, Fractional (Fixed a), Typeable a) => SafeCopy (Fixed a) where getCopy = contain $ fromRational <$> safeGet putCopy = contain . safePut . toRational errorTypeName = typeName1 instance SafeCopy () where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Bool where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance (SafeCopy a, SafeCopy b) => SafeCopy (Either a b) where getCopy = contain $ do n <- get if n then liftM Right safeGet else liftM Left safeGet putCopy (Right a) = contain $ put True >> safePut a putCopy (Left a) = contain $ put False >> safePut a errorTypeName = typeName2 -- instances for 'text' library instance SafeCopy T.Text where kind = base getCopy = contain $ T.decodeUtf8 <$> safeGet putCopy = contain . safePut . T.encodeUtf8 errorTypeName = typeName instance SafeCopy TL.Text where kind = base getCopy = contain $ TL.decodeUtf8 <$> safeGet putCopy = contain . safePut . TL.encodeUtf8 errorTypeName = typeName -- instances for 'time' library instance SafeCopy Day where kind = base getCopy = contain $ ModifiedJulianDay <$> safeGet putCopy = contain . safePut . toModifiedJulianDay errorTypeName = typeName instance SafeCopy DiffTime where kind = base getCopy = contain $ fromRational <$> safeGet putCopy = contain . safePut . toRational errorTypeName = typeName instance SafeCopy UniversalTime where kind = base getCopy = contain $ ModJulianDate <$> safeGet putCopy = contain . safePut . getModJulianDate errorTypeName = typeName instance SafeCopy UTCTime where kind = base getCopy = contain $ do day <- safeGet diffTime <- safeGet return (UTCTime day diffTime) putCopy u = contain $ do safePut (utctDay u) safePut (utctDayTime u) errorTypeName = typeName instance SafeCopy NominalDiffTime where kind = base getCopy = contain $ fromRational <$> safeGet putCopy = contain . safePut . toRational errorTypeName = typeName instance SafeCopy TimeOfDay where kind = base getCopy = contain $ do hour <- safeGet mins <- safeGet sec <- safeGet return (TimeOfDay hour mins sec) putCopy t = contain $ do safePut (todHour t) safePut (todMin t) safePut (todSec t) errorTypeName = typeName instance SafeCopy TimeZone where kind = base getCopy = contain $ do mins <- safeGet summerOnly <- safeGet zoneName <- safeGet return (TimeZone mins summerOnly zoneName) putCopy t = contain $ do safePut (timeZoneMinutes t) safePut (timeZoneSummerOnly t) safePut (timeZoneName t) errorTypeName = typeName instance SafeCopy LocalTime where kind = base getCopy = contain $ do day <- safeGet tod <- safeGet return (LocalTime day tod) putCopy t = contain $ do safePut (localDay t) safePut (localTimeOfDay t) errorTypeName = typeName instance SafeCopy ZonedTime where kind = base getCopy = contain $ do localTime <- safeGet timeZone <- safeGet return (ZonedTime localTime timeZone) putCopy t = contain $ do safePut (zonedTimeToLocalTime t) safePut (zonedTimeZone t) errorTypeName = typeName instance SafeCopy AbsoluteTime where getCopy = contain $ liftM toAbsoluteTime safeGet where toAbsoluteTime :: DiffTime -> AbsoluteTime toAbsoluteTime dt = addAbsoluteTime dt taiEpoch putCopy = contain . safePut . fromAbsoluteTime where fromAbsoluteTime :: AbsoluteTime -> DiffTime fromAbsoluteTime at = diffAbsoluteTime at taiEpoch errorTypeName = typeName -- instances for old-time instance SafeCopy ClockTime where kind = base getCopy = contain $ do secs <- safeGet pico <- safeGet return (TOD secs pico) putCopy (TOD secs pico) = contain $ do safePut secs safePut pico instance SafeCopy TimeDiff where kind = base getCopy = contain $ do year <- get month <- get day <- get hour <- get mins <- get sec <- get pico <- get return (TimeDiff year month day hour mins sec pico) putCopy t = contain $ do put (tdYear t) put (tdMonth t) put (tdDay t) put (tdHour t) put (tdMin t) put (tdSec t) put (tdPicosec t) instance SafeCopy OT.Day where kind = base ; getCopy = contain $ toEnum <$> get ; putCopy = contain . put . fromEnum instance SafeCopy Month where kind = base ; getCopy = contain $ toEnum <$> get ; putCopy = contain . put . fromEnum instance SafeCopy CalendarTime where kind = base getCopy = contain $ do year <- get month <- safeGet day <- get hour <- get mins <- get sec <- get pico <- get wday <- safeGet yday <- get 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) safePut (ctMonth t) put (ctDay t) put (ctHour t) put (ctMin t) put (ctSec t) put (ctPicosec t) safePut (ctWDay t) put (ctYDay t) safePut (ctTZName t) put (ctTZ t) put (ctIsDST t) 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 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 safecopy-0.10.4.2/src/Data/SafeCopy/Internal.hs0000644000000000000000000000024707346545000017222 0ustar0000000000000000module Data.SafeCopy.Internal ( module Data.SafeCopy.SafeCopy , module Data.SafeCopy.Derive ) where import Data.SafeCopy.SafeCopy import Data.SafeCopy.Derive safecopy-0.10.4.2/src/Data/SafeCopy/SafeCopy.hs0000644000000000000000000005575507346545000017175 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Data.SafeCopy.SafeCopy -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- SafeCopy extends the parsing and serialization capabilities of Data.Binary -- to include nested version control. Nested version control means that you -- can change the defintion and binary format of a type nested deep within -- other types without problems. -- module Data.SafeCopy.SafeCopy where 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. -- -- This type class specifies what data migrations can happen -- and how they happen. class SafeCopy (MigrateFrom a) => Migrate a where -- | This is the type we're extending. Each type capable of migration can -- only extend one other type. type MigrateFrom a -- | This method specifies how to migrate from the older type to the newer -- one. It will never be necessary to use this function manually as it -- 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') 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 -- 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 } -- | The centerpiece of this library. Defines a version for a data type -- together with how it should be serialized/parsed. -- -- Users should define instances of 'SafeCopy' for their types -- even though 'getCopy' and 'putCopy' can't be used directly. -- To serialize/parse a data type using 'SafeCopy', see 'safeGet' -- and 'safePut'. 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) -- but doesn't have to be sequential or continuous. -- -- The default version is '0'. version :: Version a version = Version 0 -- | The kind specifies how versions are dealt with. By default, -- values are tagged with their version id and don't have any -- previous versions. See 'extension' and the much less used -- 'primitive'. kind :: Kind a kind = Base -- | This method defines how a value should be parsed without also worrying -- about writing out the version tag. This function cannot be used directly. -- One should use 'safeGet', instead. getCopy :: Contained (Get a) -- | 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 'safePut, instead. putCopy :: a -> Contained Put -- | Internal function that should not be overrided. -- @Consistent@ iff the version history is consistent -- (i.e. there are no duplicate version numbers) and -- the chain of migrations is valid. -- -- This function is in the typeclass so that this -- information is calculated only once during the program -- lifetime, instead of everytime 'safeGet' or 'safePut' is -- used. internalConsistency :: Consistency a internalConsistency = computeConsistency Proxy -- | 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 default errorTypeName :: Typeable a => Proxy a -> String errorTypeName _ = show (typeRep (Proxy @a)) 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)))) 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 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 (proxyFromKind fail_kind) , ": " , msg ] ------------------------------------------------- -- The public interface. These functions are used -- to parse/serialize and to create new parsers & -- serialisers. -- | Parse a version tagged data type and then migrate it to the desired type. -- Any serialized value has been extended by the return type can be parsed. safeGet :: SafeCopy a => Get a safeGet = join getSafeGet -- | Parse a version tag and return the corresponding migrated parser. This is -- useful when you can prove that multiple values have the same version. -- See 'getSafePut'. getSafeGet :: forall a. SafeCopy a => Get (Get a) getSafeGet = checkConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ unsafeUnPack getCopy 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 -- simpler than the corresponding 'safeGet' since previous versions don't -- come into play. safePut :: SafeCopy a => a -> Put safePut a = do putter <- getSafePut putter a -- | Serialize the version tag and return the associated putter. This is useful -- when serializing multiple values with the same version. See 'getSafeGet'. getSafePut :: forall a. SafeCopy a => PutM (a -> Put) getSafePut = 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 :: Migrate a => Kind a extension = Extends Proxy -- | The default kind. Does not extend any type. base :: Kind a base = Base -- | Primitive kinds aren't version tagged. This kind is used for small or built-in -- types that won't change such as 'Int' or 'Bool'. primitive :: Kind a primitive = Primitive ------------------------------------------------- -- Data type versions. Essentially just a unique -- identifier used to lookup the corresponding -- parser function. -- | A simple numeric version id. newtype Version a = Version {unVersion :: Int32} deriving (Read,Show,Eq) castVersion :: Version a -> Version b castVersion (Version a) = Version a instance Num (Version a) where Version a + Version b = Version (a+b) Version a - Version b = Version (a-b) Version a * Version b = Version (a*b) negate (Version a) = Version (negate a) abs (Version a) = Version (abs a) signum (Version a) = Version (signum a) fromInteger i = Version (fromInteger i) instance Serialize (Version a) where get = liftM Version get put = put . unVersion ------------------------------------------------- -- Container type to control the access to the -- parsers/putters. -- | To ensure that no-one reads or writes values without handling versions -- 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} -- | Place a value in an unbreakable container. contain :: a -> Contained a contain = Contained ------------------------------------------------- -- 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 = 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 = 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 (kindFromProxy c_proxy) Extended sub_kind -> check sub_kind -- Verify that the SafeCopy instance is consistent. checkConsistency :: (SafeCopy a, Fail.MonadFail m) => Proxy a -> m b -> m b checkConsistency proxy ks = case consistentFromProxy proxy of 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 :: 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 for " ++ show (typeRep (Proxy @a)) ++ ": " ++ show versions | not (validChain proxy) = NotConsistent "Primitive types cannot be extended as they have no version tag." | otherwise = Consistent where versions = availableVersions proxy isObviouslyConsistent :: Kind a -> Bool isObviouslyConsistent Primitive = True isObviouslyConsistent Base = True isObviouslyConsistent _ = False ------------------------------------------------- -- Small utility functions that mean we don't -- have to depend on ScopedTypeVariables. 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 ------------------------------------------------- -- Type proxies data Proxy a = Proxy mkProxy :: a -> Proxy a mkProxy _ = Proxy asProxyType :: a -> Proxy a -> a asProxyType a _ = a safecopy-0.10.4.2/test/0000755000000000000000000000000007346545000012715 5ustar0000000000000000safecopy-0.10.4.2/test/generic.hs0000644000000000000000000002411307346545000014666 0ustar0000000000000000{-# 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 ]) safecopy-0.10.4.2/test/instances.hs0000644000000000000000000001265207346545000015246 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Hack for bug in older Cabal versions #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif import Control.Applicative import Control.Lens import Control.Lens.Action import Data.Array (Array) import Data.Array.Unboxed (UArray) import Data.Data.Lens 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.QuickCheck.Instances () 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 #if ! MIN_VERSION_QuickCheck(2,9,0) instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) => Arbitrary (a,b,c,d,e,f) where arbitrary = (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) => Arbitrary (a,b,c,d,e,f,g) where arbitrary = (,,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary #endif #if ! MIN_VERSION_QuickCheck(2,8,2) instance (Arbitrary a) => Arbitrary (V.Vector a) where arbitrary = V.fromList <$> arbitrary instance (Arbitrary a, VP.Prim a) => Arbitrary (VP.Vector a) where arbitrary = VP.fromList <$> arbitrary instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where arbitrary = VS.fromList <$> arbitrary instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where arbitrary = VU.fromList <$> arbitrary #endif 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 #if ! MIN_VERSION_time(1,6,0) deriving instance Show UniversalTime #endif -- | 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) #if !MIN_VERSION_template_haskell(2,10,0) classes <- mapM reify [ name | ClassP name _ <- preds ] #else -- print preds classes <- case preds of [ForallT _ cxt' _] -> mapM reify [ name | AppT (ConT name) _ <- cxt' ] _ -> error "FIXME: fix this code to handle this case." -- classes <- mapM reify [ ] #endif def <- a #if MIN_VERSION_template_haskell(2,11,0) let instances (ClassI _ decs) = [ typ | InstanceD _ _ (AppT _ typ) _ <- decs ] #else let instances (ClassI _ decs) = [ typ | InstanceD _ (AppT _ typ) _ <- decs ] #endif 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 #if !MIN_VERSION_template_haskell(2,8,0) -- 'report' throws warnings in template-haskell-2.8.0.0 reportWarning = report False #endif 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 ]