diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # binary package # -[![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) +[![Hackage version](https://img.shields.io/hackage/v/binary.svg?label=Hackage)](https://hackage.haskell.org/package/binary) [![Stackage version](https://www.stackage.org/package/binary/badge/lts?label=Stackage)](https://www.stackage.org/package/binary) [![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) *Efficient, pure binary serialisation using lazy ByteStrings.* diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.8.4.1 +version: 0.8.5.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 -------------- diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -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 + diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -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. --- +-- -- -- Now, let's have a look at a decoder for this format. -- diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -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) diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -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 ] diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs --- a/tools/derive/BinaryDerive.hs +++ b/tools/derive/BinaryDerive.hs @@ -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