serdoc-binary (empty) → 0.1.0.0
raw patch · 8 files changed
+833/−0 lines, 8 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, mtl, serdoc-binary, serdoc-core, tasty, tasty-quickcheck, text, time
Files
- CHANGELOG.md +5/−0
- LICENSE +13/−0
- README.md +26/−0
- serdoc-binary.cabal +49/−0
- src/Data/SerDoc/Binary.hs +6/−0
- src/Data/SerDoc/Binary/Codec.hs +499/−0
- test/Data/SerDoc/Binary/Test/Codec.hs +221/−0
- test/Main.hs +14/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for serdoc-binary++## v0.1.0++- Initial release
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2023 IO Global++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ README.md view
@@ -0,0 +1,26 @@+serdoc+======++Unified serialization with semi-automatic documentation++Introduction+------------+SerDoc provides:++- A unified interface for serialization formats ("codecs"), in the form of a+ 'Serializable' typeclass.+- A mini-EDSL (`FieldInfo`) for describing serialization formats as first-class+ data structures, and a typeclass (`HasInfo`) to link them to codecs and+ serializable Haskell types.+- Building blocks and utility code for implementing `Codec`, `Serializable`,+ and `HasInfo` for existing or new serialization formats.++It also includes an implementation of these typeclasses for [the `binary`+package](https://hackage.haskell.org/package/binary).++Components+----------+SerDoc is split up into two sub-projects:++- `serdoc-core`, which provides the typeclasses and building blocks+- `serdoc-binary` (this library), which provides instances for `binary`
+ serdoc-binary.cabal view
@@ -0,0 +1,49 @@+cabal-version: 3.0+name: serdoc-binary+version: 0.1.0.0+synopsis: `binary` backend for `serdoc`+-- description:+license: Apache-2.0+license-file: LICENSE+author: Tobias Dammers+maintainer: tobias@well-typed.com+copyright: 2023 IO Global+category: Data+build-type: Simple+extra-doc-files: README.md+ , CHANGELOG.md+-- extra-source-files:++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: Data.SerDoc.Binary+ , Data.SerDoc.Binary.Codec+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.14.0.0 && <5+ , serdoc-core ^>=0.1.0.0+ , binary >=0.8.0.0 && <0.11+ , bytestring >=0.11 && <0.13+ hs-source-dirs: src+ default-language: Haskell2010++test-suite serdoc-binary-test+ import: warnings+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Data.SerDoc.Binary.Test.Codec+ build-depends: base >=4.14.0.0 && <5+ , serdoc-binary+ , serdoc-core ^>=0.1.0.0+ , binary >=0.8.0.0 && <0.11+ , bytestring >=0.11 && <0.13+ , mtl >=2.3.1 && <2.4+ , tasty >=1.5 && <1.6+ , tasty-quickcheck >=0.10.3 && <0.11+ , text >=1.1 && <2.2+ , time >=1.12 && <1.14
+ src/Data/SerDoc/Binary.hs view
@@ -0,0 +1,6 @@+module Data.SerDoc.Binary+( module M+)+where++import Data.SerDoc.Binary.Codec as M
+ src/Data/SerDoc/Binary/Codec.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Data.SerDoc.Binary.Codec+where++import Data.SerDoc.Class as SerDoc+import Data.SerDoc.Info++import qualified Data.Binary as B+import qualified Data.Binary.Put as B+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.ByteString.Short (ShortByteString)+import Data.Int+import Data.List+import Data.Proxy+import Data.Word+import Numeric.Natural++data BinaryCodec++instance Codec BinaryCodec where+ type MonadEncode BinaryCodec = B.PutM+ type MonadDecode BinaryCodec = B.Get++newtype ViaBinary a = ViaBinary { viaBinary :: a }++instance B.Binary a => Serializable BinaryCodec (ViaBinary a) where+ encode _ = B.put . viaBinary+ decode _ = ViaBinary <$> B.get++instance HasInfo BinaryCodec () where+ info _ _ = basicField "()" (FixedSize 0)++deriving via (ViaBinary ()) instance Serializable BinaryCodec ()++instance HasInfo BinaryCodec Bool where+ info codec p = enumInfo codec p (Proxy @Word8)++deriving via (ViaBinary Bool) instance Serializable BinaryCodec Bool++instance HasInfo BinaryCodec Ordering where+ info codec p = enumInfo codec p (Proxy @Word8)++deriving via (ViaBinary Ordering) instance Serializable BinaryCodec Ordering++instance HasInfo BinaryCodec Word8 where+ info _ _ = basicField "Word8" (FixedSize 1)++deriving via (ViaBinary Word8) instance Serializable BinaryCodec Word8++instance HasInfo BinaryCodec Word16 where+ info _ _ = basicField "Word16BE" (FixedSize 2)++deriving via (ViaBinary Word16) instance Serializable BinaryCodec Word16++instance HasInfo BinaryCodec Word32 where+ info _ _ = basicField "Word32BE" (FixedSize 4)++deriving via (ViaBinary Word32) instance Serializable BinaryCodec Word32++instance HasInfo BinaryCodec Word64 where+ info _ _ = basicField "Word64BE" (FixedSize 8)++deriving via (ViaBinary Word64) instance Serializable BinaryCodec Word64++instance HasInfo BinaryCodec Word where+ info _ _ = basicField "Word64BE" (FixedSize 8)++deriving via (ViaBinary Word) instance Serializable BinaryCodec Word++instance HasInfo BinaryCodec Int8 where+ info _ _ = basicField "Int8" (FixedSize 1)++deriving via (ViaBinary Int8) instance Serializable BinaryCodec Int8++instance HasInfo BinaryCodec Int16 where+ info _ _ = basicField "Int16BE" (FixedSize 2)++deriving via (ViaBinary Int16) instance Serializable BinaryCodec Int16++instance HasInfo BinaryCodec Int32 where+ info _ _ = basicField "Int32BE" (FixedSize 4)++deriving via (ViaBinary Int32) instance Serializable BinaryCodec Int32++instance HasInfo BinaryCodec Int64 where+ info _ _ = basicField "Int64BE" (FixedSize 8)++deriving via (ViaBinary Int64) instance Serializable BinaryCodec Int64++instance HasInfo BinaryCodec Int where+ info _ _ = basicField "Int64BE" (FixedSize 8)++deriving via (ViaBinary Int) instance Serializable BinaryCodec Int++instance HasInfo BinaryCodec Float where+ info _ _ = basicField "Float" UnknownSize++deriving via (ViaBinary Float) instance Serializable BinaryCodec Float++instance HasInfo BinaryCodec Double where+ info _ _ = basicField "Double" UnknownSize++deriving via (ViaBinary Double) instance Serializable BinaryCodec Double++instance HasInfo BinaryCodec Integer where+ info codec _ =+ compoundField "Integer"+ [ ("big", info codec (Proxy :: Proxy Bool))+ , ("data",+ choiceField+ (IndexField "big")+ [ info codec (Proxy :: Proxy Int32)+ , compoundField "BigInteger"+ [ ("sign", info codec (Proxy :: Proxy Word8))+ , ("dataBytes", info codec (Proxy :: Proxy [Word8]))+ ]+ ]+ )+ ]++deriving via (ViaBinary Integer) instance Serializable BinaryCodec Integer++instance HasInfo BinaryCodec Natural where+ info codec _ =+ compoundField "Natural"+ [ ("big", info codec (Proxy :: Proxy Bool))+ , ("data",+ choiceField+ (IndexField "big")+ [ info codec (Proxy :: Proxy Word64)+ , info codec (Proxy :: Proxy [Word8])+ ]+ )+ ]++deriving via (ViaBinary Natural) instance Serializable BinaryCodec Natural++instance HasInfo BinaryCodec a => HasInfo BinaryCodec [a] where+ info codec (_ :: Proxy [a]) =+ compoundField "List"+ [ ("length", info codec (Proxy :: Proxy Int))+ , ("items", listField (VarSize "length") (info codec (Proxy :: Proxy a)))+ ]+deriving via (ViaBinary [a]) instance B.Binary a => Serializable BinaryCodec [a]++instance HasInfo BinaryCodec a => HasInfo BinaryCodec (Maybe a) where+ info codec (_ :: Proxy (Maybe a)) =+ compoundField "Maybe"+ [ ("isJust", info codec (Proxy :: Proxy Word8))+ , ("value",+ choiceField+ (IndexField "isJust")+ [ AnnField "Nothing" $ info codec (Proxy :: Proxy ())+ , AnnField "Just" $ info codec (Proxy :: Proxy a)+ ]+ )+ ]+deriving via (ViaBinary (Maybe a)) instance B.Binary a => Serializable BinaryCodec (Maybe a)++instance (HasInfo BinaryCodec a, HasInfo BinaryCodec b)+ => HasInfo BinaryCodec (Either a b)+ where+ info codec (_ :: Proxy (Either a b)) =+ compoundField "Either"+ [ ("constructor", info codec (Proxy :: Proxy Word8))+ , ("value",+ choiceField+ (IndexField "constructor")+ [ AnnField "Left" $ info codec (Proxy :: Proxy a)+ , AnnField "Right" $ info codec (Proxy :: Proxy b)+ ]+ )+ ]++deriving via (ViaBinary (Either a b)) instance (B.Binary a, B.Binary b)+ => Serializable BinaryCodec (Either a b)++tupleInfo :: [FieldInfo codec] -> FieldInfo codec+tupleInfo fieldInfos =+ compoundField combinedName subfieldInfos+ where+ combinedName = "(" <> (mconcat . intersperse ",") (map shortFieldType fieldInfos) <> ")"+ subfieldInfos =+ [ ("elem" <> show (n :: Int), fi)+ | (n, fi) <- zip [0,1..] fieldInfos+ ]++deriving via (ViaBinary (a, b))+ instance+ ( B.Binary a+ , B.Binary b+ )+ =>+ Serializable BinaryCodec (a, b)++deriving via (ViaBinary (a, b, c))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ )+ =>+ Serializable BinaryCodec (a, b, c)++deriving via (ViaBinary (a, b, c, d))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ )+ =>+ Serializable BinaryCodec (a, b, c, d)++deriving via (ViaBinary (a, b, c, d, e))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ , B.Binary e+ )+ =>+ Serializable BinaryCodec (a, b, c, d, e)++deriving via (ViaBinary (a, b, c, d, e, f))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ , B.Binary e+ , B.Binary f+ )+ =>+ Serializable BinaryCodec (a, b, c, d, e, f)++deriving via (ViaBinary (a, b, c, d, e, f, g))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ , B.Binary e+ , B.Binary f+ , B.Binary g+ )+ =>+ Serializable BinaryCodec (a, b, c, d, e, f, g)++deriving via (ViaBinary (a, b, c, d, e, f, g, h))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ , B.Binary e+ , B.Binary f+ , B.Binary g+ , B.Binary h+ )+ =>+ Serializable BinaryCodec (a, b, c, d, e, f, g, h)++deriving via (ViaBinary (a, b, c, d, e, f, g, h, i))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ , B.Binary e+ , B.Binary f+ , B.Binary g+ , B.Binary h+ , B.Binary i+ )+ =>+ Serializable BinaryCodec (a, b, c, d, e, f, g, h, i)++deriving via (ViaBinary (a, b, c, d, e, f, g, h, i, j))+ instance+ ( B.Binary a+ , B.Binary b+ , B.Binary c+ , B.Binary d+ , B.Binary e+ , B.Binary f+ , B.Binary g+ , B.Binary h+ , B.Binary i+ , B.Binary j+ )+ =>+ Serializable BinaryCodec (a, b, c, d, e, f, g, h, i, j)++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ )+ => HasInfo BinaryCodec (a, b)+ where+ info codec (_ :: Proxy (a, b)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ )+ => HasInfo BinaryCodec (a, b, c)+ where+ info codec (_ :: Proxy (a, b, c)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ )+ => HasInfo BinaryCodec (a, b, c, d)+ where+ info codec (_ :: Proxy (a, b, c, d)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ , HasInfo BinaryCodec e+ )+ => HasInfo BinaryCodec (a, b, c, d, e)+ where+ info codec (_ :: Proxy (a, b, c, d, e)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ , info codec (Proxy :: Proxy e)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ , HasInfo BinaryCodec e+ , HasInfo BinaryCodec f+ )+ => HasInfo BinaryCodec (a, b, c, d, e, f)+ where+ info codec (_ :: Proxy (a, b, c, d, e, f)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ , info codec (Proxy :: Proxy e)+ , info codec (Proxy :: Proxy f)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ , HasInfo BinaryCodec e+ , HasInfo BinaryCodec f+ , HasInfo BinaryCodec g+ )+ => HasInfo BinaryCodec (a, b, c, d, e, f, g)+ where+ info codec (_ :: Proxy (a, b, c, d, e, f, g)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ , info codec (Proxy :: Proxy e)+ , info codec (Proxy :: Proxy f)+ , info codec (Proxy :: Proxy g)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ , HasInfo BinaryCodec e+ , HasInfo BinaryCodec f+ , HasInfo BinaryCodec g+ , HasInfo BinaryCodec h+ )+ => HasInfo BinaryCodec (a, b, c, d, e, f, g, h)+ where+ info codec (_ :: Proxy (a, b, c, d, e, f, g, h)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ , info codec (Proxy :: Proxy e)+ , info codec (Proxy :: Proxy f)+ , info codec (Proxy :: Proxy g)+ , info codec (Proxy :: Proxy h)+ ]+++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ , HasInfo BinaryCodec e+ , HasInfo BinaryCodec f+ , HasInfo BinaryCodec g+ , HasInfo BinaryCodec h+ , HasInfo BinaryCodec i+ )+ => HasInfo BinaryCodec (a, b, c, d, e, f, g, h, i)+ where+ info codec (_ :: Proxy (a, b, c, d, e, f, g, h, i)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ , info codec (Proxy :: Proxy e)+ , info codec (Proxy :: Proxy f)+ , info codec (Proxy :: Proxy g)+ , info codec (Proxy :: Proxy h)+ , info codec (Proxy :: Proxy i)+ ]++instance ( HasInfo BinaryCodec a+ , HasInfo BinaryCodec b+ , HasInfo BinaryCodec c+ , HasInfo BinaryCodec d+ , HasInfo BinaryCodec e+ , HasInfo BinaryCodec f+ , HasInfo BinaryCodec g+ , HasInfo BinaryCodec h+ , HasInfo BinaryCodec i+ , HasInfo BinaryCodec j+ )+ => HasInfo BinaryCodec (a, b, c, d, e, f, g, h, i, j)+ where+ info codec (_ :: Proxy (a, b, c, d, e, f, g, h, i, j)) =+ tupleInfo+ [ info codec (Proxy :: Proxy a)+ , info codec (Proxy :: Proxy b)+ , info codec (Proxy :: Proxy c)+ , info codec (Proxy :: Proxy d)+ , info codec (Proxy :: Proxy e)+ , info codec (Proxy :: Proxy f)+ , info codec (Proxy :: Proxy g)+ , info codec (Proxy :: Proxy h)+ , info codec (Proxy :: Proxy i)+ , info codec (Proxy :: Proxy j)+ ]++instance HasInfo BinaryCodec ByteString where+ info codec _ =+ compoundField "List"+ [ ("length", info codec (Proxy :: Proxy Int))+ , ("items", listField (VarSize "length") (info codec (Proxy :: Proxy Word8)))+ ]+deriving via (ViaBinary ByteString) instance Serializable BinaryCodec ByteString++instance HasInfo BinaryCodec LBS.ByteString where+ info codec _ =+ compoundField "List"+ [ ("length", info codec (Proxy :: Proxy Int))+ , ("items", listField (VarSize "length") (info codec (Proxy :: Proxy Word8)))+ ]+deriving via (ViaBinary LBS.ByteString) instance Serializable BinaryCodec LBS.ByteString++instance HasInfo BinaryCodec ShortByteString where+ info codec _ =+ compoundField "List"+ [ ("length", info codec (Proxy :: Proxy Int))+ , ("items", listField (VarSize "length") (info codec (Proxy :: Proxy Word8)))+ ]+deriving via (ViaBinary ShortByteString) instance Serializable BinaryCodec ShortByteString
+ test/Data/SerDoc/Binary/Test/Codec.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.SerDoc.Binary.Test.Codec+where++import Test.Tasty+import Test.Tasty.QuickCheck+import Data.Proxy++import Data.SerDoc.Class+import Data.SerDoc.Info+import Data.SerDoc.TH+import Data.SerDoc.Binary.Codec++import Data.Binary (Binary (..))+import Data.Binary.Get (runGetOrFail)+import Data.Binary.Put (runPut)+import Data.Typeable+import Data.Int+import Data.Word+import Numeric.Natural+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Short as SBS++shrinkBS :: ByteString -> [ByteString]+shrinkBS = fmap BS.pack . shrink . BS.unpack++data TestRecord =+ TestRecord+ { firstField :: Int+ , secondField :: ByteString+ , thirdField :: ()+ }+ deriving (Show, Eq)++instance Arbitrary TestRecord where+ arbitrary =+ TestRecord+ <$> arbitrary+ <*> (BS.pack <$> arbitrary)+ <*> arbitrary+ shrink (TestRecord f1 f2 f3) =+ (TestRecord f1 <$> shrinkBS f2 <*> pure f3)+ +++ (TestRecord <$> shrink f1 <*> pure f2 <*> pure f3)++instance Binary TestRecord where+ get = TestRecord <$> get <*> get <*> get+ put (TestRecord f1 f2 f3) = put (f1, f2, f3)++$(deriveSerDoc ''BinaryCodec [] ''TestRecord)++tests :: TestTree+tests = testGroup "BinaryCodec"+ [ testGroup "Serializable"+ [ testSerializable (Proxy @())+ , testSerializable (Proxy @Integer)+ , testSerializableWith (fromInteger . abs :: Integer -> Natural) (Proxy @Natural)+ , testSerializable (Proxy @Int)+ , testSerializable (Proxy @Int8)+ , testSerializable (Proxy @Int16)+ , testSerializable (Proxy @Int32)+ , testSerializable (Proxy @Int64)+ , testSerializable (Proxy @Word)+ , testSerializable (Proxy @Word8)+ , testSerializable (Proxy @Word16)+ , testSerializable (Proxy @Word32)+ , testSerializable (Proxy @Word64)+ , testSerializable (Proxy @Float)+ , testSerializable (Proxy @Double)+ , testSerializable (Proxy @Ordering)+ , testSerializableWith BS.pack Proxy+ , testSerializableWith LBS.pack Proxy+ , testSerializableWith SBS.pack Proxy+ , testSerializable (Proxy @[Word8])+ , testSerializable (Proxy @[Double])+ , testSerializable (Proxy @(Maybe Word8))+ , testSerializable (Proxy @(Either Word8 Int32))+ , testSerializable (Proxy @(Word8, Int32))+ , testSerializable (Proxy @(Word8, Integer))+ , testSerializable (Proxy @(Word8, Word16, Word32))+ , testSerializable (Proxy @(Word8, Word16, Word32, Word64))+ , testSerializable (Proxy @(Word8, Word16, Word16, Word32, Word64))+ , testSerializable (Proxy @(Word8, Word16, Word16, Word16, Word32, Word64))+ , testSerializable (Proxy @(Word8, Word16, Word16, Word16, Word16, Word32, Word64))+ , testSerializable (Proxy @(Word8, Word16, Word16, Word16, Word16, Word16, Word32, Word64))+ , testSerializable (Proxy @(Word8, Word16, Word16, Word16, Word16, Word16, Word16, Word32, Word64))+ , testSerializable (Proxy @(Word8, Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word32, Word64))+ , testSerializable (Proxy @TestRecord)+ ]+ ]++testSerializable :: forall a.+ ( Typeable a+ , Arbitrary a+ , Show a+ , Eq a+ , Serializable BinaryCodec a+ , HasInfo BinaryCodec a+ , Binary a+ )+ => Proxy a+ -> TestTree+testSerializable =+ testSerializableWith id++testSerializableWith :: forall a b.+ ( Typeable b+ , Arbitrary a+ , Show a+ , Show b+ , Eq b+ , Serializable BinaryCodec b+ , HasInfo BinaryCodec b+ , Binary b+ )+ => (a -> b)+ -> Proxy b+ -> TestTree+testSerializableWith make proxy =+ testGroup (show . typeRep $ proxy)+ [ testProperty "Round trip" $ pRoundTrip . make+ , testProperty "Encoded size matches" $ pEncodedSizeMatches . make+ , testProperty "Binary matches codec" $ pBinaryMatchesCodec . make+ ]++pUnitHasInfo :: (Codec codec, HasInfo codec ())+ => Proxy codec+ -> Property+pUnitHasInfo pCodec =+ actual === expected+ where+ actual = info pCodec (Proxy @())+ expected = basicField "()" (FixedSize 0)++pRoundTrip :: forall a.+ ( Serializable BinaryCodec a+ , Eq a+ , Show a+ )+ => a+ -> Property+pRoundTrip expected =+ case getResult of+ Left (unconsumed, consumed, err) ->+ counterexample ("Error: " ++ err) $+ counterexample ("Unconsumed input: " ++ show unconsumed) $+ counterexample ("Consumed bytes: " ++ show consumed) $+ counterexample ("Encoded: " ++ show encoded) $+ property False+ Right ("", _size, actual) ->+ expected === actual+ Right (unconsumed, consumed, actual) ->+ counterexample "Not all input consumed" $+ counterexample ("Unconsumed input: " ++ show unconsumed) $+ counterexample ("Consumed bytes: " ++ show consumed) $+ counterexample ("Parsed value: " ++ show actual) $+ counterexample ("Encoded: " ++ show encoded) $+ property False+ where+ encoded = runPut $ encode (Proxy @BinaryCodec) expected+ getResult = runGetOrFail (decode (Proxy @BinaryCodec)) encoded++pBinaryMatchesCodec :: forall a.+ ( Serializable BinaryCodec a+ , Binary a+ , Eq a+ , Show a+ )+ => a+ -> Property+pBinaryMatchesCodec value =+ encoded === encodedBinary+ where+ encoded = runPut $ encode (Proxy @BinaryCodec) value+ encodedBinary = runPut $ put value++pEncodedSizeMatches :: forall a.+ ( Serializable BinaryCodec a+ , Eq a+ , Show a+ , HasInfo BinaryCodec a+ )+ => a+ -> Property+pEncodedSizeMatches value =+ case infoSizeExpr of+ FixedSize s ->+ s === encodedSize+ RangeSize (FixedSize lo) (FixedSize hi) ->+ counterexample (show encoded) $+ counterexample (show infoSizeExpr) $+ counterexample (show encodedSize ++ " < " ++ show lo) (property $ encodedSize >= lo)+ .&&.+ counterexample (show encodedSize ++ " > " ++ show hi) (property $ encodedSize <= hi)+ RangeSize (FixedSize lo) _ ->+ counterexample (show encoded) $+ counterexample (show infoSizeExpr) $+ counterexample (show encodedSize ++ " < " ++ show lo) (property $ encodedSize >= lo)+ RangeSize _ (FixedSize hi) ->+ counterexample (show encoded) $+ counterexample (show infoSizeExpr) $+ counterexample (show encodedSize ++ " > " ++ show hi) (property $ encodedSize <= hi)+ s ->+ label (show s) $+ property True+ where+ encoded = runPut $ encode (Proxy @BinaryCodec) value+ encodedSize = fromIntegral $ LBS.length encoded+ fi = info (Proxy @BinaryCodec) (Proxy @a)+ infoSizeExpr = fieldSize fi
+ test/Main.hs view
@@ -0,0 +1,14 @@+module Main+where++import Test.Tasty++import qualified Data.SerDoc.Binary.Test.Codec as Codec++tests :: TestTree+tests = testGroup "serdoc-binary"+ [ Codec.tests+ ]++main :: IO ()+main = defaultMain tests