diff --git a/safecopy.cabal b/safecopy.cabal --- a/safecopy.cabal +++ b/safecopy.cabal @@ -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. diff --git a/src/Data/SafeCopy.hs b/src/Data/SafeCopy.hs --- a/src/Data/SafeCopy.hs +++ b/src/Data/SafeCopy.hs @@ -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 () diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -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 diff --git a/src/Data/SafeCopy/SafeCopy.hs b/src/Data/SafeCopy/SafeCopy.hs --- a/src/Data/SafeCopy/SafeCopy.hs +++ b/src/Data/SafeCopy/SafeCopy.hs @@ -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