safecopy-0.9.4.3/0000755000000000000000000000000013410721623011663 5ustar0000000000000000safecopy-0.9.4.3/CHANGELOG.md0000644000000000000000000000165513410721623013503 0ustar00000000000000000.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.9.4.3/safecopy.cabal0000644000000000000000000000463713410721623014472 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.9.4.3 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 -- Copyright: Category: Data, Parsing Build-type: Simple Extra-source-files: CHANGELOG.md Cabal-version: >=1.8 tested-with: GHC==7.8.4, GHC==7.10.2, GHC==8.0.2, GHC==8.2.1, GHC==8.4.1 Source-repository head type: git location: git://github.com/acid-state/safecopy.git Library -- 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.5 && <5, array < 0.6, cereal >= 0.5 && < 0.6, bytestring < 0.11, containers >= 0.3 && < 0.7, old-time < 1.2, template-haskell < 2.15, text < 1.3, time < 1.10, vector >= 0.10 && < 0.13 if !impl(ghc > 8.0) Build-Depends: semigroups >= 0.18 && < 0.19 -- Modules not exported by this package. Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy, Data.SafeCopy.Derive -- 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 if(impl(ghc >= 7.1)) cpp-options: -DSAFE_HASKELL Test-suite instances 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.0, lens-action, tasty, tasty-quickcheck, quickcheck-instances, QuickCheck safecopy-0.9.4.3/Setup.hs0000644000000000000000000000005613410721623013320 0ustar0000000000000000import Distribution.Simple main = defaultMain safecopy-0.9.4.3/src/0000755000000000000000000000000013410721623012452 5ustar0000000000000000safecopy-0.9.4.3/src/Data/0000755000000000000000000000000013410721623013323 5ustar0000000000000000safecopy-0.9.4.3/src/Data/SafeCopy.hs0000644000000000000000000000742513410721623015400 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) , 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.9.4.3/src/Data/SafeCopy/0000755000000000000000000000000013410721623015034 5ustar0000000000000000safecopy-0.9.4.3/src/Data/SafeCopy/Derive.hs0000644000000000000000000005034313410721623016613 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 #if MIN_VERSION_template_haskell(2,8,0) import Language.Haskell.TH hiding (Kind) #else import Language.Haskell.TH hiding (Kind(..)) #endif #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad import Data.Maybe (fromMaybe) #ifdef __HADDOCK__ 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 tyVarName :: TyVarBndr -> Name tyVarName (PlainTV n) = n #if MIN_VERSION_template_haskell(2,10,0) tyVarName (KindedTV n _) = n #endif internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec] internalDeriveSafeCopy deriveType versionId kindName tyName = do 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 #if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD context _name tyvars _kind cons _derivs) #else TyConI (DataD context _name tyvars cons _derivs) #endif | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ ". The datatype must have less than 256 constructors." | otherwise -> worker context tyvars (zip [0..] cons) #if MIN_VERSION_template_haskell(2,11,0) TyConI (NewtypeD context _name tyvars _kind con _derivs) -> #else TyConI (NewtypeD context _name tyvars con _derivs) -> #endif worker context tyvars [(0, con)] FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of #if MIN_VERSION_template_haskell(2,11,0) DataInstD context _name ty _kind cons _derivs -> #else DataInstD context _name ty cons _derivs -> #endif worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) #if MIN_VERSION_template_haskell(2,11,0) NewtypeInstD context _name ty _kind con _derivs -> #else NewtypeInstD context _name ty con _derivs -> #endif worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) return $ concat decs _ -> 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 ] #if MIN_VERSION_template_haskell(2,10,0) safeCopyClass args = foldl appT (conT ''SafeCopy) args #else safeCopyClass args = classP ''SafeCopy args #endif in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons , 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,11,0) DataInstD context _name ty _kind cons _derivs #else DataInstD context _name ty cons _derivs #endif | ty == tyIndex -> worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) | otherwise -> return [] #if MIN_VERSION_template_haskell(2,11,0) NewtypeInstD context _name ty _kind con _derivs #else NewtypeInstD context _name ty con _derivs #endif | ty == tyIndex -> worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] | otherwise -> 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 ] #if MIN_VERSION_template_haskell(2,10,0) safeCopyClass args = foldl appT (conT ''SafeCopy) args #else safeCopyClass args = classP ''SafeCopy args #endif in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons , 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." #if MIN_VERSION_template_haskell(2,11,0) conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." #endif conName :: Con -> Name conName (NormalC name _args) = name 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.9.4.3/src/Data/SafeCopy/Instances.hs0000644000000000000000000004513413410721623017326 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 #if MIN_VERSION_base(4,7,0) import Data.Typeable hiding (Proxy) #else import Data.Typeable #endif import Data.Word #if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural) #endif import System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..)) import qualified System.Time as OT import qualified Data.Vector as V 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 #if MIN_VERSION_base(4,8,0) instance SafeCopy Natural where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName #endif -- | cereal change the formats for Float/Double in 0.5.* -- -- 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 change 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)) => 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.9.4.3/src/Data/SafeCopy/Internal.hs0000644000000000000000000000024713410721623017147 0ustar0000000000000000module Data.SafeCopy.Internal ( module Data.SafeCopy.SafeCopy , module Data.SafeCopy.Derive ) where import Data.SafeCopy.SafeCopy import Data.SafeCopy.Derive safecopy-0.9.4.3/src/Data/SafeCopy/SafeCopy.hs0000644000000000000000000003467413410721623017117 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif ----------------------------------------------------------------------------- -- | -- 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 Data.Serialize import Control.Monad import Data.Int (Int32) import Data.List -- | 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') tells 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 -- 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 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 'safeGet', 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. -- Feel free to leave undefined in your instances. errorTypeName :: Proxy a -> String errorTypeName _ = "" #ifdef DEFAULT_SIGNATURES default getCopy :: Serialize a => Contained (Get a) getCopy = contain get default putCopy :: Serialize a => a -> Contained Put putCopy = contain . put #endif -- 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 = checkConsistency 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 :: (SafeCopy a, 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 = 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 -- correct, 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, Monad m) => Proxy a -> m b -> m b checkConsistency proxy ks = case consistentFromProxy proxy of NotConsistent msg -> fail msg Consistent -> ks {-# INLINE computeConsistency #-} computeConsistency :: 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 | 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 a, 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.9.4.3/test/0000755000000000000000000000000013410721623012642 5ustar0000000000000000safecopy-0.9.4.3/test/instances.hs0000644000000000000000000001265213410721623015173 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 ]