diff --git a/safecopy.cabal b/safecopy.cabal --- a/safecopy.cabal +++ b/safecopy.cabal @@ -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 -- 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 diff --git a/src/Data/SafeCopy.hs b/src/Data/SafeCopy.hs --- a/src/Data/SafeCopy.hs +++ b/src/Data/SafeCopy.hs @@ -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 diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeCopy/Derive.hs @@ -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 _ = "_" diff --git a/src/Data/SafeCopy/Instances.hs b/src/Data/SafeCopy/Instances.hs --- a/src/Data/SafeCopy/Instances.hs +++ b/src/Data/SafeCopy/Instances.hs @@ -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 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 @@ -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