packages feed

safecopy 0.8.2 → 0.8.3

raw patch · 5 files changed

+214/−16 lines, 5 filesdep +lensdep +quickcheck-instancesdep +safecopydep ~basedep ~cerealdep ~containersnew-uploader

Dependencies added: lens, quickcheck-instances, safecopy, tasty, tasty-quickcheck, vector

Dependency ranges changed: base, cereal, containers, template-haskell

Files

safecopy.cabal view
@@ -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
src/Data/SafeCopy.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+#ifdef SAFE_HASKELL+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.SafeCopy
src/Data/SafeCopy/Derive.hs view
@@ -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)
src/Data/SafeCopy/Instances.hs view
@@ -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
+ test/instances.hs view
@@ -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+    ]