diff --git a/safecopy.cabal b/safecopy.cabal --- a/safecopy.cabal +++ b/safecopy.cabal @@ -3,7 +3,7 @@ -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. -- The name of the package. Name: safecopy -Version: 0.9.4.3 +Version: 0.10.0 Synopsis: Binary serialization with version control. Description: An extension to Data.Serialize with built-in version control. Homepage: https://github.com/acid-state/safecopy @@ -15,7 +15,7 @@ Build-type: Simple Extra-source-files: CHANGELOG.md Cabal-version: >=1.8 -tested-with: GHC==7.8.4, GHC==7.10.2, GHC==8.0.2, GHC==8.2.1, GHC==8.4.1 +tested-with: GHC==8.0.2, GHC==8.2.1, GHC==8.4.1, GHC==8.6.5 Source-repository head type: git @@ -34,11 +34,13 @@ array < 0.6, cereal >= 0.5 && < 0.6, bytestring < 0.11, + generic-data >= 0.3, containers >= 0.3 && < 0.7, old-time < 1.2, template-haskell < 2.15, text < 1.3, time < 1.10, + transformers < 0.6, vector >= 0.10 && < 0.13 if !impl(ghc > 8.0) @@ -67,3 +69,10 @@ Build-depends: base, cereal, template-haskell, safecopy, containers, time, array, vector, lens >= 4.7 && < 5.0, lens-action, tasty, tasty-quickcheck, quickcheck-instances, QuickCheck + +Test-suite generic + Type: exitcode-stdio-1.0 + Main-is: generic.hs + Hs-Source-Dirs: test/ + GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N + Build-depends: base, bytestring, cereal, safecopy, HUnit diff --git a/src/Data/SafeCopy.hs b/src/Data/SafeCopy.hs --- a/src/Data/SafeCopy.hs +++ b/src/Data/SafeCopy.hs @@ -79,6 +79,7 @@ safeGet , safePut , SafeCopy(version, kind, getCopy, putCopy, objectProfile, errorTypeName) + , SafeCopy' , Profile(..) , Prim(..) , Migrate(..) 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 @@ -52,7 +52,7 @@ import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU -instance SafeCopy a => SafeCopy (Prim a) where +instance SafeCopy' a => SafeCopy (Prim a) where kind = primitive getCopy = contain $ do e <- unsafeUnPack getCopy @@ -145,22 +145,22 @@ getCopy = contain $ liftM2 (,) safeGet safeGet putCopy (a,b) = contain $ safePut a >> safePut b errorTypeName = typeName2 -instance (SafeCopy a, SafeCopy b, SafeCopy c) => SafeCopy (a,b,c) where +instance (SafeCopy' a, SafeCopy' b, SafeCopy' c) => SafeCopy (a,b,c) where 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 +instance (SafeCopy' a, SafeCopy' b, SafeCopy' c, SafeCopy' d) => SafeCopy (a,b,c,d) where getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet putCopy (a,b,c,d) = contain $ safePut a >> safePut b >> safePut c >> safePut d -instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e) => +instance (SafeCopy' a, SafeCopy' b, SafeCopy' c, SafeCopy' d, SafeCopy' e) => SafeCopy (a,b,c,d,e) where getCopy = contain $ liftM5 (,,,,) safeGet safeGet safeGet safeGet safeGet putCopy (a,b,c,d,e) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e -instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f) => +instance (SafeCopy' a, SafeCopy' b, SafeCopy' c, SafeCopy' d, SafeCopy' e, SafeCopy' f) => SafeCopy (a,b,c,d,e,f) where getCopy = contain $ (,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet putCopy (a,b,c,d,e,f) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e >> safePut f -instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g) => +instance (SafeCopy' a, SafeCopy' b, SafeCopy' c, SafeCopy' d, SafeCopy' e, SafeCopy' f, SafeCopy' g) => SafeCopy (a,b,c,d,e,f,g) where getCopy = contain $ (,,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet @@ -253,7 +253,7 @@ putCopy r = contain $ do safePut (numerator r) safePut (denominator r) errorTypeName = typeName1 -instance (HasResolution a, Fractional (Fixed a)) => SafeCopy (Fixed a) where +instance (HasResolution a, Fractional (Fixed a), Typeable a) => SafeCopy (Fixed a) where getCopy = contain $ fromRational <$> safeGet putCopy = contain . safePut . toRational errorTypeName = typeName1 @@ -457,18 +457,18 @@ putGenericVector v = contain $ do put (VG.length v) getSafePut >>= VG.forM_ v -instance SafeCopy a => SafeCopy (V.Vector a) where +instance SafeCopy' a => SafeCopy (V.Vector a) where getCopy = getGenericVector putCopy = putGenericVector -instance (SafeCopy a, VP.Prim a) => SafeCopy (VP.Vector a) where +instance (SafeCopy' a, VP.Prim a) => SafeCopy (VP.Vector a) where getCopy = getGenericVector putCopy = putGenericVector -instance (SafeCopy a, VS.Storable a) => SafeCopy (VS.Vector a) where +instance (SafeCopy' a, VS.Storable a) => SafeCopy (VS.Vector a) where getCopy = getGenericVector putCopy = putGenericVector -instance (SafeCopy a, VU.Unbox a) => SafeCopy (VU.Vector a) where +instance (SafeCopy' a, VU.Unbox a) => SafeCopy (VU.Vector a) where getCopy = getGenericVector putCopy = putGenericVector 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 @@ -3,7 +3,18 @@ {-# LANGUAGE CPP #-} #ifdef DEFAULT_SIGNATURES +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #endif ----------------------------------------------------------------------------- @@ -27,6 +38,22 @@ import Data.Int (Int32) import Data.List +#ifdef DEFAULT_SIGNATURES +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State as State (evalStateT, modify, StateT) +import qualified Control.Monad.Trans.State as State (get) +import Control.Monad.Trans.RWS as RWS (evalRWST, modify, RWST, tell) +import qualified Control.Monad.Trans.RWS as RWS (get) +import Data.Bits (shiftR) +import Data.Map as Map (Map, lookup, insert) +import Data.Set as Set (insert, member, Set) +import Data.Typeable (Typeable, TypeRep, typeOf, typeRep) +import Data.Word (Word8) +import GHC.Generics +import Generic.Data as G (Constructors, gconIndex, gconNum) +import Unsafe.Coerce (unsafeCoerce) +#endif + -- | The central mechanism for dealing with version control. -- -- This type class specifies what data migrations can happen @@ -118,21 +145,208 @@ objectProfile :: Profile a objectProfile = mkProfile Proxy - -- | The name of the type. This is only used in error - -- message strings. - -- Feel free to leave undefined in your instances. + -- | The name of the type. This is only used in error message + -- strings. errorTypeName :: Proxy a -> String - errorTypeName _ = "" + default errorTypeName :: Typeable a => Proxy a -> String + errorTypeName _ = show (typeRep (Proxy @a)) #ifdef DEFAULT_SIGNATURES - default getCopy :: Serialize a => Contained (Get a) - getCopy = contain get + default putCopy :: (GPutCopy (Rep a) DatatypeInfo, Constructors a) => a -> Contained Put + putCopy a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a - default putCopy :: Serialize a => a -> Contained Put - putCopy = contain . put + default getCopy :: (GGetCopy (Rep a) DatatypeInfo, Constructors a) => Contained (Get a) + getCopy = contain (to <$> ggetCopy (ConstructorCount (fromIntegral (gconNum @a)))) + +class GPutCopy f p where + gputCopy :: p -> f p -> Put + +instance GPutCopy a p => GPutCopy (M1 D c a) p where + gputCopy p (M1 a) = gputCopy p a + {-# INLINE gputCopy #-} + +instance (GPutCopy f p, GPutCopy g p) => GPutCopy (f :+: g) p where + gputCopy p (L1 x) = gputCopy @f p x + gputCopy p (R1 x) = gputCopy @g p x + {-# INLINE gputCopy #-} + +-- | A constraint that combines 'SafeCopy' and 'Typeable'. +type SafeCopy' a = (SafeCopy a, Typeable a) + +-- To get the current safecopy behavior we need to emulate the +-- template haskell code here - collect the (a -> Put) values for all +-- the fields and then run them in order.o +instance (GPutFields a p, p ~ DatatypeInfo) => GPutCopy (M1 C c a) p where + gputCopy p (M1 x) = + (when (_size p >= 2) (putWord8 (fromIntegral (_code p)))) *> + -- This is how I tried it first, and it works well but the + -- result is not the same as deriveSafeCopy. + -- mconcat (fmap join (gputFields p x)) + -- join (mconcat <$> sequence (fmap snd (gputFields p x))) + (do putter <- (mconcat . snd) <$> (evalRWST (gputFields p x) () mempty) + putter) + {-# INLINE gputCopy #-} + +-- | gputFields traverses the fields of a constructor and returns a put +-- for the safecopy versions and a put for the field values. +class GPutFields f p where + gputFields :: p -> f p -> RWST () [Put] (Set TypeRep) PutM () + +instance (GPutFields f p, GPutFields g p) => GPutFields (f :*: g) p where + gputFields p (a :*: b) = gputFields p a >> gputFields p b + +instance GPutFields f p => GPutFields (M1 S c f) p where + gputFields p (M1 a) = gputFields p a + {-# INLINE gputFields #-} + +instance SafeCopy' a => GPutFields (K1 R a) p where + gputFields _ (K1 a) = do + getSafePutGeneric putCopy a + {-# INLINE gputFields #-} + +#if 1 +-- This corresponds to ggetFields, but does it match deriveSafeCopy? +instance GPutFields U1 p where + gputFields _ _ = + return () +#else +-- This outputs the version tag for (), which is 1. +instance (GPutFields (K1 R ()) p) => GPutFields U1 p where + gputFields p _ = + gputFields p (K1 () :: K1 R () p) #endif + {-# INLINE gputFields #-} +instance GPutFields V1 p where + gputFields _ _ = undefined + {-# INLINE gputFields #-} +------------------------------------------------------------------------ + +class GGetCopy f p where + ggetCopy :: p -> Get (f a) + +-- | The M1 type has a fourth type parameter p: +-- +-- newtype M1 i (c :: Meta) (f :: k -> *) (p :: k) = M1 {unM1 :: f p} +-- +-- Note that the type of the M1 field is @f p@, so in order to express this +-- type we add a parameter of type p that we can apply to values of type f. +instance (GGetCopy f p, p ~ DatatypeInfo) => GGetCopy (M1 D d f) p where + ggetCopy p + | _size p >= 2 = do + !code <- getWord8 + M1 <$> ggetCopy (ConstructorInfo (_size p) code) + | otherwise = M1 <$> ggetCopy (ConstructorInfo (_size p) 0) + {-# INLINE ggetCopy #-} + +instance (GGetCopy f p, GGetCopy g p, p ~ DatatypeInfo) => GGetCopy (f :+: g) p where + ggetCopy p = do + -- choose the left or right branch of the constructor types + -- based on whether the code is in the left or right half of the + -- remaining constructor count. + let sizeL = _size p `shiftR` 1 + sizeR = _size p - sizeL + case _code p < sizeL of + True -> L1 <$> ggetCopy @f (ConstructorInfo sizeL (_code p)) + False -> R1 <$> ggetCopy @g (ConstructorInfo sizeR (_code p - sizeL)) + +instance GGetFields f p => GGetCopy (M1 C c f) p where + ggetCopy p = do + M1 <$> join (evalStateT (ggetFields p) mempty) + {-# INLINE ggetCopy #-} + +-- append constructor fields +class GGetFields f p where + ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (f a)) + +instance (GGetFields f p, GGetFields g p) => GGetFields (f :*: g) p where + ggetFields p = do + fgetter <- ggetFields @f p + ggetter <- ggetFields @g p + return ((:*:) <$> fgetter <*> ggetter) + +instance GGetFields f p => GGetFields (M1 S c f) p where + ggetFields p = do + getter <- ggetFields p + return (M1 <$> getter) + {-# INLINE ggetFields #-} + +instance SafeCopy' a => GGetFields (K1 R a) p where + ggetFields _ = do + getter <- getSafeGetGeneric + return (K1 <$> getter) + {-# INLINE ggetFields #-} + +instance GGetFields U1 p where + ggetFields _p = pure (pure U1) + {-# INLINE ggetFields #-} + +instance GGetFields V1 p where + ggetFields _p = undefined + {-# INLINE ggetFields #-} + +data DatatypeInfo = + ConstructorCount {_size :: Word8} + | ConstructorInfo {_size :: Word8, _code :: Word8} + deriving Show + +-- | Whereas the other 'getSafeGet' is only run when we know we need a +-- version, this one is run for every field and must decide whether to +-- read a version or not. It constructs a Map TypeRep Int32 and reads +-- whent he new TypeRep is not in the map. +getSafeGetGeneric :: + forall a. SafeCopy' a + => StateT (Map TypeRep Int32) Get (Get a) +getSafeGetGeneric + = checkConsistency proxy $ + case kindFromProxy proxy of + Primitive -> return $ unsafeUnPack getCopy + a_kind -> do let rep = typeRep (Proxy :: Proxy a) + reps <- State.get + v <- maybe (lift get) pure (Map.lookup rep reps) + case constructGetterFromVersion (unsafeCoerce v) a_kind of + Right getter -> State.modify (Map.insert rep v) >> return getter + Left msg -> fail msg + where proxy = Proxy :: Proxy a + +-- | This version returns (Put, Put), the collected version tags and +-- the collected serialized fields. The original 'getSafePut' result +-- type prevents doing this because each fields may have a different +-- type. Maybe you can show me a better way +getSafePutGeneric :: + forall a. SafeCopy' a + => (a -> Contained Put) + -> a + -> RWST () [Put] (Set TypeRep) PutM () +getSafePutGeneric cput a + = checkConsistency proxy $ + case kindFromProxy proxy of + Primitive -> tell [unsafeUnPack (cput $ asProxyType a proxy)] + _ -> do reps <- RWS.get + let typ = typeOf a + when (not (member typ reps)) $ do + lift (put (versionFromProxy proxy)) + RWS.modify (Set.insert typ) + tell [unsafeUnPack (cput $ asProxyType a proxy)] + where proxy = Proxy :: Proxy a + +type GSafeCopy a = (SafeCopy' a, Generic a, GPutCopy (Rep a) DatatypeInfo, Constructors a) + +-- | Generic only version of safePut. Instead of calling 'putCopy' it +-- calls 'putCopyDefault', a copy of the implementation of the +-- 'SafeCopy' default method for 'putCopy'. +safePutGeneric :: forall a. GSafeCopy a => a -> Put +safePutGeneric a = do + putter <- (mconcat . snd) <$> evalRWST (getSafePutGeneric putCopyDefault a) () mempty + putter + +-- | See 'safePutGeneric'. A copy of the code in the default +-- implementation of the putCopy method. +putCopyDefault :: forall a. GSafeCopy a => a -> Contained Put +putCopyDefault a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a +#endif + -- 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 = @@ -214,7 +428,7 @@ -- | The extended_extension kind lets the system know that there is -- at least one previous and one future version of this type. -extended_extension :: (SafeCopy a, Migrate a, Migrate (Reverse a)) => Kind a +extended_extension :: (Migrate a, Migrate (Reverse a)) => Kind a extended_extension = Extended extension -- | The extended_base kind lets the system know that there is @@ -227,7 +441,7 @@ -- 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 :: Migrate a => Kind a extension = Extends Proxy -- | The default kind. Does not extend any type. @@ -379,7 +593,7 @@ versionFromKind :: (SafeCopy a) => Kind a -> Version a versionFromKind _ = version -versionFromReverseKind :: (SafeCopy a, SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a)) +versionFromReverseKind :: (SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a)) versionFromReverseKind _ = version kindFromProxy :: SafeCopy a => Proxy a -> Kind a diff --git a/test/generic.hs b/test/generic.hs new file mode 100644 --- /dev/null +++ b/test/generic.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS -Wno-missing-signatures #-} + +import GHC.Generics +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif +import Data.SafeCopy +import Data.SafeCopy.Internal +import Data.Serialize (runGet, runPut, Serialize) +import Text.Printf +import Test.HUnit (Test(..), assertEqual, runTestTT) +--import Generic.Data as G hiding (unpack) + +-- Debugging +import Data.Typeable hiding (Proxy) +--import Debug.Trace +import Data.ByteString (ByteString, unpack) +import Data.Char (chr) +import Data.Word (Word8, Word32) + +-- Test types +data Foo = Foo Int Char deriving (Generic, Show, Eq) +data Bar = Bar Float Foo deriving (Generic, Show, Eq) +data Baz = Baz1 Int | Baz2 Bool deriving (Generic, Show, Eq) + +#if 0 +safePutTest :: forall a. (SafeCopy' a, Generic a, GPutCopy (Rep a) DatatypeInfo, GConstructors (Rep a)) => a -> Put +safePutTest a = + case runPut p1 == runPut p2 of + True -> p1 + False -> trace ("safePutTest failed for " ++ show (typeRep (Proxy :: Proxy a)) ++ "\n custom: " ++ showBytes (runPut p1) ++ "\n generic: " ++ showBytes (runPut p2)) p1 + where + p1 = safePut a + p2 = safePutGeneric a +#endif + +---------------------------------------------- + +-- Compare a value to the result of encoding and then decoding it. +roundTrip :: forall a. (SafeCopy a, Typeable a, Eq a, Show a) => a -> Test +roundTrip x = do + -- putStrLn ("\n========== " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a)) ++ " ==========") + let d = runPut (safePut x) -- Use custom putCopy/getCopy implementation if present + a :: Either String a + a = runGet safeGet d + TestCase (assertEqual ("roundTrip " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a))) (Right x) a) + +-- Test whether two values of different types have the same encoded +-- representation. This is used here on types of similar shape to +-- test whether the generic SafeCopy instance matches the template +-- haskell instance. +compareBytes :: + forall expected actual. (SafeCopy expected, Typeable expected, + SafeCopy actual, Typeable actual) + => expected -> actual -> Test +compareBytes e a = + TestCase (assertEqual ("compareBytes " ++ show (typeRep (Proxy :: Proxy expected)) ++ " " ++ + show (typeRep (Proxy :: Proxy actual))) + (showBytes (runPut $ safePut e)) + (showBytes (runPut $ safePut a))) + +showBytes :: ByteString -> String +showBytes b = mconcat (fmap f (unpack b)) + where f :: Word8 -> String + f 192 = "[G|" + f 193 = "[C|" + f 194 = "[T|" + f 195 = "]_ " + f 196 = " _<" + f 197 = ">_ " + f c | c >= 32 && c < 127 = [' ', chr (fromIntegral c), ' '] + f c | c == 0 = " __" + f c = printf " %02x" c + +----------------------------- +-- Test Types and Values +----------------------------- + +foo = Foo maxBound 'x' +bar = Bar 1.5 foo +baz1 = Baz1 3 +baz2 = Baz2 True + +-- These instances will use the generic putCopy and getCopy +instance SafeCopy Foo where version = 3; kind = base +instance SafeCopy Bar where version = 4; kind = base +instance SafeCopy Baz where version = 5; kind = base + +-- Copies of the types above with generated SafeCopy instances +data FooTH = FooTH Int Char deriving (Generic, Serialize, Show, Eq) +data BarTH = BarTH Float FooTH deriving (Generic, Serialize, Show, Eq) +data BazTH = Baz1TH Int | Baz2TH Bool deriving (Generic, Serialize, Show, Eq) + +fooTH = FooTH maxBound 'x' +barTH = BarTH 1.5 fooTH +baz1TH = Baz1TH 3 +baz2TH = Baz2TH True + +-- For comparison, these instances have the generated implementations +-- of putCopy and getCopy +#if 1 +$(deriveSafeCopy 3 'base ''FooTH) +$(deriveSafeCopy 4 'base ''BarTH) +$(deriveSafeCopy 5 'base ''BazTH) +#else +instance SafeCopy FooTH where + putCopy (FooTH a1_aeVVN a2_aeVVO) + = contain + (do safePut_Int_aeVVP <- getSafePut + safePut_Char_aeVVQ <- getSafePut + safePut_Int_aeVVP a1_aeVVN + safePut_Char_aeVVQ a2_aeVVO + return ()) + getCopy + = contain + ((Data.Serialize.Get.label "Main.FooTH:") + (do safeGet_Int_aeVVR <- getSafeGet + safeGet_Char_aeVVS <- getSafeGet + ((return FooTH <*> safeGet_Int_aeVVR) <*> safeGet_Char_aeVVS))) + version = 3 + kind = base + errorTypeName _ = "Main.FooTH" + +instance SafeCopy BarTH where + putCopy (BarTH a1_aeVXE a2_aeVXF) + = contain + (do safePut_Float_aeVXG <- getSafePut + safePut_FooTH_aeVXH <- getSafePut + safePut_Float_aeVXG a1_aeVXE + safePut_FooTH_aeVXH a2_aeVXF + return ()) + getCopy + = contain + ((Data.Serialize.Get.label "Main.BarTH:") + (do safeGet_Float_aeVXI <- getSafeGet + safeGet_FooTH_aeVXJ <- getSafeGet + ((return BarTH <*> safeGet_Float_aeVXI) <*> safeGet_FooTH_aeVXJ))) + version = 4 + kind = base + errorTypeName _ = "Main.BarTH" + +instance SafeCopy BazTH where + putCopy (Baz1TH a1_aeVZv) + = contain + (do Data.Serialize.Put.putWord8 0 + safePut_Int_aeVZw <- getSafePut + safePut_Int_aeVZw a1_aeVZv + return ()) + putCopy (Baz2TH a1_aeVZx) + = contain + (do Data.Serialize.Put.putWord8 1 + safePut_Bool_aeVZy <- getSafePut + safePut_Bool_aeVZy a1_aeVZx + return ()) + getCopy + = contain + ((Data.Serialize.Get.label "Main.BazTH:") + (do tag_aeVZz <- Data.Serialize.Get.getWord8 + case tag_aeVZz of + 0 -> do safeGet_Int_aeVZA <- getSafeGet + (return Baz1TH <*> safeGet_Int_aeVZA) + 1 -> do safeGet_Bool_aeVZB <- getSafeGet + (return Baz2TH <*> safeGet_Bool_aeVZB) + _ -> fail + ("Could not identify tag \"" + ++ + (show tag_aeVZz + ++ + "\" for type \"Main.BazTH\" that has only 2 constructors. Maybe your data is corrupted?")))) + version = 5 + kind = base + errorTypeName _ = "Main.BazTH" +#endif + +data File + = File { _fileChksum :: Checksum -- ^ The checksum of the file's contents + , _fileMessages :: [String] -- ^ Messages received while manipulating the file + , _fileExt :: String -- ^ Name is formed by appending this to checksum + } deriving (Generic, Eq, Ord, Show) + +data FileSource + = TheURI String + | ThePath FilePath + deriving (Generic, Eq, Ord, Show) + +type Checksum = String + +$(deriveSafeCopy 10 'base ''File) +$(deriveSafeCopy 11 'base ''FileSource) + +file1 = File ("checksum") [] ".jpg" +file2 = File ("checksum") [] ".jpg" +file3 = File ("checksum") [] ".jpg" + +---------------------------------------------- +-- Demonstration of the ordering issue +---------------------------------------------- + +data T1 = T1 Char T2 T3 deriving (Generic, Show) +data T2 = T2 Char deriving (Generic, Show) +data T3 = T3 Char deriving (Generic, Show) +data T4 = T4 Word32 Word32 Word32 deriving (Generic, Show) + +t1 = T1 'a' (T2 'b') (T3 'c') +t2 = (T2 'b') +t3 = (T3 'c') +t4 = T4 100 200 300 + +$(deriveSafeCopy 3 'base ''T1) +$(deriveSafeCopy 4 'base ''T2) +$(deriveSafeCopy 5 'base ''T3) +$(deriveSafeCopy 6 'base ''T4) + +data T1G = T1G Char T2G T3G deriving (Generic, Show) +data T2G = T2G Char deriving (Generic, Show) +data T3G = T3G Char deriving (Generic, Show) +data T4G = T4G Word32 Word32 Word32 deriving (Generic, Show) + +t1g = T1G 'a' (T2G 'b') (T3G 'c') +t2g = (T2G 'b') +t3g = (T3G 'c') +t4g = T4G 100 200 300 + +instance SafeCopy T1G where version = 3; kind = base +instance SafeCopy T2G where version = 4; kind = base +instance SafeCopy T3G where version = 5; kind = base +instance SafeCopy T4G where version = 6; kind = base + +orderTests :: Test +orderTests = + let -- When I thought to myself "what should the output be type Baz" + -- without reference to reality, this is what I came up with. + _expected :: ByteString + _expected = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "a" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\ENQ" <> "\NUL\NUL\NUL\NUL" <> "c") + -- T1 Char 'a' T2 Char 'b' T3 Char 'c' + -- But this is reality - the type, followed by its three field + -- types, followed by its three field values. + actual :: ByteString + actual = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\ENQ" <> "a" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\NUL" <> "c") in + -- T1 Char T2 T3 'a' Char 'b' Char 'c' + TestList + [ TestCase (assertEqual "actual template haskell safeput output" (showBytes actual) (showBytes (runPut (safePut t1)))) + , TestCase (assertEqual "what the new implementation does" (showBytes actual) (showBytes (runPut (safePut t1g)))) + ] + +main = do + runTestTT + (TestList + [ orderTests + , roundTrip () + , roundTrip ("hello" :: String) + , roundTrip foo + , roundTrip fooTH + , roundTrip bar + , roundTrip barTH + , roundTrip baz1 + , roundTrip baz1TH + , roundTrip baz2 + , roundTrip baz2TH + , roundTrip (Just 'x') + , roundTrip (Nothing :: Maybe Char) + , roundTrip ('a', (123 :: Int), ("hello" :: String)) + , roundTrip file1 + , roundTrip file2 + , roundTrip file3 + , compareBytes fooTH foo + , compareBytes barTH bar + , compareBytes baz1TH baz1 + , compareBytes baz2TH baz2 + ])