safecopy 0.7.2 → 0.8.0
raw patch · 4 files changed
+90/−40 lines, 4 filesdep ~cereal
Dependency ranges changed: cereal
Files
- safecopy.cabal +1/−1
- src/Data/SafeCopy.hs +4/−1
- src/Data/SafeCopy/Derive.hs +7/−7
- src/Data/SafeCopy/SafeCopy.hs +78/−31
safecopy.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.7.2+Version: 0.8.0 -- A short (one-line) description of the package. Synopsis: Binary serialization with version control.
src/Data/SafeCopy.hs view
@@ -76,8 +76,12 @@ , SafeCopy(version, kind, getCopy, putCopy, errorTypeName) , Prim(..) , Migrate(..)+ , Reverse(..) , Kind , extension+ , extended_extension+ , extended_base+ , base , Contained , contain , Version@@ -94,7 +98,6 @@ , getSafeGet , getSafePut , primitive- , base ) where import Data.SafeCopy.Instances ()
src/Data/SafeCopy/Derive.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, CPP #-} module Data.SafeCopy.Derive ( deriveSafeCopy@@ -16,8 +16,9 @@ import Control.Applicative import Control.Monad import Data.Maybe (fromMaybe)-import Data.Typeable (Typeable, typeOf)+#ifdef __HADDOCK__ import Data.Word (Word8) -- Haddock+#endif -- | Derive an instance of 'SafeCopy'. --@@ -233,14 +234,13 @@ worker context tyvars [(0, con)] _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) where- typeName = show tyName worker = worker' (conT tyName) worker' tyBase context tyvars cons = let ty = foldl appT tyBase [ varT var | PlainTV var <- tyvars ] in (:[]) <$> instanceD (cxt $ [classP ''SafeCopy [varT var] | PlainTV var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons- , mkGetCopy deriveType typeName 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)) []]@@ -268,16 +268,16 @@ return $ concat decs _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) where- typeName = unwords $ map show (tyName:tyIndex')+ typeNameStr = unwords $ map show (tyName:tyIndex') worker' tyBase context tyvars cons = let ty = foldl appT tyBase [ varT var | PlainTV var <- tyvars ] in (:[]) <$> instanceD (cxt $ [classP ''SafeCopy [varT var] | PlainTV var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons- , mkGetCopy deriveType typeName 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 typeName) []]+ , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] ] mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ
src/Data/SafeCopy/SafeCopy.hs view
@@ -41,6 +41,9 @@ -- 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@@ -56,6 +59,7 @@ Primitive :: Kind a Base :: Kind a Extends :: (Migrate a) => Proxy (MigrateFrom a) -> Kind a+ Extended :: (Migrate (Reverse a)) => Kind a -> Kind a -- | Wrapper for data that was saved without a version tag. newtype Prim a = Prim { getPrimitive :: a }@@ -124,24 +128,37 @@ #endif -constructGetterFromVersion :: SafeCopy a => Version a -> Proxy a -> Get a-constructGetterFromVersion diskVersion a_proxy- | version == diskVersion = unsafeUnPack getCopy- | otherwise = case kindFromProxy a_proxy of- Primitive -> fail $ errorMsg "Cannot migrate from primitive types."- Base ->- fail $- errorMsg $- "Cannot find getter associated with this version number: " ++ show diskVersion- Extends b_proxy- -> do previous <- constructGetterFromVersion (castVersion diskVersion) b_proxy- return $! migrate previous-+-- constructGetterFromVersion :: SafeCopy a => Version a -> Kind (MigrateFrom (Reverse a)) -> Get (Get a)+constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a)+constructGetterFromVersion diskVersion orig_kind =+ worker False diskVersion orig_kind where- errorMsg msg =+ worker :: forall a. SafeCopy a => Bool -> Version a -> Kind a -> Either String (Get a)+ worker fwd thisVersion thisKind+ | version == thisVersion = return $ unsafeUnPack getCopy+ | otherwise =+ case thisKind of+ Primitive -> Left $ errorMsg thisKind "Cannot migrate from primitive types."+ Base -> Left $ errorMsg thisKind versionNotFound+ Extends b_proxy -> do+ previousGetter <- worker fwd (castVersion diskVersion) (kindFromProxy b_proxy)+ return $ fmap migrate previousGetter+ Extended{} | fwd -> Left $ errorMsg thisKind versionNotFound+ Extended a_kind -> do+ let rev_proxy :: Proxy (MigrateFrom (Reverse a))+ rev_proxy = Proxy+ forwardGetter :: Either String (Get a)+ forwardGetter = fmap (fmap (unReverse . migrate)) $ worker True (castVersion thisVersion) (kindFromProxy rev_proxy)+ previousGetter :: Either String (Get a)+ previousGetter = worker fwd (castVersion thisVersion) a_kind+ case forwardGetter of+ Left{} -> previousGetter+ Right val -> Right val+ versionNotFound = "Cannot find getter associated with this version number: " ++ show diskVersion+ errorMsg fail_kind msg = concat [ "safecopy: "- , errorTypeName a_proxy+ , errorTypeName (proxyFromKind fail_kind) , ": " , msg ]@@ -165,8 +182,10 @@ = checkConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ unsafeUnPack getCopy- _ -> do v <- get- return $ constructGetterFromVersion v proxy+ a_kind -> do v <- get+ case constructGetterFromVersion v a_kind of+ Right getter -> return getter+ Left msg -> fail msg where proxy = Proxy :: Proxy a -- | Serialize a data type by first writing out its version tag. This is much@@ -188,6 +207,16 @@ 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@@ -249,25 +278,34 @@ data Consistency a = Consistent | NotConsistent String availableVersions :: SafeCopy a => Proxy a -> [Int32]-availableVersions a_proxy- = case kindFromProxy a_proxy of- Primitive -> []- Base -> [unVersion (versionFromProxy a_proxy)]- Extends b_proxy ->unVersion (versionFromProxy a_proxy) : availableVersions b_proxy+availableVersions a_proxy =+ worker True (kindFromProxy a_proxy)+ where+ worker :: SafeCopy b => Bool -> Kind b -> [Int32]+ worker fwd b_kind =+ case b_kind of+ Primitive -> []+ Base -> [unVersion (versionFromKind b_kind)]+ Extends b_proxy -> unVersion (versionFromKind b_kind) : worker False (kindFromProxy b_proxy)+ Extended sub_kind | fwd -> worker False sub_kind+ Extended sub_kind -> worker False sub_kind -- Extend chains must end in a Base kind. Ending in a Primitive is an error. validChain :: SafeCopy a => Proxy a -> Bool-validChain a_proxy- = case kindFromProxy a_proxy of- Primitive -> True- Base -> True- Extends b_proxy -> check b_proxy- where check :: SafeCopy b => Proxy b -> Bool- check b_proxy- = case kindFromProxy b_proxy of+validChain a_proxy =+ worker (kindFromProxy a_proxy)+ where+ worker Primitive = True+ worker Base = True+ worker (Extends b_proxy) = check (kindFromProxy b_proxy)+ worker (Extended a_kind) = worker a_kind+ check :: SafeCopy b => Kind b -> Bool+ check b_kind+ = case b_kind of Primitive -> False Base -> True- Extends c_proxy -> check c_proxy+ Extends c_proxy -> check (kindFromProxy c_proxy)+ Extended sub_kind -> check sub_kind -- Verify that the SafeCopy instance is consistent. checkConsistency :: (SafeCopy a, Monad m) => Proxy a -> m b -> m b@@ -303,11 +341,20 @@ proxyFromConsistency :: Consistency a -> Proxy a proxyFromConsistency _ = Proxy +proxyFromKind :: Kind a -> Proxy a+proxyFromKind _ = Proxy+ consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a consistentFromProxy _ = internalConsistency versionFromProxy :: SafeCopy a => Proxy a -> Version a versionFromProxy _ = version++versionFromKind :: (SafeCopy a) => Kind a -> Version a+versionFromKind _ = version++versionFromReverseKind :: (SafeCopy a, SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a))+versionFromReverseKind _ = version kindFromProxy :: SafeCopy a => Proxy a -> Kind a kindFromProxy _ = kind