diff --git a/safecopy.cabal b/safecopy.cabal --- a/safecopy.cabal +++ b/safecopy.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.8.2 +Version: 0.8.3 -- A short (one-line) description of the package. Synopsis: Binary serialization with version control. @@ -40,11 +40,11 @@ -- Extra-source-files: -- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.6 +Cabal-version: >=1.8 Source-repository head - type: darcs - location: http://hub.darcs.net/Lemmih/safecopy + type: git + location: git://github.com/acid-state/safecopy.git Library @@ -55,7 +55,7 @@ -- Packages needed in order to build this package. Build-depends: base >=4 && <5, array, cereal >= 0.3.1.0, bytestring, containers >= 0.3, - old-time, template-haskell, text, time + old-time, template-haskell, text, time, vector == 0.10.* -- Modules not exported by this package. Other-modules: Data.SafeCopy.Instances, Data.SafeCopy.SafeCopy, @@ -68,3 +68,15 @@ if(impl(ghc >= 7.2.1)) cpp-options: -DDEFAULT_SIGNATURES + + if(impl(ghc >= 7.1)) + cpp-options: -DSAFE_HASKELL + +Test-suite instances + 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, + tasty, tasty-quickcheck, quickcheck-instances diff --git a/src/Data/SafeCopy.hs b/src/Data/SafeCopy.hs --- a/src/Data/SafeCopy.hs +++ b/src/Data/SafeCopy.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE CPP #-} +#ifdef SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.SafeCopy diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -1,4 +1,10 @@ {-# 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 ( deriveSafeCopy @@ -12,7 +18,11 @@ 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 import Control.Applicative import Control.Monad import Data.Maybe (fromMaybe) @@ -232,6 +242,15 @@ | otherwise -> worker context tyvars (zip [0..] cons) TyConI (NewtypeD context _name tyvars con _derivs) -> worker context tyvars [(0, con)] + FamilyI _ insts -> do + decs <- forM insts $ \inst -> + case inst of + DataInstD context _name ty cons _derivs -> + worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) + NewtypeInstD context _name ty con _derivs -> + worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] + _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) + return $ concat decs _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) where worker = worker' (conT tyName) diff --git a/src/Data/SafeCopy/Instances.hs b/src/Data/SafeCopy/Instances.hs --- a/src/Data/SafeCopy/Instances.hs +++ b/src/Data/SafeCopy/Instances.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts, UndecidableInstances, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.SafeCopy.Instances where @@ -31,7 +32,7 @@ import Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime) import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..)) import qualified Data.Tree as Tree -#if __GLASGOW_HASKELL__ >= 707 +#if MIN_VERSION_base(4,7,0) import Data.Typeable hiding (Proxy) #else import Data.Typeable @@ -39,6 +40,11 @@ import Data.Word import System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..)) import qualified System.Time as OT +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU instance SafeCopy a => SafeCopy (Prim a) where kind = primitive @@ -352,8 +358,8 @@ pico <- get wday <- safeGet yday <- get - tzname <- get - tz <- safeGet + tzname <- safeGet + tz <- get dst <- get return (CalendarTime year month day hour mins sec pico wday yday tzname tz dst) putCopy t = contain $ do put (ctYear t) @@ -372,18 +378,32 @@ typeName :: Typeable a => Proxy a -> String typeName proxy = show (typeOf (undefined `asProxyType` proxy)) -#if __GLASGOW_HASKELL__ < 707 typeName1 :: (Typeable1 c) => Proxy (c a) -> String typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy)) typeName2 :: (Typeable2 c) => Proxy (c a b) -> String typeName2 proxy = show (typeOf2 (undefined `asProxyType` proxy)) -#else -typeName1 :: (Typeable c) => Proxy (c a) -> String -typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy)) +getGenericVector :: (SafeCopy a, VG.Vector v a) => Contained (Get (v a)) +getGenericVector = contain $ do n <- get + getSafeGet >>= VG.replicateM n -typeName2 :: (Typeable c) => Proxy (c a b) -> String -typeName2 proxy = show (typeOf2 (undefined `asProxyType` proxy)) -#endif +putGenericVector :: (SafeCopy a, VG.Vector v a) => v a -> Contained Put +putGenericVector v = contain $ do put (VG.length v) + getSafePut >>= VG.forM_ v +instance SafeCopy a => SafeCopy (V.Vector a) where + getCopy = getGenericVector + putCopy = putGenericVector + +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 + getCopy = getGenericVector + putCopy = putGenericVector + +instance (SafeCopy a, VU.Unbox a) => SafeCopy (VU.Vector a) where + getCopy = getGenericVector + putCopy = putGenericVector diff --git a/test/instances.hs b/test/instances.hs new file mode 100644 --- /dev/null +++ b/test/instances.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# 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 Data.Array (Array) +import Data.Array.Unboxed (UArray) +import Data.Data.Lens +import Data.Fixed (Fixed, E1) +import Data.List +import Data.SafeCopy +import Data.Serialize (runPut, runGet) +import Data.Time (UniversalTime(..), ZonedTime(..)) +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 +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU + +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 + +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 + +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 +deriving instance Show UniversalTime + +-- | Equality on the 'Right' value, showing the unequal value on failure; +-- or explicit failure using the 'Left' message without equality testing. +(===) :: (Eq a, Show a) => Either String a -> a -> Property +Left e === _ = printTestCase e False +Right a === b = printTestCase (show a) $ a == b + +-- | An instance for 'SafeCopy' makes a type isomorphic to a bytestring +-- serialization, which is to say that @decode . encode = id@, i.e. +-- @decode@ is the inverse of @encode@ if we ignore bottom. +prop_inverse :: (SafeCopy a, Arbitrary a, Eq a, Show a) => a -> Property +prop_inverse a = (decode . encode) a === a where + encode = runPut . safePut + decode = runGet safeGet + +-- | Test the 'prop_inverse' property against all 'SafeCopy' instances +-- (that also satisfy the rest of the constraints) defaulting any type +-- variables to 'Int'. +do let a = conT ''Int + + -- types we skip because the Int defaulting doesn't type check + excluded <- sequence + [ [t| Fixed $a |] + ] + + -- instead we include these hand-defaulted types + included <- sequence + [ [t| Fixed E1 |] + ] + + -- types whose samples grow exponentially and need a lower maxSize + downsized <- sequence + [ [t| Array $a $a |] + , [t| UArray $a $a |] + , [t| Tree $a |] + ] + + safecopy <- reify ''SafeCopy + preds <- 'prop_inverse ^!! act reify . (template :: Traversal' Info Pred) + classes <- mapM reify [ name | ClassP name _ <- preds ] + def <- a + + let instances (ClassI _ decs) = [ typ | InstanceD _ (AppT _ typ) _ <- decs ] + instances _ = [] + types = map instances classes + + defaulting (VarT _) = def + defaulting t = t + defaulted = transformOn (traverse.traverse) defaulting types + wanted = transformOn traverse defaulting $ instances safecopy + + common = foldl1 intersect defaulted + untested = wanted \\ common + exclusive = filter (`notElem` excluded) common + + downsize typ | typ `elem` downsized = [| mapSize (`div` 5) |] + | otherwise = [| id |] + + unqualifying (Name occ _) = Name occ NameS + name = pprint . transformOnOf template template unqualifying + + prop typ = + [| testProperty $(litE . stringL $ name typ) + ($(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 + + [d| inversions :: [TestTree] + inversions = $(props included) ++ $(props exclusive) |] + +main :: IO () +main = defaultMain $ testGroup "SafeCopy instances" + [ testGroup "decode is the inverse of encode" inversions + ]