diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,35 +0,0 @@ -Copyright (c) 2007, David Himmelstrup -All rights reserved. - -Redistribution and use in source and binary forms, -with or without modification, are permitted provided -that the following conditions are met: - - * Redistributions of source code must retain - the above copyright notice, this list of - conditions and the following disclaimer. - * Redistributions in binary form must reproduce - the above copyright notice, this list of - conditions and the following disclaimer in the - documentation and/or other materials provided - with the distribution. - * Neither the name of David Himmelstrup nor the - names of other contributors may be used to - endorse or promote products derived from this - software without specific prior written permission. - - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND -CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE -USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY -OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMain diff --git a/safecopy.cabal b/safecopy.cabal --- a/safecopy.cabal +++ b/safecopy.cabal @@ -1,17 +1,60 @@ +-- 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 -Version: 0.3 + +-- 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 + +-- 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. -Category: Data, Parsing -License: BSD3 -License-file: LICENSE + +-- URL for the project homepage or repository. +Homepage: http://acid-state.seize.it/safecopy + +-- The license under which the package is released. +License: PublicDomain + +-- The package author(s). Author: David Himmelstrup -Maintainer: lemmih@gmail.com -Build-Depends: base, mtl, bytestring, containers, binary -Build-Type: Simple -ghc-options: -O -fglasgow-exts -Hs-Source-Dirs: src -Exposed-Modules: - Data.SafeCopy - Data.SafeCopy.Types - Data.SafeCopy.Instances + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: Lemmih + +-- A copyright notice. +-- Copyright: + +Category: Data, Parsing + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + + +Library + -- Modules exported by the library. + Exposed-modules: Data.SafeCopy + + Hs-Source-Dirs: src/ + + -- Packages needed in order to build this package. + Build-depends: base >=4 && <5, binary, bytestring, containers + + -- Modules not exported by this package. + Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + diff --git a/src/Data/SafeCopy.hs b/src/Data/SafeCopy.hs --- a/src/Data/SafeCopy.hs +++ b/src/Data/SafeCopy.hs @@ -1,8 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.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. +-- +-- 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.Binary +-- together with Haskell's easy of use. However, things quickly takes a 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 - ( module Data.SafeCopy.Types - , module Data.SafeCopy.Instances + ( + safeGet + , safePut + , SafeCopy(..) + , Migrate(..) + , Kind + , extension + , Contained + , contain + , Version + -- * Rarely used functions + , getSafeGet + , getSafePut + , primitive ) where -import Data.SafeCopy.Types import Data.SafeCopy.Instances - +import Data.SafeCopy.SafeCopy 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,6 +1,6 @@ module Data.SafeCopy.Instances where -import Data.SafeCopy.Types +import Data.SafeCopy.SafeCopy import Data.Word import Data.Int @@ -20,7 +20,7 @@ instance SafeCopy a => SafeCopy [a] where - mode = Primitive + kind = primitive getCopy = contain $ do n <- get getSafeGet >>= replicateM n @@ -30,7 +30,7 @@ getSafePut >>= forM_ lst instance SafeCopy a => SafeCopy (Maybe a) where - mode = Primitive + kind = primitive getCopy = contain $ do n <- get if n then liftM Just safeGet else return Nothing @@ -51,104 +51,60 @@ instance (SafeCopy a, SafeCopy b) => SafeCopy (a,b) where - mode = Primitive + kind = primitive getCopy = contain $ liftM2 (,) safeGet safeGet putCopy (a,b) = contain $ safePut a >> safePut b instance (SafeCopy a, SafeCopy b, SafeCopy c) => SafeCopy (a,b,c) where - mode = Primitive + kind = primitive getCopy = contain $ liftM3 (,,) safeGet safeGet safeGet putCopy (a,b,c) = contain $ safePut a >> safePut b >> safePut c instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d) => SafeCopy (a,b,c,d) where - mode = Primitive + kind = primitive getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet putCopy (a,b,c,d) = contain $ safePut a >> safePut b >> safePut c >> safePut d instance SafeCopy Int where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = Primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Integer where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = Primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Float where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Double where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy L.ByteString where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy B.ByteString where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Char where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Word8 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Word16 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Word32 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Word64 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Ordering where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Int8 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Int16 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Int32 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Int64 where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy () where - mode = Primitive; getCopy = contain $ get; putCopy = contain . put + kind = primitive; getCopy = contain $ get; putCopy = contain . put instance SafeCopy Bool where - mode = 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 - mode = Primitive + kind = primitive getCopy = contain $ do n <- get if n then liftM Right safeGet else liftM Left safeGet putCopy (Right a) = contain $ put True >> safePut a putCopy (Left a) = contain $ put False >> safePut a - - -data Test1 = Test1 deriving (Read,Show) -data Test2 = Test2 [Int] deriving (Read,Show) -data Test3 = Test3 [Integer] deriving (Read,Show) -data Test4 = Test4 [Sub2] deriving (Read,Show) -data Sub1 = Sub1 Integer deriving (Read,Show) -data Sub2 = Sub2 Int deriving (Read,Show) -instance SafeCopy Test1 where getCopy = contain $ return Test1; putCopy _ = contain $ return () -instance SafeCopy Test2 where - version = 2 - mode = Extension (mkPrevious (Proxy :: Proxy Test1)) - getCopy = contain $ fmap Test2 get - putCopy (Test2 lst) = contain $ put lst -instance Migrate Test1 Test2 where - migrate Test1 = Test2 [] - -instance SafeCopy Test3 where - version = 3 - mode = Extension (mkPrevious (Proxy :: Proxy Test2)) - getCopy = contain $ fmap Test3 get - putCopy (Test3 lst) = contain $ put lst -instance Migrate Test2 Test3 where - migrate (Test2 lst) = Test3 (map fromIntegral lst) - -instance SafeCopy Test4 where - version = 4 - mode = Extension (mkPrevious (Proxy :: Proxy Test3)) - getCopy = contain $ fmap Test4 safeGet - putCopy (Test4 lst) = contain $ safePut lst -instance Migrate Test3 Test4 where - migrate (Test3 lst) = Test4 (map Sub2 $ map fromIntegral lst) - -instance SafeCopy Sub1 where - getCopy = contain $ fmap Sub1 get - putCopy (Sub1 n) = contain $ put n - -instance Migrate Sub1 Sub2 where - migrate (Sub1 n) = Sub2 (fromIntegral n) -instance SafeCopy Sub2 where - version = 2 - mode = Extension (mkPrevious (Proxy :: Proxy Sub1)) - getCopy = contain $ fmap Sub2 get - putCopy (Sub2 n) = contain $ put n diff --git a/src/Data/SafeCopy/SafeCopy.hs b/src/Data/SafeCopy/SafeCopy.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeCopy/SafeCopy.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- 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.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 Control.Monad +import Control.Applicative +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 + +-- | 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 + +-- | 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 through '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 (Get 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 Put + + +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." + Base -> fail $ "Cannot find getter associated with this version number: " ++ show diskVersion + Extends b_proxy + -> fmap migrate (constructGetterFromVersion (castVersion diskVersion) b_proxy) + +------------------------------------------------- +-- 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 => Get 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 :: SafeCopy a => Get (Get a) +getSafeGet + = checkInvariants proxy $ + case kindFromProxy proxy of + Primitive -> return $ unsafeUnPack getCopy + _ -> do v <- get + return $ constructGetterFromVersion v proxy + where proxy = Proxy + +-- | 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 -> Put +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 :: SafeCopy a => PutM (a -> Put) +getSafePut + = checkInvariants 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 + +-- | 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 + +-- | 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 :: Int} deriving (Read,Show,Eq) + +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) + +instance Binary (Version a) where + get = liftM Version get + put = put . unVersion + +------------------------------------------------- +-- 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. +data Contained a = Contained {unsafeUnPack :: a} + +-- | Place a value in an unbreakable container. +contain :: a -> Contained a +contain = Contained + +------------------------------------------------- +-- Consistency checking + +availableVersions :: SafeCopy a => Proxy a -> [Int] +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 + where versions = availableVersions proxy + +------------------------------------------------- +-- Small utility functions that mean we don't +-- have to depend on ScopedTypeVariables. + +versionFromProxy :: SafeCopy a => Proxy a -> Version a +versionFromProxy _ = 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 diff --git a/src/Data/SafeCopy/Types.hs b/src/Data/SafeCopy/Types.hs deleted file mode 100644 --- a/src/Data/SafeCopy/Types.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -module Data.SafeCopy.Types - ( SafeCopy(..) - , Migrate(..) - , Mode(..) - , Contained - , contain - , Proxy(..) - , mkProxy - , Previous - , mkPrevious --- , version - , getSafeGet - , getSafePut - , safePut - , safeGet - , safeGetVersioned - ) 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 Control.Monad - -data Contained a = Contained {unsafeUnPack :: a} - -contain :: a -> Contained a -contain = Contained - -data Proxy a = Proxy - -mkProxy :: a -> Proxy a -mkProxy _ = Proxy - -asProxyType :: a -> Proxy a -> a -asProxyType a _ = a - -class Migrate a b where - migrate :: a -> b - -data Previous a = forall b. (SafeCopy b, Migrate b a) => Previous (Proxy b) - -mkPrevious :: forall a b. (SafeCopy b, Migrate b a) => Proxy b -> Previous a -mkPrevious Proxy = Previous (Proxy :: Proxy b) - -newtype Version a = Version {unVersion :: Int} deriving (Num,Read,Show,Eq) - -data Mode a = Primitive - | Base - | Extension (Previous a) - -class SafeCopy a where - version :: Version a - version = 0 - mode :: Mode a - mode = Base - getCopy :: Contained (Get a) - putCopy :: a -> Contained Put - -instance Binary (Version a) where - get = liftM Version get - put = put . unVersion - -getSafeGet :: forall a. SafeCopy a => Get (Get a) -getSafeGet = case mode :: Mode a of - Primitive -> return (unsafeUnPack getCopy) - _ -> - do v <- get - return (safeGetVersioned v) - -getSafePut :: forall a. SafeCopy a => PutM (a -> Put) -getSafePut = case mode :: Mode a of - Primitive -> return (unsafeUnPack . putCopy) - _ -> do B.put (version :: Version a) - return (unsafeUnPack . putCopy) - - -safePut :: forall a. SafeCopy a => a -> Put -safePut val = do fn <- getSafePut - fn val - -safeGet :: forall a. SafeCopy a => Get a -safeGet = join getSafeGet - -safeGetVersioned :: forall a b. SafeCopy b => Version a -> B.Get b -safeGetVersioned v = case compareVersions v (version :: Version b) of - GT -> error $ "Version tag too large: " ++ show v - EQ -> unsafeUnPack getCopy - LT -> case mode of - Extension (Previous (_ :: Proxy f) :: Previous b) - -> do old <- safeGetVersioned v :: B.Get f - return $ migrate old - _ -> error $ "No previous version" - -compareVersions :: Version a -> Version b -> Ordering -compareVersions v1 v2 = compare (unVersion v1) (unVersion v2) - - - -{- - -class Versioned a where - typeVersion :: a -> Int - -data Test1 a = Test1 a -data Test2 a = Test2 a - -data Sub1 = Sub1 Int; instance Versioned Sub1 where typeVersion _ = 1 -data Sub2 = Sub2 String; instance Versioned Sub2 where typeVersion _ = 2 - -showVersion (Test1 s) = typeVersion s --} -{- -class HotSwap a where - hotVersion :: Version a - hotVersion = 0 - destruct :: a -> (Int,ArgList) - construct :: (Int,ArgList) -> a - -data Test = Test Sub1 Sub2 -data Sub1 = Sub1 -data Sub2 = Sub2 - -data ArgList = Nil | forall a. HotSwap a => a :+: ArgList - -infixr 5 :+: - -instance HotSwap Test where - destruct (Test a b) = (1, a :+: b :+: Nil) - construct (1, a :+: b :+: Nil) = Test (fromHot a) (fromHot b) - -instance HotSwap Sub1 where - destruct Sub1 = (1,Nil) - construct (1,Nil) = Sub1 -instance HotSwap Sub2 where - destruct Sub2= (1,Nil) - construct (1,Nil) = Sub2 - -fromHot :: (HotSwap a, HotSwap b) => a -> b -fromHot = undefined - -{- -hotSwap :: forall a b. (HotSwap a, HotSwap b) => a -> b -hotSwap inp - = let inpVersion = hotVersion :: Version a - outVersion = hotVersion :: Version b - in --} --}