safecopy 0.9.4.3 → 0.10.4.3
raw patch · 8 files changed
Files
- CHANGELOG.md +36/−2
- safecopy.cabal +65/−38
- src/Data/SafeCopy.hs +28/−0
- src/Data/SafeCopy/Derive.hs +25/−47
- src/Data/SafeCopy/Instances.hs +9/−17
- src/Data/SafeCopy/SafeCopy.hs +246/−31
- test/generic.hs +281/−0
- test/instances.hs +4/−54
CHANGELOG.md view
@@ -1,3 +1,39 @@+0.10.4.3+--------++_Andreas Abel, 2025-08-27_++- Remove old code for GHC 7+- Tested with GHC 8.0 - 9.14 alpha1++0.10.4+======++Add a Typeable a superclass to SafeCopy. The previous version in effect+had the Typeable constraint anyway, this means less need to specify it.+The SafeCopy' type alias is now identical to SafeCopy. This should not+break any code except perhaps some GADT types that use "deriving Typeable".+These may need a standalone deriving instance.++0.10.0+======++This version replaces the default implementation of getCopy and putCopy+with a full implementation using GHC.Generics. Before these functions+simply serialized and deserialized their argument. Now they function+identically to the instances generated by deriveSafeCopy. This means+that embedded values with SafeCopy instances will be migrated properly,+and that you can replace template haskell with standalone deriving+instances such as "deriving instance SafeCopy Foo where kind = extension;+version = 3".++The one caveat is that the new default implementation of getCopy and+putCopy adds the constraint "Typeable a", so that it can build a set of+the subtypes that appear in a. This will only affect code that already+used the default instance, not code that used deriveSafeCopy or custom+SafeCopy instances. If you do run into this you can add a custom SafeCopy+instance with the old implementations mentioned above.+ 0.9.4 ===== - Support ghc-8.4.1@@ -25,5 +61,3 @@ [https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced](https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced) [https://github.com/GaloisInc/cereal/issues/35](https://github.com/GaloisInc/cereal/issues/35)--
safecopy.cabal view
@@ -1,69 +1,96 @@--- 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.+Cabal-version: 1.18 Name: safecopy-Version: 0.9.4.3+Version: 0.10.4.3 Synopsis: Binary serialization with version control. Description: An extension to Data.Serialize with built-in version control. Homepage: https://github.com/acid-state/safecopy License: PublicDomain Author: David Himmelstrup, Felipe Lessa-Maintainer: Lemmih <lemmih@gmail.com>+Maintainer: Lemmih <lemmih@gmail.com>, David Fox <dsf@seereason.com> -- Copyright: Category: Data, Parsing 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 +Extra-doc-files: CHANGELOG.md++tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2+ Source-repository head type: git- location: git://github.com/acid-state/safecopy.git+ location: https://github.com/acid-state/safecopy.git Library- -- Modules exported by the library.+ Default-language: Haskell2010 Exposed-modules: Data.SafeCopy Data.SafeCopy.Internal Hs-Source-Dirs: src/ - -- Packages needed in order to build this package.- Build-depends: base >=4.5 && <5,- array < 0.6,- cereal >= 0.5 && < 0.6,- bytestring < 0.11,- containers >= 0.3 && < 0.7,- old-time < 1.2,- template-haskell < 2.15,- text < 1.3,- time < 1.10,- vector >= 0.10 && < 0.13-- if !impl(ghc > 8.0)- Build-Depends: semigroups >= 0.18 && < 0.19+ -- Lower bounds are chosen to match LTS 7.24 (GHC 8.0)+ Build-depends: base >= 4.9 && < 5+ , array >= 0.5.1.1 && < 0.6+ , cereal >= 0.5.4.0 && < 0.6+ , bytestring >= 0.10.8.1 && < 0.13+ , generic-data >= 0.3.0.0 && < 2+ , containers >= 0.5.7.1 && < 1+ , old-time >= 1.1.0.3 && < 1.2+ , template-haskell >= 2.11.0.0 && < 2.25+ , text >= 1.2.2.2 && < 1.3 || >= 2.0 && < 2.2+ , time >= 1.6.0.1 && < 2+ , transformers >= 0.5.2.0 && < 0.7+ , vector >= 0.11.0.0 && < 0.14 - -- 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:- GHC-Options: -Wall - if(impl(ghc >= 7.2.1))- cpp-options: -DDEFAULT_SIGNATURES-- if(impl(ghc >= 7.1))- cpp-options: -DSAFE_HASKELL+ cpp-options: -DDEFAULT_SIGNATURES -DSAFE_HASKELL Test-suite instances+ Default-language: Haskell2010 Type: exitcode-stdio-1.0 Main-is: instances.hs Hs-Source-Dirs: test/ GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N- Build-depends: base, cereal, template-haskell, safecopy,- containers, time, array, vector, lens >= 4.7 && < 5.0,- lens-action, tasty, tasty-quickcheck, quickcheck-instances, QuickCheck+ Build-depends: base+ , array+ , cereal+ , containers+ , safecopy+ , template-haskell+ , time+ , vector+ -- new dependencies:+ , lens >= 4.7 && < 6+ , lens-action+ , tasty+ , tasty-quickcheck++Test-suite generic+ Default-language: Haskell2010+ 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
src/Data/SafeCopy.hs view
@@ -16,6 +16,8 @@ -- can change the definition and binary format of a type nested deep within -- other types without problems. --+-- = Migration+-- -- Consider this scenario. You want to store your contact list on disk -- and so write the following code: --@@ -74,11 +76,37 @@ -- 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.+--+-- = Retiring Migrations+--+-- There may come a time when you have to remove @Contacts_v0@.+-- Perhaps it uses types you want to remove from your build to+-- decrease its size. Perhaps it has constraints such as @Enum@ which+-- are imposed on your new @Contacts@ type via the @SafeCopy@+-- instance.+--+-- In any case, if you are using @safecopy@ incombination with+-- @acid-state@, some care must be taken when removing @Contacts_v0@.+-- The following steps must be taken to add a new type and remove the old:+--+-- 1. Add the migration as described above.+-- 2. Run the server with the new migration on /all important data/. This+-- will cause the type to be modified in the running program.+-- 3. /Restart/ the server with the new migration on /all important data/. This+-- causes checkpoints to be written that only contain the new type.+-- 4. Remove the old type from your source code, changing the @kind@ of+-- the new type from @extension@ to @base@. Build and deploy.+--+-- If you omit any of these steps it is a certainty that you will+-- proceed happily with your development thinking all is grand, and+-- then when you go to deploy your live system the migration will fail.+ module Data.SafeCopy ( safeGet , safePut , SafeCopy(version, kind, getCopy, putCopy, objectProfile, errorTypeName)+ , SafeCopy' , Profile(..) , Prim(..) , Migrate(..)
src/Data/SafeCopy/Derive.hs view
@@ -1,23 +1,11 @@ {-# LANGUAGE TemplateHaskell, CPP #-} --- Hack for bug in older Cabal versions-#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif- module Data.SafeCopy.Derive where import Data.Serialize (getWord8, putWord8, label) import Data.SafeCopy.SafeCopy -#if MIN_VERSION_template_haskell(2,8,0) import Language.Haskell.TH hiding (Kind)-#else-import Language.Haskell.TH hiding (Kind(..))-#endif-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad import Data.Maybe (fromMaybe) #ifdef __HADDOCK__@@ -226,9 +214,13 @@ forceTag HappstackData = True forceTag _ = False +#if MIN_VERSION_template_haskell(2,17,0)+tyVarName :: TyVarBndr s -> Name+tyVarName (PlainTV n _) = n+tyVarName (KindedTV n _ _) = n+#else tyVarName :: TyVarBndr -> Name tyVarName (PlainTV n) = n-#if MIN_VERSION_template_haskell(2,10,0) tyVarName (KindedTV n _) = n #endif @@ -240,38 +232,30 @@ internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec] internalDeriveSafeCopy' deriveType versionId kindName tyName info = do case info of-#if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD context _name tyvars _kind cons _derivs)-#else- TyConI (DataD context _name tyvars cons _derivs)-#endif | 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) -#if MIN_VERSION_template_haskell(2,11,0) TyConI (NewtypeD context _name tyvars _kind con _derivs) ->-#else- TyConI (NewtypeD context _name tyvars con _derivs) ->-#endif worker context tyvars [(0, con)] FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of-#if MIN_VERSION_template_haskell(2,11,0)- DataInstD context _name ty _kind cons _derivs ->+#if MIN_VERSION_template_haskell(2,15,0)+ DataInstD context _ nty _kind cons _derivs ->+ worker' (return nty) context [] (zip [0..] cons)++ NewtypeInstD context _ nty _kind con _derivs ->+ worker' (return nty) context [] [(0, con)] #else- DataInstD context _name ty cons _derivs ->-#endif+ DataInstD context _name ty _kind cons _derivs -> worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) -#if MIN_VERSION_template_haskell(2,11,0) NewtypeInstD context _name ty _kind con _derivs ->-#else- NewtypeInstD context _name ty con _derivs ->-#endif worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]+#endif _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) return $ concat decs _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)@@ -279,11 +263,7 @@ worker = worker' (conT tyName) worker' tyBase context tyvars cons = let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]-#if MIN_VERSION_template_haskell(2,10,0) safeCopyClass args = foldl appT (conT ''SafeCopy) args-#else- safeCopyClass args = classP ''SafeCopy args-#endif in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons@@ -305,23 +285,27 @@ FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of-#if MIN_VERSION_template_haskell(2,11,0)- DataInstD context _name ty _kind cons _derivs+#if MIN_VERSION_template_haskell(2,15,0)+ DataInstD context _ nty _kind cons _derivs+ | nty == foldl AppT (ConT tyName) tyIndex ->+ worker' (return nty) context [] (zip [0..] cons) #else- DataInstD context _name ty cons _derivs-#endif+ DataInstD context _name ty _kind cons _derivs | ty == tyIndex -> worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)+#endif | otherwise -> return [] -#if MIN_VERSION_template_haskell(2,11,0)- NewtypeInstD context _name ty _kind con _derivs+#if MIN_VERSION_template_haskell(2,15,0)+ NewtypeInstD context _ nty _kind con _derivs+ | nty == foldl AppT (ConT tyName) tyIndex ->+ worker' (return nty) context [] [(0, con)] #else- NewtypeInstD context _name ty con _derivs-#endif+ NewtypeInstD context _name ty _kind con _derivs | ty == tyIndex -> worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]+#endif | otherwise -> return [] _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)@@ -331,11 +315,7 @@ typeNameStr = unwords $ map show (tyName:tyIndex') worker' tyBase context tyvars cons = let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]-#if MIN_VERSION_template_haskell(2,10,0) safeCopyClass args = foldl appT (conT ''SafeCopy) args-#else- safeCopyClass args = classP ''SafeCopy args-#endif in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons@@ -433,10 +413,8 @@ conSize (RecC _name recs) = length recs conSize InfixC{} = 2 conSize ForallC{} = error "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it."-#if MIN_VERSION_template_haskell(2,11,0) conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."-#endif conName :: Con -> Name conName (NormalC name _args) = name
src/Data/SafeCopy/Instances.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, UndecidableInstances, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Data.SafeCopy.Instances where import Data.SafeCopy.SafeCopy -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad import qualified Data.Array as Array import qualified Data.Array.Unboxed as UArray@@ -35,15 +35,9 @@ import Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime) import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..)) import qualified Data.Tree as Tree-#if MIN_VERSION_base(4,7,0) import Data.Typeable hiding (Proxy)-#else-import Data.Typeable-#endif import Data.Word-#if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural)-#endif import System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..)) import qualified System.Time as OT import qualified Data.Vector as V@@ -172,16 +166,14 @@ getCopy = contain get; putCopy = contain . put; errorTypeName = typeName instance SafeCopy Integer where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName-#if MIN_VERSION_base(4,8,0) instance SafeCopy Natural where getCopy = contain get; putCopy = contain . put; errorTypeName = typeName-#endif --- | cereal change the formats for Float/Double in 0.5.*+-- | cereal changed the formats for Float/Double in 0.5.* -- -- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced -- https://github.com/GaloisInc/cereal/issues/35-newtype CerealFloat040 = CerealFloat040 { unCerealFloat040 :: Float} deriving (Show, Typeable)+newtype CerealFloat040 = CerealFloat040 { unCerealFloat040 :: Float} deriving (Show) instance SafeCopy CerealFloat040 where getCopy = contain (CerealFloat040 <$> liftM2 encodeFloat get get) putCopy (CerealFloat040 float) = contain (put (decodeFloat float))@@ -198,11 +190,11 @@ putCopy = contain . put errorTypeName = typeName --- | cereal change the formats for Float/Double in 0.5.*+-- | cereal changed the formats for Float/Double in 0.5.* -- -- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced -- https://github.com/GaloisInc/cereal/issues/35-newtype CerealDouble040 = CerealDouble040 { unCerealDouble040 :: Double} deriving (Show, Typeable)+newtype CerealDouble040 = CerealDouble040 { unCerealDouble040 :: Double} deriving (Show) instance SafeCopy CerealDouble040 where getCopy = contain (CerealDouble040 <$> liftM2 encodeFloat get get) putCopy (CerealDouble040 double) = contain (put (decodeFloat double))@@ -253,7 +245,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
src/Data/SafeCopy/SafeCopy.hs view
@@ -1,10 +1,15 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE CPP #-}-#ifdef DEFAULT_SIGNATURES+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}-#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- |@@ -21,11 +26,24 @@ -- module Data.SafeCopy.SafeCopy where -import Data.Serialize- import Control.Monad+import Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Fail as Fail+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.Int (Int32) import Data.List+import Data.Map as Map (Map, lookup, insert)+import Data.Serialize+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) -- | The central mechanism for dealing with version control. --@@ -49,11 +67,11 @@ -- 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+-- Extensions (see 'extension') tell 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+-- There is also a default kind which is neither primitive nor -- an extension of a previous type. data Kind a where Primitive :: Kind a@@ -75,7 +93,7 @@ -- even though 'getCopy' and 'putCopy' can't be used directly. -- To serialize/parse a data type using 'SafeCopy', see 'safeGet' -- and 'safePut'.-class SafeCopy a where+class Typeable a => SafeCopy a where -- | The version of the type. -- -- Only used as a key so it must be unique (this is checked at run-time)@@ -99,7 +117,7 @@ -- | 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.+ -- One should use 'safePut, instead. putCopy :: a -> Contained Put -- | Internal function that should not be overrided.@@ -118,21 +136,210 @@ 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>" -#ifdef DEFAULT_SIGNATURES- default getCopy :: Serialize a => Contained (Get a)- getCopy = contain get+ default errorTypeName :: Typeable a => Proxy a -> String+ errorTypeName _ = show (typeRep (Proxy @a)) - default putCopy :: Serialize a => a -> Contained Put- putCopy = contain . put-#endif+ 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 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+{-# DEPRECATED SafeCopy' "SafeCopy' is now equivalent to SafeCopy " #-}++-- 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+ {-# INLINE gputFields #-}++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 #-}++-- This corresponds to ggetFields, but does it match deriveSafeCopy?+instance GPutFields U1 p where+ gputFields _ _ =+ return ()+{-+-- 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)+-}+ {-# 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))+ {-# INLINE ggetCopy #-}++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)+ {-# INLINE ggetFields #-}++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+-- when the 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+ = unpureCheckConsistency 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+ -- 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 =@@ -205,7 +412,7 @@ -- when serializing multiple values with the same version. See 'getSafeGet'. getSafePut :: forall a. SafeCopy a => PutM (a -> Put) getSafePut- = checkConsistency proxy $+ = unpureCheckConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) _ -> do put (versionFromProxy proxy)@@ -214,7 +421,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 +434,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.@@ -268,7 +475,7 @@ -- 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'.+-- correctly, 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. newtype Contained a = Contained {unsafeUnPack :: a}@@ -334,21 +541,29 @@ Extended sub_kind -> check sub_kind -- Verify that the SafeCopy instance is consistent.-checkConsistency :: (SafeCopy a, Monad m) => Proxy a -> m b -> m b+checkConsistency :: (SafeCopy a, Fail.MonadFail m) => Proxy a -> m b -> m b checkConsistency proxy ks = case consistentFromProxy proxy of- NotConsistent msg -> fail msg+ NotConsistent msg -> Fail.fail msg Consistent -> ks +-- | PutM doesn't have reasonable 'fail' implementation.+-- It just throws an unpure exception anyway.+unpureCheckConsistency :: SafeCopy a => Proxy a -> b -> b+unpureCheckConsistency proxy ks+ = case consistentFromProxy proxy of+ NotConsistent msg -> error $ "unpureCheckConsistency: " ++ msg+ Consistent -> ks+ {-# INLINE computeConsistency #-}-computeConsistency :: SafeCopy a => Proxy a -> Consistency a+computeConsistency :: forall a. 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+ = NotConsistent $ "Duplicate version tags for " ++ show (typeRep (Proxy @a)) ++ ": " ++ show versions | not (validChain proxy) = NotConsistent "Primitive types cannot be extended as they have no version tag." | otherwise@@ -379,7 +594,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
+ test/generic.hs view
@@ -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 4 'base ''T2)+$(deriveSafeCopy 5 'base ''T3)+$(deriveSafeCopy 3 'base ''T1)+$(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+ ])
test/instances.hs view
@@ -5,17 +5,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- Hack for bug in older Cabal versions-#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif- import Control.Applicative-import Control.Lens-import Control.Lens.Action+import Control.Lens (transformOn, transformOnOf)+import Control.Lens.Traversal (Traversal')+import Control.Lens.Action ((^!!), act) import Data.Array (Array) import Data.Array.Unboxed (UArray)-import Data.Data.Lens+import Data.Data.Lens (template) import Data.Fixed (Fixed, E1) import Data.List import Data.SafeCopy@@ -24,7 +20,6 @@ import Data.Tree (Tree) import Language.Haskell.TH import Language.Haskell.TH.Syntax-import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.QuickCheck hiding (Fixed, (===)) import qualified Data.Vector as V@@ -32,40 +27,11 @@ import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU -#if ! MIN_VERSION_QuickCheck(2,9,0)-instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) =>- Arbitrary (a,b,c,d,e,f) where- arbitrary = (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*>- arbitrary <*> arbitrary <*> arbitrary--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) =>- Arbitrary (a,b,c,d,e,f,g) where- arbitrary = (,,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*>- arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-#endif--#if ! MIN_VERSION_QuickCheck(2,8,2)-instance (Arbitrary a) => Arbitrary (V.Vector a) where- arbitrary = V.fromList <$> arbitrary--instance (Arbitrary a, VP.Prim a) => Arbitrary (VP.Vector a) where- arbitrary = VP.fromList <$> arbitrary--instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where- arbitrary = VS.fromList <$> arbitrary--instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where- arbitrary = VU.fromList <$> arbitrary-#endif- deriving instance (Arbitrary a) => Arbitrary (Prim a) deriving instance (Eq a) => Eq (Prim a) deriving instance (Show a) => Show (Prim a) deriving instance Eq ZonedTime-#if ! MIN_VERSION_time(1,6,0)-deriving instance Show UniversalTime-#endif -- | Equality on the 'Right' value, showing the unequal value on failure; -- or explicit failure using the 'Left' message without equality testing.@@ -105,25 +71,14 @@ safecopy <- reify ''SafeCopy preds <- 'prop_inverse ^!! act reify . (template :: Traversal' Info Pred)-#if !MIN_VERSION_template_haskell(2,10,0)- classes <- mapM reify [ name | ClassP name _ <- preds ]-#else--- print preds- classes <- case preds of [ForallT _ cxt' _] -> mapM reify [ name | AppT (ConT name) _ <- cxt' ] _ -> error "FIXME: fix this code to handle this case."--- classes <- mapM reify [ ]-#endif def <- a -#if MIN_VERSION_template_haskell(2,11,0) let instances (ClassI _ decs) = [ typ | InstanceD _ _ (AppT _ typ) _ <- decs ]-#else- let instances (ClassI _ decs) = [ typ | InstanceD _ (AppT _ typ) _ <- decs ]-#endif instances _ = [] types = map instances classes @@ -147,11 +102,6 @@ ($(downsize typ) (prop_inverse :: $(return typ) -> Property)) |] props = listE . map prop--#if !MIN_VERSION_template_haskell(2,8,0)- -- 'report' throws warnings in template-haskell-2.8.0.0- reportWarning = report False-#endif mapM_ (\typ -> reportWarning $ "not tested: " ++ name typ) untested