safecopy 0.9.4.3 → 0.10.0

raw patch · 5 files changed

+529/−24 lines, 5 filesdep +HUnitdep +generic-datadep +transformersdep ~basedep ~bytestringdep ~cerealPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, generic-data, transformers

Dependency ranges changed: base, bytestring, cereal, semigroups

API changes (from Hackage documentation)

Files

• safecopy.cabal +11/−2
• src/Data/SafeCopy.hs +1/−0
• src/Data/SafeCopy/Instances.hs +11/−11
• src/Data/SafeCopy/SafeCopy.hs +225/−11
• test/generic.hs +281/−0

@@ -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

@@ -79,6 +79,7 @@       safeGet     , safePut     , SafeCopy(version, kind, getCopy, putCopy, objectProfile, errorTypeName)+    , SafeCopy'     , Profile(..)     , Prim(..)     , Migrate(..)

@@ -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

@@ -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 _ = "<unknown type>"+    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

@@ -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+      ])