safecopy-store (empty) → 0.9.2
raw patch · 10 files changed
+1761/−0 lines, 10 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, bytestring, containers, lens, lens-action, old-time, quickcheck-instances, safecopy-store, store, store-core, tasty, tasty-quickcheck, template-haskell, text, time, vector
Files
- CHANGELOG.md +23/−0
- Setup.hs +2/−0
- safecopy-store.cabal +66/−0
- src/Data/SafeCopy/Store.hs +116/−0
- src/Data/SafeCopy/Store/Derive.hs +462/−0
- src/Data/SafeCopy/Store/Encode.hs +51/−0
- src/Data/SafeCopy/Store/Instances.hs +468/−0
- src/Data/SafeCopy/Store/Internal.hs +9/−0
- src/Data/SafeCopy/Store/SafeCopy.hs +394/−0
- test/instances.hs +170/−0
+ CHANGELOG.md view
@@ -0,0 +1,23 @@+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)++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ safecopy-store.cabal view
@@ -0,0 +1,66 @@+-- 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-store+Version: 0.9.2+Synopsis: Binary serialization with version control.+Description: Fork of safecopy that uses store instead of cereal.+Homepage: https://github.com/NCrashed/safecopy+License: PublicDomain+Author: David Himmelstrup, Felipe Lessa, Anton Gushcha+Maintainer: Anton Gushcha <ncrashed@gmail.com>+-- Copyright:+Category: Data, Parsing+Build-type: Simple+Extra-source-files: CHANGELOG.md+Cabal-version: >=1.8+tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1++Source-repository head+ type: git+ location: git://github.com/NCrashed/safecopy.git++Library+ -- Modules exported by the library.+ Exposed-modules: Data.SafeCopy.Store+ Data.SafeCopy.Store.Internal++ Hs-Source-Dirs: src/++ -- Packages needed in order to build this package.+ Build-depends: base >=4.5 && <5,+ array < 0.6,+ bytestring < 0.11,+ containers >= 0.3 && < 0.6,+ old-time < 1.2,+ store >= 0.3 && < 0.4,+ store-core >= 0.3 && < 0.4,+ template-haskell < 2.12,+ text < 1.3,+ time < 1.7,+ vector >= 0.10 && < 0.12++ -- Modules not exported by this package.+ Other-modules: Data.SafeCopy.Store.Instances, Data.SafeCopy.Store.SafeCopy,+ Data.SafeCopy.Store.Derive, Data.SafeCopy.Store.Encode++ -- 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, store, template-haskell, safecopy-store,+ containers, time, array, vector, lens >= 4.7 && < 5.0,+ lens-action, tasty, tasty-quickcheck, quickcheck-instances, QuickCheck
+ src/Data/SafeCopy/Store.hs view
@@ -0,0 +1,116 @@+{-# 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.Store+ (+ safeGet+ , safePut+ , SafeCopy(version, kind, getCopy, putCopy, objectProfile, errorTypeName)+ , Encode+ , runEncode+ , PeekException+ , 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.Store.Derive+import Data.SafeCopy.Store.Encode+import Data.SafeCopy.Store.Instances ()+import Data.SafeCopy.Store.SafeCopy+import Data.Store
+ src/Data/SafeCopy/Store/Derive.hs view
@@ -0,0 +1,462 @@+{-# 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.Store.Derive where++import Data.Store+import Data.SafeCopy.Store.Encode+import Data.SafeCopy.Store.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 a@(T0 arg1 arg2) = contain $ do put_b <- getSafePut+-- put_Int <- getSafePut+-- put_b arg1+-- put_Int arg2+-- return a+-- 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 a@(C arg1 arg2) = contain $ do putWord8 0+-- put_a <- getSafePut+-- put_a arg1+-- put_a arg2+-- return a+-- putCopy a@(D arg1 arg2) = contain $ do putWord8 1+-- put_b <- getSafePut+-- put_Int <- getSafePut+-- put_b arg1+-- put_Int arg2+-- return a+-- 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 a@(C arg1 arg2) = contain $ do putWord8 0+-- safePut arg1+-- safePut arg2+-- return a+-- putCopy a@(D arg1 arg2) = contain $ do putWord8 1+-- safePut arg1+-- safePut arg2+-- return a+-- 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 a@(T0 arg1 arg2) = contain $ do putWord8 0+-- safePut arg1+-- safePut arg2+-- return a+-- 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 <- replicateM (conSize con) (newName "arg")+ (putFunsDecs, putFuns) <- case deriveType of+ Normal -> mkSafeFunctions "safePut_" 'getSafePut con+ _ -> return ([], const 'safePut)+ asName <- newName "a"+ let putClause = asP asName $ conP (conName con) (map varP putVars)+ putCopyBody = varE 'contain `appE` doE (+ [ bindS wildP $ varE 'pokeE `appE` litE (IntegerL conNumber) | manyConstructors ] +++ putFunsDecs +++ [ bindS wildP $ varE (putFuns typ) `appE` varE var | (typ, var) <- zip (conTypes con) putVars ] +++ [ noBindS $ varE 'return `appE` varE asName ])+ clause [putClause] (normalB putCopyBody) []++mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ+mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` mkLabel) []+ where+ mkLabel = getCopyBody+ getCopyBody+ = case cons of+ [(_, con)] | not (forceTag deriveType) -> mkGetBody con+ _ -> do+ tagVar <- newName "tag"+ doE [ bindS (varP tagVar) (varE 'poke)+ , 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 _ = "_"
+ src/Data/SafeCopy/Store/Encode.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.SafeCopy.Store.Encode where++import Data.ByteString (ByteString)+import Data.Monoid+import Data.Store+import Data.Store.Core++data Encode a = Encode {-# UNPACK #-} !Int !(Poke ()) !a++instance Monoid a => Monoid (Encode a) where+ mempty = Encode 0 (Poke $ \_ offset -> pure (offset, ())) mempty+ {-# INLINE mempty #-}++ (Encode len1 f1 a1) `mappend` (Encode len2 f2 a2) = Encode (len1 + len2) (f1 *> f2) (a1 <> a2)+ {-# INLINE mappend #-}++instance Functor Encode where+ fmap f (Encode l p a) = Encode l p (f a)+ {-# INLINE fmap #-}++instance Applicative Encode where+ pure = Encode 0 (Poke $ \_ offset -> pure (offset, ()))+ {-# INLINE pure #-}++ (Encode len1 f1 af) <*> (Encode len2 f2 b) = Encode (len1 + len2) (f1 *> f2) (af b)+ {-# INLINE (<*>) #-}++instance Monad Encode where+ return = pure+ {-# INLINE return #-}++ (Encode len1 f1 a) >>= ef = case ef a of+ Encode len2 f2 b -> Encode (len1 + len2) (f1 *> f2) b+ {-# INLINE (>>=) #-}++getEncodeLen :: Encode a -> Int+getEncodeLen (Encode len _ _) = len+{-# INLINE getEncodeLen #-}++runEncode :: Encode a -> ByteString+runEncode (Encode len f _) = unsafeEncodeWith f len+{-# INLINE runEncode #-}++pokeE :: forall a . Store a => a -> Encode a+pokeE v = Encode len (poke v) v+ where+ len = case (size :: Size a) of+ VarSize sf -> sf v+ ConstSize cs -> cs+{-# INLINE pokeE #-}
+ src/Data/SafeCopy/Store/Instances.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, UndecidableInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.SafeCopy.Store.Instances where++import Data.SafeCopy.Store.SafeCopy+import Data.SafeCopy.Store.Encode++#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.Map as Map+import Data.Ratio (Ratio, (%), numerator, denominator)+import qualified Data.Sequence as Sequence+import Data.Store+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+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) >> pure (Prim e)++instance SafeCopy a => SafeCopy [a] where+ getCopy = contain $ do+ n <- peek+ g <- getSafeGet+ go g [] n+ where+ go :: Peek a -> [a] -> Int -> Peek [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 void $ pokeE (length lst)+ getSafePut >>= forM lst+ errorTypeName = typeName1++instance SafeCopy a => SafeCopy (Maybe a) where+ getCopy = contain $ do n <- peek+ if n then fmap Just safeGet+ else return Nothing+ putCopy (Just a) = contain $ pokeE True >> safePut a >> pure (Just a)+ putCopy Nothing = contain $ pokeE False >> pure Nothing+ errorTypeName = typeName1++instance (SafeCopy a, Ord a) => SafeCopy (Set.Set a) where+ getCopy = contain $ fmap Set.fromDistinctAscList safeGet+ putCopy a = contain $ safePut (Set.toAscList a) >> pure a+ errorTypeName = typeName1++instance (SafeCopy a, SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where+ getCopy = contain $ fmap Map.fromDistinctAscList safeGet+ putCopy a = contain $ safePut (Map.toAscList a) >> pure a+ errorTypeName = typeName2++instance (SafeCopy a) => SafeCopy (IntMap.IntMap a) where+ getCopy = contain $ fmap IntMap.fromDistinctAscList safeGet+ putCopy a = contain $ safePut (IntMap.toAscList a) >> pure a+ errorTypeName = typeName1++instance SafeCopy IntSet.IntSet where+ getCopy = contain $ fmap IntSet.fromDistinctAscList safeGet+ putCopy a = contain $ safePut (IntSet.toAscList a) >> pure a+ errorTypeName = typeName++instance (SafeCopy a) => SafeCopy (Sequence.Seq a) where+ getCopy = contain $ fmap Sequence.fromList safeGet+ putCopy a = contain $ safePut (Foldable.toList a) >> pure a+ errorTypeName = typeName1++instance (SafeCopy a) => SafeCopy (Tree.Tree a) where+ getCopy = contain $ liftM2 Tree.Node safeGet safeGet+ putCopy a@(Tree.Node root sub) = contain $ safePut root >> safePut sub >> pure a+ errorTypeName = typeName1++iarray_getCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => Contained (Peek (a i e))+iarray_getCopy = contain $ do getIx <- getSafeGet+ liftM3 mkArray getIx getIx safeGet+ where+ mkArray l h = IArray.listArray (l, h)+{-# INLINE iarray_getCopy #-}++iarray_putCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => a i e -> Contained (Encode (a i e))+iarray_putCopy arr = contain $ do putIx <- getSafePut+ let (l,h) = IArray.bounds arr+ _ <- putIx l >> putIx h+ _ <- safePut (IArray.elems arr)+ pure 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 >> pure (a,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 >> pure (a,b,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 >> pure (a,b,c,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 >> pure (a,b,c,d,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 >> pure (a,b,c,d,e,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 >> pure (a,b,c,d,e,f,g)+++instance SafeCopy Int where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Integer where+ getCopy = contain peek; putCopy = contain . pokeE; 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 CerealFloat040 = CerealFloat040 { unCerealFloat040 :: Float} deriving (Show, Typeable)+instance SafeCopy CerealFloat040 where+ getCopy = contain (CerealFloat040 <$> liftM2 encodeFloat peek peek)+ putCopy a@(CerealFloat040 float) = contain $ pokeE (decodeFloat float) >> pure a+ 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 peek+ putCopy = contain . pokeE+ 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 peek peek)+ putCopy a@(CerealDouble040 double) = contain $ pokeE (decodeFloat double) >> pure a+ 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 peek+ putCopy = contain . pokeE+ errorTypeName = typeName++instance Store Ordering++instance SafeCopy L.ByteString where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy B.ByteString where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Char where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Word where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Word8 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Word16 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Word32 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Word64 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Ordering where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Int8 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Int16 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Int32 where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Int64 where+ getCopy = contain peek; putCopy = contain . pokeE; 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 void $ safePut (numerator r)+ void $ safePut (denominator r)+ pure r+ errorTypeName = typeName1+instance (HasResolution a, Fractional (Fixed a)) => SafeCopy (Fixed a) where+ getCopy = contain $ fromRational <$> safeGet+ putCopy a = contain $ safePut (toRational a) >> pure a+ errorTypeName = typeName1++instance SafeCopy () where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance SafeCopy Bool where+ getCopy = contain peek; putCopy = contain . pokeE; errorTypeName = typeName+instance (SafeCopy a, SafeCopy b) => SafeCopy (Either a b) where+ getCopy = contain $ do n <- peek+ if n then fmap Right safeGet+ else fmap Left safeGet+ putCopy e@(Right a) = contain $ pokeE True >> safePut a >> pure e+ putCopy e@(Left a) = contain $ pokeE False >> safePut a >> pure e++ errorTypeName = typeName2++-- instances for 'text' library++instance SafeCopy T.Text where+ kind = base+ getCopy = contain $ T.decodeUtf8 <$> safeGet+ putCopy e = contain $ safePut (T.encodeUtf8 e) >> pure e+ errorTypeName = typeName++instance SafeCopy TL.Text where+ kind = base+ getCopy = contain $ TL.decodeUtf8 <$> safeGet+ putCopy e = contain $ safePut (TL.encodeUtf8 e) >> pure e+ errorTypeName = typeName++-- instances for 'time' library++instance SafeCopy Day where+ kind = base+ getCopy = contain $ ModifiedJulianDay <$> safeGet+ putCopy e = contain $ safePut (toModifiedJulianDay e) >> pure e+ errorTypeName = typeName++instance SafeCopy DiffTime where+ kind = base+ getCopy = contain $ fromRational <$> safeGet+ putCopy e = contain $ safePut (toRational e) >> pure e+ errorTypeName = typeName++instance SafeCopy UniversalTime where+ kind = base+ getCopy = contain $ ModJulianDate <$> safeGet+ putCopy e = contain $ safePut (getModJulianDate e) >> pure e+ errorTypeName = typeName++instance SafeCopy UTCTime where+ kind = base+ getCopy = contain $ do day <- safeGet+ diffTime <- safeGet+ return (UTCTime day diffTime)+ putCopy u = contain $ do void $ safePut (utctDay u)+ void $ safePut (utctDayTime u)+ pure u+ errorTypeName = typeName++instance SafeCopy NominalDiffTime where+ kind = base+ getCopy = contain $ fromRational <$> safeGet+ putCopy e = contain $ safePut (toRational e) >> pure e+ 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 void $ safePut (todHour t)+ void $ safePut (todMin t)+ void $ safePut (todSec t)+ pure 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 void $ safePut (timeZoneMinutes t)+ void $ safePut (timeZoneSummerOnly t)+ void $ safePut (timeZoneName t)+ pure t+ errorTypeName = typeName++instance SafeCopy LocalTime where+ kind = base+ getCopy = contain $ do day <- safeGet+ tod <- safeGet+ return (LocalTime day tod)+ putCopy t = contain $ do void $ safePut (localDay t)+ void $ safePut (localTimeOfDay t)+ pure t+ errorTypeName = typeName++instance SafeCopy ZonedTime where+ kind = base+ getCopy = contain $ do localTime <- safeGet+ timeZone <- safeGet+ return (ZonedTime localTime timeZone)+ putCopy t = contain $ do void $ safePut (zonedTimeToLocalTime t)+ void $ safePut (zonedTimeZone t)+ pure t+ errorTypeName = typeName++instance SafeCopy AbsoluteTime where+ getCopy = contain $ fmap toAbsoluteTime safeGet+ where+ toAbsoluteTime :: DiffTime -> AbsoluteTime+ toAbsoluteTime dt = addAbsoluteTime dt taiEpoch+ putCopy e = contain $ safePut (fromAbsoluteTime e) >> pure e+ 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 e@(TOD secs pico) =+ contain $ do void $ safePut secs+ void $ safePut pico+ pure e++instance SafeCopy TimeDiff where+ kind = base+ getCopy = contain $ do year <- peek+ month <- peek+ day <- peek+ hour <- peek+ mins <- peek+ sec <- peek+ pico <- peek+ return (TimeDiff year month day hour mins sec pico)+ putCopy t = contain $ do void $ pokeE (tdYear t)+ void $ pokeE (tdMonth t)+ void $ pokeE (tdDay t)+ void $ pokeE (tdHour t)+ void $ pokeE (tdMin t)+ void $ pokeE (tdSec t)+ void $ pokeE (tdPicosec t)+ pure t++instance SafeCopy OT.Day where+ kind = base ; getCopy = contain $ toEnum <$> peek ; putCopy a = contain $ pokeE (fromEnum a) >> pure a++instance SafeCopy Month where+ kind = base ; getCopy = contain $ toEnum <$> peek ; putCopy a = contain $ pokeE (fromEnum a) >> pure a+++instance SafeCopy CalendarTime where+ kind = base+ getCopy = contain $ do year <- peek+ month <- safeGet+ day <- peek+ hour <- peek+ mins <- peek+ sec <- peek+ pico <- peek+ wday <- safeGet+ yday <- peek+ tzname <- safeGet+ tz <- peek+ dst <- peek+ return (CalendarTime year month day hour mins sec pico wday yday tzname tz dst)+ putCopy t = contain $ do void $ pokeE (ctYear t)+ void $ safePut (ctMonth t)+ void $ pokeE (ctDay t)+ void $ pokeE (ctHour t)+ void $ pokeE (ctMin t)+ void $ pokeE (ctSec t)+ void $ pokeE (ctPicosec t)+ void $ safePut (ctWDay t)+ void $ pokeE (ctYDay t)+ void $ safePut (ctTZName t)+ void $ pokeE (ctTZ t)+ void $ pokeE (ctIsDST t)+ pure t++typeName :: Typeable a => Proxy a -> String+typeName proxy = show (typeOf (undefined `asProxyType` proxy))++typeName1 :: (Typeable c) => Proxy (c a) -> String+typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy))++typeName2 :: (Typeable c) => Proxy (c a b) -> String+typeName2 proxy = show (typeOf2 (undefined `asProxyType` proxy))++getGenericVector :: (SafeCopy a, VG.Vector v a) => Contained (Peek (v a))+getGenericVector = contain $ do n <- peek+ getSafeGet >>= VG.replicateM n++putGenericVector :: (SafeCopy a, VG.Vector v a) => v a -> Contained (Encode (v a))+putGenericVector v = contain $ do void $ pokeE (VG.length v)+ getSafePut >>= VG.forM v++instance SafeCopy a => SafeCopy (V.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector++instance (SafeCopy a, VP.Prim a) => SafeCopy (VP.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector++instance (SafeCopy a, VS.Storable a) => SafeCopy (VS.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector++instance (SafeCopy a, VU.Unbox a) => SafeCopy (VU.Vector a) where+ getCopy = getGenericVector+ putCopy = putGenericVector
+ src/Data/SafeCopy/Store/Internal.hs view
@@ -0,0 +1,9 @@+module Data.SafeCopy.Store.Internal (+ module Data.SafeCopy.Store.SafeCopy+ , module Data.SafeCopy.Store.Encode+ , module Data.SafeCopy.Store.Derive+ ) where++import Data.SafeCopy.Store.Derive+import Data.SafeCopy.Store.Encode+import Data.SafeCopy.Store.SafeCopy
+ src/Data/SafeCopy/Store/SafeCopy.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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.Store.SafeCopy where++import Data.Store+import Data.SafeCopy.Store.Encode++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 (Peek 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 (Encode a)++ -- | 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 _ = "<unkown type>"++#ifdef DEFAULT_SIGNATURES+ default getCopy :: Store a => Contained (Peek a)+ getCopy = contain peek++ default putCopy :: Store a => a -> Contained (Encode a)+ putCopy = contain . pokeE+#endif+++-- constructGetterFromVersion :: SafeCopy a => Version a -> Kind (MigrateFrom (Reverse a)) -> Get (Peek a)+constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Peek a)+constructGetterFromVersion diskVersion orig_kind =+ worker False diskVersion orig_kind+ where+ worker :: forall a. SafeCopy a => Bool -> Version a -> Kind a -> Either String (Peek 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 (Peek a)+ forwardGetter = fmap (fmap (unReverse . migrate)) $ worker True (castVersion thisVersion) (kindFromProxy rev_proxy)+ previousGetter :: Either String (Peek 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 => Peek 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 => Peek (Peek a)+getSafeGet+ = checkConsistency proxy $+ case kindFromProxy proxy of+ Primitive -> return $ unsafeUnPack getCopy+ a_kind -> do v <- peek+ 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 -> Encode a+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 => Encode (a -> Encode a)+getSafePut+ = checkConsistency proxy $+ case kindFromProxy proxy of+ Primitive -> return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy)+ _ -> do _ <- pokeE (versionFromProxy proxy)+ return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy)+ where proxy = Proxy :: Proxy a++-- | The extended_base kind lets the system know that there is+-- at least 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,Store)++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)++-------------------------------------------------+-- 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
+ test/instances.hs view
@@ -0,0 +1,170 @@+{-# 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.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.Store+import Data.Store (decodeWith)+import Data.Time (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, (===))++#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++data Example = Example {+ exampleField1 :: String+ , exampleField2 :: Bool+ } deriving (Show, Eq)++deriveSafeCopy 1 'base ''Example++instance Arbitrary Example where+ arbitrary = Example <$> arbitrary <*> arbitrary++-- | 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 PeekException a -> a -> Property+Left e === _ = counterexample (show e) False+Right a === b = counterexample (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 = runEncode . safePut+ decode = decodeWith 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 |]+ , [t| Example |]+ ]++ -- 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+ ]