diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,7 +20,7 @@ 0200 0541 6c69 6365 0103 426f 62 [(0, "Alice"), (1, "Bob")] ``` -Unlike `binary` or `cereal` which doesn't preserve metadata at all, winery also +Unlike other libraries that don't preserve metadata (e.g.` binary`, `cereal`, `store`) at all, winery also allows readers to decode values regardless of the current implementation. ## Interface diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs --- a/src/Codec/Winery.hs +++ b/src/Codec/Winery.hs @@ -37,6 +37,7 @@ , readFileDeserialise -- * Separate serialisation , serialiseSchema + , schemaToBuilder , deserialiseSchema , Extractor(..) , unwrapExtractor @@ -108,7 +109,6 @@ import Control.Exception (throw, throwIO) import qualified Data.ByteString as B import qualified Data.ByteString.FastBuilder as BB -import qualified Data.ByteString.Lazy as BL import Data.Function (fix) import qualified Data.Text as T import Data.Text.Prettyprint.Doc (pretty, dquotes) @@ -221,7 +221,7 @@ -- -- /"Write the vision, and make it plain upon tables, that he may run that readeth it."/ serialise :: Serialise a => a -> B.ByteString -serialise = BL.toStrict . BB.toLazyByteString . toBuilderWithSchema +serialise = BB.toStrictByteString . toBuilderWithSchema {-# INLINE serialise #-} -- | 'serialise' then write it to a file. @@ -246,11 +246,13 @@ Decoder $ \bs' i -> DecoderResult (B.length bs') (sch, B.drop i bs') Nothing -> Left EmptyInput --- | Serialise a schema. +-- | Serialise a schema (prefix with the version number only). serialiseSchema :: Schema -> B.ByteString -serialiseSchema = BL.toStrict . BB.toLazyByteString - . mappend (BB.word8 currentSchemaVersion) . toBuilder +serialiseSchema = BB.toStrictByteString . schemaToBuilder +schemaToBuilder :: Schema -> BB.Builder +schemaToBuilder = mappend (BB.word8 currentSchemaVersion) . toBuilder + -- | Deserialise a 'serialise'd 'B.Bytestring'. -- -- /"Old wood to burn! Old wine to drink! Old friends to trust! Old authors to read!"/ @@ -284,7 +286,7 @@ -- -- /"Any unsaved progress will be lost."/ serialiseOnly :: Serialise a => a -> B.ByteString -serialiseOnly = BL.toStrict . BB.toLazyByteString . toBuilder +serialiseOnly = BB.toStrictByteString . toBuilder {-# INLINE serialiseOnly #-} -- | Build an extractor from a 'Subextractor'. diff --git a/src/Codec/Winery/Class.hs b/src/Codec/Winery/Class.hs --- a/src/Codec/Winery/Class.hs +++ b/src/Codec/Winery/Class.hs @@ -945,6 +945,8 @@ | i < len' = L1 <$> variantDecoder len' i | otherwise = R1 <$> variantDecoder (len - len') (i - len') where + -- Nested ':+:' are balanced + -- cf. https://github.com/GaloisInc/cereal/blob/cereal-0.5.8.1/src/Data/Serialize.hs#L659 len' = unsafeShiftR len 1 {-# INLINE variantDecoder #-} @@ -963,6 +965,8 @@ variantEncoder len i (L1 f) = variantEncoder (unsafeShiftR len 1) i f variantEncoder len i (R1 g) = variantEncoder (len - len') (i + len') g where + -- Nested ':+:' are balanced + -- cf. https://github.com/GaloisInc/cereal/blob/cereal-0.5.8.1/src/Data/Serialize.hs#L659 len' = unsafeShiftR len 1 {-# INLINE variantEncoder #-} diff --git a/src/Codec/Winery/Test.hs b/src/Codec/Winery/Test.hs --- a/src/Codec/Winery/Test.hs +++ b/src/Codec/Winery/Test.hs @@ -7,6 +7,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} ---------------------------------------------------------------------------- -- | -- Module : Codec.Winery.Test @@ -24,6 +25,7 @@ ( -- * Generating tests TestGen(..) , printTests + , buildTestGroups -- * Test cases , Tested(..) , testCase @@ -39,6 +41,7 @@ import Data.Functor.Identity import Data.Hashable import Data.Proxy +import qualified Data.Set as Set import qualified Data.Sequence as S import Data.Typeable import Codec.Winery @@ -76,6 +79,13 @@ -- | List of test cases for the type. testCases :: [Test] + default testCases :: (Serialise a, Eq a, Show a) => [Test] + testCases = [testCase sch b a | (sch, xs) <- testGroups @ a, (b, a) <- xs] + + testGroups :: [(Schema, [(B.ByteString, a)])] + testGroups = [] + {-# MINIMAL testGroups | testCases #-} + -- these are already covered by the QuickCheck tests from winery instance Tested Void where testCases = [] instance Tested Bool where testCases = [] @@ -93,6 +103,7 @@ instance Tested a => Tested (Identity a) where testCases = testCases @ a instance Tested a => Tested (S.Seq a) where testCases = [] +instance (Ord a, Tested a) => Tested (Set.Set a) where testCases = [] instance Tested a => Tested [a] where testCases = [] instance (Tested a, Tested b) => Tested (Either a b) where testCases = [] instance (Tested a, Tested b) => Tested (a, b) where testCases = [] @@ -102,11 +113,16 @@ instance (UV.Unbox a, Tested a) => Tested (UV.Vector a) where testCases = [] instance (Hashable k, Tested k, Tested a) => Tested (HM.HashMap k a) where testCases = [] instance (Ord k, Tested k, Tested a) => Tested (M.Map k a) where testCases = [] +instance Tested a => TestGen (Maybe a) +instance Tested a => Tested (Maybe a) where testCases = [] -- | Generate test cases and print them to the standard output. printTests :: forall a. (TestGen a, Serialise a, Show a) => IO () printTests = putStrLn $ showTests (genTestCases :: [a]) +buildTestGroups :: forall a. (TestGen a, Serialise a) => [(Schema, [(B.ByteString, a)])] +buildTestGroups = [(schema (Proxy @ a), [(serialiseOnly a, a) | a <- genTestCases :: [a]])] + showTests :: (Serialise a, Show a) => [a] -> String showTests xs = showListWith ppTest xs "" @@ -184,6 +200,10 @@ genTestCases = [[]] inheritedTests _ = allTests @ a +instance (Ord a, Tested a) => TestGen (Set.Set a) where + genTestCases = [mempty] + inheritedTests _ = allTests @ a + instance Tested a => TestGen (S.Seq a) where genTestCases = [mempty] inheritedTests _ = allTests @ a @@ -213,27 +233,27 @@ inheritedTests = mempty instance TestGen Word8 where - genTestCases = [42] + genTestCases = [8] inheritedTests = mempty instance TestGen Word16 where - genTestCases = [42] + genTestCases = [16] inheritedTests = mempty instance TestGen Word32 where - genTestCases = [42] + genTestCases = [32] inheritedTests = mempty instance TestGen Word64 where - genTestCases = [42] + genTestCases = [64] inheritedTests = mempty instance TestGen Float where - genTestCases = [pi] - inheritedTests = mempty + genTestCases = [0.1] + inheritedTests = mempty instance TestGen Double where - genTestCases = [pi] + genTestCases = [0.2] inheritedTests = mempty instance TestGen Char where @@ -241,9 +261,9 @@ inheritedTests = mempty instance TestGen T.Text where - genTestCases = [mempty] + genTestCases = ["葡"] inheritedTests = mempty instance TestGen B.ByteString where - genTestCases = [mempty] + genTestCases = ["B"] inheritedTests = mempty diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -1,7 +1,6 @@ -cabal-version: 1.12 - +cabal-version: 2.0 name: winery -version: 1.1.2 +version: 1.1.3 synopsis: A compact, well-typed seralisation format for Haskell values description: <> @@ -15,7 +14,7 @@ copyright: Copyright (c) 2019 Fumiaki Kinoshita license: BSD3 license-file: LICENSE -tested-with: GHC == 8.4.4, GHC == 8.6.3 +tested-with: GHC == 8.4.4, GHC == 8.6.3, GHC ==8.8.1 build-type: Simple extra-source-files: README.md @@ -39,8 +38,6 @@ Codec.Winery.Test Data.Winery Data.Winery.Test - other-modules: - Paths_winery hs-source-dirs: src ghc-options: -Wall -O2 -Wcompat @@ -69,8 +66,6 @@ executable winery main-is: Main.hs - other-modules: - Paths_winery hs-source-dirs: app ghc-options: -Wall -O2 -Wcompat @@ -89,8 +84,6 @@ type: exitcode-stdio-1.0 main-is: Spec.hs ghc-options: -Wall -Wcompat - other-modules: - Paths_winery hs-source-dirs: test build-depends: @@ -111,8 +104,6 @@ benchmark bench-winery type: exitcode-stdio-1.0 main-is: bench.hs - other-modules: - Paths_winery hs-source-dirs: benchmarks ghc-options: -O2 -Wall -Wcompat