safecopy 0.4.3 → 0.5
raw patch · 5 files changed
+518/−71 lines, 5 filesdep +arraydep +cerealdep +template-haskelldep −binarydep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: array, cereal, template-haskell
Dependencies removed: binary
Dependency ranges changed: base, containers
API changes (from Hackage documentation)
+ Data.SafeCopy: base :: Kind a
+ Data.SafeCopy: deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec]
+ Data.SafeCopy: deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec]
+ Data.SafeCopy: deriveSafeCopySimple :: Version a -> Name -> Name -> Q [Dec]
Files
- safecopy.cabal +15/−12
- src/Data/SafeCopy.hs +16/−8
- src/Data/SafeCopy/Derive.hs +336/−0
- src/Data/SafeCopy/Instances.hs +68/−28
- src/Data/SafeCopy/SafeCopy.hs +83/−23
safecopy.cabal view
@@ -7,13 +7,13 @@ -- 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.4.3+Version: 0.5 -- A short (one-line) description of the package. Synopsis: Binary serialization with version control. -- A longer description of the package.-Description: An extension to Data.Binary with built-in version control.+Description: An extension to Data.Serialize with built-in version control. -- URL for the project homepage or repository. Homepage: http://acid-state.seize.it/safecopy@@ -22,14 +22,14 @@ License: PublicDomain -- The package author(s).-Author: David Himmelstrup+Author: David Himmelstrup, Felipe Lessa -- An email address to which users can send suggestions, bug reports, -- and patches. Maintainer: Lemmih <lemmih@gmail.com> -- A copyright notice.--- Copyright: +-- Copyright: Category: Data, Parsing @@ -37,7 +37,7 @@ -- Extra files to be distributed with the package, such as examples or -- a README.--- Extra-source-files: +-- Extra-source-files: -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.6@@ -48,13 +48,16 @@ Exposed-modules: Data.SafeCopy Hs-Source-Dirs: src/- + -- Packages needed in order to build this package.- Build-depends: base >=4 && <5, binary, bytestring, containers- + Build-depends: base >=4 && <5, array, cereal >= 0.3.1.0, bytestring, containers >= 0.3,+ template-haskell+ -- Modules not exported by this package.- Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy- + Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy,+ Data.SafeCopy.Derive+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.- -- Build-tools: - + -- Build-tools:++ GHC-Options: -Wall
src/Data/SafeCopy.hs view
@@ -6,9 +6,9 @@ -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) ----- SafeCopy extends the parsing and serialization capabilities of Data.Binary+-- SafeCopy extends the parsing and serialization capabilities of Data.Serialize -- to include nested version control. Nested version control means that you--- can change the defintion and binary format of a type nested deep within+-- 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@@ -23,8 +23,8 @@ -- getCopy = contain $ Contacts \<$\> safeGet -- @ ----- At this point, everything is fine. You get the awesome speed of Data.Binary--- together with Haskell's easy of use. However, things quickly takes a turn for the worse+-- 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@@ -42,7 +42,7 @@ --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 }@@ -70,21 +70,29 @@ -- 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(..)+ , SafeCopy(version, kind, getCopy, putCopy) , Migrate(..) , Kind , extension , Contained , contain , Version++ -- * Template haskell functions+ , deriveSafeCopy+ , deriveSafeCopySimple+ , deriveSafeCopyHappstackData+ -- * Rarely used functions , getSafeGet , getSafePut , primitive+ , base ) where -import Data.SafeCopy.Instances+import Data.SafeCopy.Instances () import Data.SafeCopy.SafeCopy+import Data.SafeCopy.Derive
+ src/Data/SafeCopy/Derive.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.SafeCopy.Derive+ (+ deriveSafeCopy+ , deriveSafeCopySimple+ , deriveSafeCopyHappstackData+ ) where++import Data.Serialize (getWord8, putWord8)+import Data.SafeCopy.SafeCopy++import Language.Haskell.TH hiding (Kind(..))+import Control.Applicative+import Control.Monad+import Data.Maybe (fromMaybe)+import Data.Word (Word8) -- Haddock++-- | 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++-- | 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++-- | 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++data DeriveType = Normal | Simple | HappstackData++forceTag :: DeriveType -> Bool+forceTag HappstackData = True+forceTag _ = False++internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec]+internalDeriveSafeCopy deriveType versionId kindName tyName+ = do info <- reify tyName+ case info of+ TyConI (DataD context _name tyvars cons _derivs)+ | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName +++ ". The datatype must have less than 256 constructors."+ | otherwise -> worker context tyvars (zip [0..] cons)+ TyConI (NewtypeD context _name tyvars con _derivs)+ -> worker context tyvars [(0, con)]+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)+ where worker context tyvars cons+ = let ty = foldl appT (conT tyName) [ 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 tyName cons+ , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []+ , valD (varP 'kind) (normalB (varE kindName)) []+ ]++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)+ 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 -> Name -> [(Integer, Con)] -> DecQ+mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` getCopyBody) []+ where+ 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 typeList (ds, fs) = (reverse ds, getName)+ where getName typ = fromMaybe err $ lookup typ typeList >>= flip lookup fs+ err = error "mkSafeFunctions: never here"+ -- We can't use a Data.Map because Type isn't a member of Ord =/...++-- | 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 complex constructor. Cannot derive SafeCopy for it."++conName :: Con -> Name+conName (NormalC name _args) = name+conName (RecC name _recs) = name+conName (InfixC _ name _) = name+conName _ = error "conName: never here"++conTypes :: Con -> [Type]+conTypes (NormalC _name args) = [t | (_, t) <- args]+conTypes (RecC _name args) = [t | (_, _, t) <- args]+conTypes (InfixC (_, t1) _ (_, t2)) = [t1, t2]+conTypes _ = error "conName: never here"++typeName :: Type -> String+typeName (VarT name) = nameBase name+typeName (ConT name) = nameBase name+typeName (TupleT n) = '(' : replicate (n-1) ',' ++ ")"+typeName ArrowT = "Arrow"+typeName ListT = "List"+typeName (AppT t u) = typeName t ++ typeName u+typeName (SigT t _k) = typeName t+typeName _ = "_"
src/Data/SafeCopy/Instances.hs view
@@ -1,25 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.SafeCopy.Instances where import Data.SafeCopy.SafeCopy import Data.Word import Data.Int-import Data.Maybe-import Data.Binary-import Data.Binary.Put-import Data.Binary.Get+import Data.Serialize import Control.Applicative+import Data.Ix+import qualified Data.Array as Array+import qualified Data.Array.Unboxed as UArray+import qualified Data.Array.IArray as IArray+import qualified Data.Foldable as Foldable import qualified Data.Map as Map import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Sequence as Sequence import qualified Data.Set as Set+import qualified Data.Tree as Tree import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as B import Control.Monad -- instance SafeCopy a => SafeCopy [a] where kind = primitive getCopy = contain $@@ -39,18 +44,53 @@ putCopy Nothing = contain $ put False instance (SafeCopy a, Ord a) => SafeCopy (Set.Set a) where- getCopy = contain $ fmap Set.fromAscList safeGet+ getCopy = contain $ fmap Set.fromDistinctAscList safeGet putCopy = contain . safePut . Set.toAscList -instance (SafeCopy a,SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where- getCopy = contain $ fmap Map.fromAscList safeGet+instance (SafeCopy a, SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where+ getCopy = contain $ fmap Map.fromDistinctAscList safeGet putCopy = contain . safePut . Map.toAscList instance (SafeCopy a) => SafeCopy (IntMap.IntMap a) where- getCopy = contain $ fmap IntMap.fromAscList safeGet+ getCopy = contain $ fmap IntMap.fromDistinctAscList safeGet putCopy = contain . safePut . IntMap.toAscList +instance SafeCopy IntSet.IntSet where+ getCopy = contain $ fmap IntSet.fromDistinctAscList safeGet+ putCopy = contain . safePut . IntSet.toAscList +instance (SafeCopy a) => SafeCopy (Sequence.Seq a) where+ getCopy = contain $ fmap Sequence.fromList safeGet+ putCopy = contain . safePut . Foldable.toList++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+++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++instance (IArray.IArray UArray.UArray e, Ix i, SafeCopy e, SafeCopy i) => SafeCopy (UArray.UArray i e) where+ getCopy = iarray_getCopy+ putCopy = iarray_putCopy++ instance (SafeCopy a, SafeCopy b) => SafeCopy (a,b) where kind = primitive getCopy = contain $ liftM2 (,) safeGet safeGet@@ -84,41 +124,41 @@ instance SafeCopy Int where- kind = Primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Integer where- kind = Primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Float where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Double where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy L.ByteString where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy B.ByteString where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Char where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Word8 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Word16 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Word32 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Word64 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Ordering where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Int8 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Int16 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Int32 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Int64 where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy () where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance SafeCopy Bool where- kind = primitive; getCopy = contain $ get; putCopy = contain . put+ kind = primitive; getCopy = contain get; putCopy = contain . put instance (SafeCopy a, SafeCopy b) => SafeCopy (Either a b) where kind = primitive getCopy = contain $ do n <- get
src/Data/SafeCopy/SafeCopy.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.SafeCopy.SafeCopy@@ -14,15 +15,12 @@ -- module Data.SafeCopy.SafeCopy where -import Data.Binary as B-import Data.Binary.Put as B-import Data.Binary.Get as B-import qualified Data.ByteString.Lazy.Char8 as L+import Data.Serialize+ import Control.Monad-import Control.Applicative+import Data.Int (Int32) import Data.List - -- | The central mechanism for dealing with version control. -- -- This type class specifies what data migrations can happen@@ -87,12 +85,28 @@ -- 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 =+ let ret = computeConsistency proxy+ proxy = proxyFromConsistency ret+ in ret ++ 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 $ "Cannot migrate from primitive types."+ Primitive -> fail "Cannot migrate from primitive types." Base -> fail $ "Cannot find getter associated with this version number: " ++ show diskVersion Extends b_proxy -> fmap migrate (constructGetterFromVersion (castVersion diskVersion) b_proxy)@@ -111,14 +125,14 @@ -- | 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 :: SafeCopy a => Get (Get a)+getSafeGet :: forall a. SafeCopy a => Get (Get a) getSafeGet- = checkInvariants proxy $+ = checkConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ unsafeUnPack getCopy _ -> do v <- get return $ constructGetterFromVersion v proxy- where proxy = Proxy+ 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@@ -130,23 +144,27 @@ -- | Serialize the version tag and return the associated putter. This is useful -- when serializing multiple values with the same version. See 'getSafeGet'.-getSafePut :: SafeCopy a => PutM (a -> Put)+getSafePut :: forall a. SafeCopy a => PutM (a -> Put) getSafePut- = checkInvariants proxy $+ = 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+ where proxy = Proxy :: Proxy a -- | 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 +-- 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@@ -158,7 +176,7 @@ -- parser function. -- | A simple numeric version id.-newtype Version a = Version {unVersion :: Int} deriving (Read,Show,Eq)+newtype Version a = Version {unVersion :: Int32} deriving (Read,Show,Eq) castVersion :: Version a -> Version b castVersion (Version a) = Version a@@ -172,7 +190,7 @@ signum (Version a) = Version (signum a) fromInteger i = Version (fromInteger i) -instance Binary (Version a) where+instance Serialize (Version a) where get = liftM Version get put = put . unVersion @@ -184,7 +202,7 @@ -- 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.-data Contained a = Contained {unsafeUnPack :: a}+newtype Contained a = Contained {unsafeUnPack :: a} -- | Place a value in an unbreakable container. contain :: a -> Contained a@@ -193,23 +211,65 @@ ------------------------------------------------- -- Consistency checking -availableVersions :: SafeCopy a => Proxy a -> [Int]+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 -checkInvariants :: (SafeCopy a, Monad m) => Proxy a -> m b -> m b-checkInvariants proxy ks- = if versions == nub versions- then ks- else fail $ "Duplicate version tags: " ++ show versions+-- 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+ Primitive -> False+ Base -> True+ Extends c_proxy -> check c_proxy++-- 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++consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a+consistentFromProxy _ = internalConsistency versionFromProxy :: SafeCopy a => Proxy a -> Version a versionFromProxy _ = version