binary 0.8.4.1 → 0.8.5.0
raw patch · 8 files changed
+258/−59 lines, 8 filesdep ~QuickCheckdep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: QuickCheck, bytestring
API changes (from Hackage documentation)
Files
- README.md +1/−1
- binary.cabal +10/−10
- changelog.md +13/−0
- src/Data/Binary/Class.hs +197/−5
- src/Data/Binary/Get.hs +1/−1
- tests/Arbitrary.hs +0/−40
- tests/QC.hs +35/−1
- tools/derive/BinaryDerive.hs +1/−1
README.md view
@@ -1,6 +1,6 @@ # binary package # -[](http://travis-ci.org/kolmodin/binary)+[](https://hackage.haskell.org/package/binary) [](https://www.stackage.org/package/binary) [](http://travis-ci.org/kolmodin/binary) *Efficient, pure binary serialisation using lazy ByteStrings.*
binary.cabal view
@@ -1,5 +1,5 @@ name: binary-version: 0.8.4.1+version: 0.8.5.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@gmail.com>@@ -31,7 +31,7 @@ location: git://github.com/kolmodin/binary.git library- build-depends: base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array+ build-depends: base >= 4.5.0.0 && < 5, bytestring >= 0.10.4, containers, array hs-source-dirs: src exposed-modules: Data.Binary, Data.Binary.Put,@@ -66,11 +66,11 @@ Arbitrary build-depends: base >= 4.5.0.0 && < 5,- bytestring >= 0.10.2,+ bytestring >= 0.10.4, random>=1.0.1.0, test-framework, test-framework-quickcheck2 >= 0.3,- QuickCheck>=2.8+ QuickCheck == 2.9.* -- build dependencies from using binary source rather than depending on the library build-depends: array, containers@@ -86,7 +86,7 @@ main-is: File.hs build-depends: base >= 4.5.0.0 && < 5,- bytestring >= 0.10.2,+ bytestring >= 0.10.4, Cabal, directory, filepath,@@ -107,7 +107,7 @@ other-modules: MemBench build-depends: base >= 4.5.0.0 && < 5,- bytestring+ bytestring >= 0.10.4 -- build dependencies from using binary source rather than depending on the library build-depends: array, containers c-sources: benchmarks/CBenchmark.c@@ -125,7 +125,7 @@ build-depends: attoparsec, base >= 4.5.0.0 && < 5,- bytestring,+ bytestring >= 0.10.4, cereal, criterion == 1.*, deepseq,@@ -144,7 +144,7 @@ main-is: Put.hs build-depends: base >= 4.5.0.0 && < 5,- bytestring,+ bytestring >= 0.10.4, criterion == 1.*, deepseq -- build dependencies from using binary source rather than depending on the library@@ -161,7 +161,7 @@ main-is: GenericsBench.hs build-depends: base >= 4.5.0.0 && < 5,- bytestring,+ bytestring >= 0.10.4, Cabal == 1.24.*, directory, filepath,@@ -187,7 +187,7 @@ main-is: Builder.hs build-depends: base >= 4.5.0.0 && < 5,- bytestring,+ bytestring >= 0.10.4, criterion == 1.*, deepseq, mtl
changelog.md view
@@ -1,6 +1,19 @@ binary ====== +binary-0.9.0.0+--------------++- `0.8.5.0` was first released as version `0.9.0.0`. It didn't have any+ breaking changes though, so it was again released as version `0.8.5.0`+ according to PVP. Next breaking release of `binary` will be version+ `0.10.0.0`.++binary-0.8.5.0+--------------++- Add Binary instances for Typeable TypeReps, #131.+ binary-0.8.4.1 --------------
src/Data/Binary/Class.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}@@ -15,10 +18,6 @@ #define HAS_FIXED_CONSTRUCTOR #endif -#ifndef HAS_FIXED_CONSTRUCTOR-{-# LANGUAGE ScopedTypeVariables #-}-#endif- ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Class@@ -74,6 +73,12 @@ import Data.List (unfoldr, foldl') -- And needed for the instances:+#if MIN_VERSION_base(4,10,0)+import Type.Reflection+import Type.Reflection.Unsafe+import Data.Kind (Type)+import GHC.Exts (RuntimeRep(..), VecCount, VecElem)+#endif import qualified Data.ByteString as B #if MIN_VERSION_bytestring(0,10,4) import qualified Data.ByteString.Short as BS@@ -819,3 +824,190 @@ get = fmap NE.fromList get put = put . NE.toList #endif++------------------------------------------------------------------------+-- Typeable/Reflection++#if MIN_VERSION_base(4,10,0)++-- $typeable-instances+--+-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and+-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC+-- 8.2.1). In prior GHC releases some of these instances were provided by+-- 'GHCi.TH.Binary' in the @ghci@ package.+--+-- These include instances for,+--+-- * 'VecCount'+-- * 'VecElem'+-- * 'RuntimeRep'+-- * 'KindRep'+-- * 'TypeLitSort'+-- * 'TyCon'+-- * 'TypeRep'+-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')+--++-- | @since 0.9.0.0. See #typeable-instances#+instance Binary VecCount where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @since 0.9.0.0. See #typeable-instances#+instance Binary VecElem where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @since 0.9.0.0. See #typeable-instances#+instance Binary RuntimeRep where+ put (VecRep a b) = putWord8 0 >> put a >> put b+ put (TupleRep reps) = putWord8 1 >> put reps+ put (SumRep reps) = putWord8 2 >> put reps+ put LiftedRep = putWord8 3+ put UnliftedRep = putWord8 4+ put IntRep = putWord8 5+ put WordRep = putWord8 6+ put Int64Rep = putWord8 7+ put Word64Rep = putWord8 8+ put AddrRep = putWord8 9+ put FloatRep = putWord8 10+ put DoubleRep = putWord8 11++ get = do+ tag <- getWord8+ case tag of+ 0 -> VecRep <$> get <*> get+ 1 -> TupleRep <$> get+ 2 -> SumRep <$> get+ 3 -> pure LiftedRep+ 4 -> pure UnliftedRep+ 5 -> pure IntRep+ 6 -> pure WordRep+ 7 -> pure Int64Rep+ 8 -> pure Word64Rep+ 9 -> pure AddrRep+ 10 -> pure FloatRep+ 11 -> pure DoubleRep+ _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"++-- | @since 0.9.0.0. See #typeable-instances#+instance Binary TyCon where+ put tc = do+ put (tyConPackage tc)+ put (tyConModule tc)+ put (tyConName tc)+ put (tyConKindArgs tc)+ put (tyConKindRep tc)+ get = mkTyCon <$> get <*> get <*> get <*> get <*> get++-- | @since 0.9.0.0. See #typeable-instances#+instance Binary KindRep where+ put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k+ put (KindRepVar bndr) = putWord8 1 >> put bndr+ put (KindRepApp a b) = putWord8 2 >> put a >> put b+ put (KindRepFun a b) = putWord8 3 >> put a >> put b+ put (KindRepTYPE r) = putWord8 4 >> put r+ put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r++ get = do+ tag <- getWord8+ case tag of+ 0 -> KindRepTyConApp <$> get <*> get+ 1 -> KindRepVar <$> get+ 2 -> KindRepApp <$> get <*> get+ 3 -> KindRepFun <$> get <*> get+ 4 -> KindRepTYPE <$> get+ 5 -> KindRepTypeLit <$> get <*> get+ _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"++-- | @since 0.9.0.0. See #typeable-instances#+instance Binary TypeLitSort where+ put TypeLitSymbol = putWord8 0+ put TypeLitNat = putWord8 1+ get = do+ tag <- getWord8+ case tag of+ 0 -> pure TypeLitSymbol+ 1 -> pure TypeLitNat+ _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"++putTypeRep :: TypeRep a -> Put+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types]+putTypeRep rep -- Handle Type specially since it's so common+ | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)+ = put (0 :: Word8)+putTypeRep (Con' con ks) = do+ put (1 :: Word8)+ put con+ put ks+putTypeRep (App f x) = do+ put (2 :: Word8)+ putTypeRep f+ putTypeRep x+putTypeRep (Fun arg res) = do+ put (3 :: Word8)+ putTypeRep arg+ putTypeRep res+putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"++getSomeTypeRep :: Get SomeTypeRep+getSomeTypeRep = do+ tag <- get :: Get Word8+ case tag of+ 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+ 1 -> do con <- get :: Get TyCon+ ks <- get :: Get [SomeTypeRep]+ return $ SomeTypeRep $ mkTrCon con ks+ 2 -> do SomeTypeRep f <- getSomeTypeRep+ SomeTypeRep x <- getSomeTypeRep+ case typeRepKind f of+ Fun arg res ->+ case arg `eqTypeRep` typeRepKind x of+ Just HRefl -> do+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+ _ -> failure "Kind mismatch" []+ _ -> failure "Kind mismatch"+ [ "Found argument of kind: " ++ show (typeRepKind x)+ , "Where the constructor: " ++ show f+ , "Expects an argument of kind: " ++ show arg+ ]+ _ -> failure "Applied non-arrow type"+ [ "Applied type: " ++ show f+ , "To argument: " ++ show x+ ]+ 3 -> do SomeTypeRep arg <- getSomeTypeRep+ SomeTypeRep res <- getSomeTypeRep+ case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl ->+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ Fun arg res+ Nothing -> failure "Kind mismatch" []+ Nothing -> failure "Kind mismatch" []+ _ -> failure "Invalid SomeTypeRep" []+ where+ failure description info =+ fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]+ ++ map (" "++) info++instance Typeable a => Binary (TypeRep (a :: k)) where+ put = putTypeRep+ get = do+ SomeTypeRep rep <- getSomeTypeRep+ case rep `eqTypeRep` expected of+ Just HRefl -> pure rep+ Nothing -> fail $ unlines+ [ "GHCi.TH.Binary: Type mismatch"+ , " Deserialized type: " ++ show rep+ , " Expected type: " ++ show expected+ ]+ where expected = typeRep :: TypeRep a++instance Binary SomeTypeRep where+ put (SomeTypeRep rep) = putTypeRep rep+ get = getSomeTypeRep+#endif+
src/Data/Binary/Get.hs view
@@ -41,7 +41,7 @@ -- The fields in @Trade@ are marked as strict (using @!@) since we don't need -- laziness here. In practise, you would probably consider using the UNPACK -- pragma as well.--- <http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#unpack-pragma>+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#unpack-pragma> -- -- Now, let's have a look at a decoder for this format. --
tests/Arbitrary.hs view
@@ -21,43 +21,3 @@ instance Arbitrary S.ShortByteString where arbitrary = S.toShort `fmap` arbitrary #endif--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f) =>- Arbitrary (a,b,c,d,e,f) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- f <- arbitrary- return (a,b,c,d,e,f)--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 = do- (a,b,c,d,e) <- arbitrary- (f,g) <- arbitrary- return (a,b,c,d,e,f,g)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g, Arbitrary h) =>- Arbitrary (a,b,c,d,e,f,g,h) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g,h) <- arbitrary- return (a,b,c,d,e,f,g,h)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) =>- Arbitrary (a,b,c,d,e,f,g,h,i) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g,h,i) <- arbitrary- return (a,b,c,d,e,f,g,h,i)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j) =>- Arbitrary (a,b,c,d,e,f,g,h,i,j) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g,h,i,j) <- arbitrary- return (a,b,c,d,e,f,g,h,i,j)
tests/QC.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} module Main ( main ) where #if MIN_VERSION_base(4,8,0)@@ -21,6 +21,7 @@ #endif import Data.Int import Data.Ratio+import Data.Typeable import System.IO.Unsafe #ifdef HAS_NATURAL@@ -40,6 +41,7 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put+import qualified Data.Binary.Class as Class ------------------------------------------------------------------------ @@ -151,7 +153,38 @@ prop_Doublehost :: Double -> Property prop_Doublehost = roundTripWith putDoublehost getDoublehost +#if MIN_VERSION_base(4,10,0)+testTypeable :: Test+testTypeable = testProperty "TypeRep" prop_TypeRep +prop_TypeRep :: TypeRep -> Property+prop_TypeRep = roundTripWith Class.put Class.get++atomicTypeReps :: [TypeRep]+atomicTypeReps =+ [ typeRep (Proxy :: Proxy ())+ , typeRep (Proxy :: Proxy String)+ , typeRep (Proxy :: Proxy Int)+ , typeRep (Proxy :: Proxy (,))+ , typeRep (Proxy :: Proxy ((,) (Maybe Int)))+ , typeRep (Proxy :: Proxy Maybe)+ , typeRep (Proxy :: Proxy 'Nothing)+ , typeRep (Proxy :: Proxy 'Left)+ , typeRep (Proxy :: Proxy "Hello")+ , typeRep (Proxy :: Proxy 42)+ , typeRep (Proxy :: Proxy '[1,2,3,4])+ , typeRep (Proxy :: Proxy ('Left Int))+ , typeRep (Proxy :: Proxy (Either Int String))+ , typeRep (Proxy :: Proxy (() -> ()))+ ]++instance Arbitrary TypeRep where+ arbitrary = oneof (map pure atomicTypeReps)+#else+testTypeable :: Test+testTypeable = testGroup "Skipping Typeable tests" []+#endif+ -- done, partial and fail -- | Test partial results.@@ -676,4 +709,5 @@ , testProperty "HasResolution -> MkFixed" $ p prop_fixed_resolution_constr ] #endif+ , testTypeable ]
tools/derive/BinaryDerive.hs view
@@ -17,7 +17,7 @@ | nTypeChildren > 0 = wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " | otherwise = ""- inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters+ inst = wrap $ tyConName typeName ++ concatMap (" "++) typeLetters wrap x = if nTypeChildren > 0 then "("++x++")" else x join sep lst = concat $ intersperse sep lst nTypeChildren = length typeChildren