diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,17 @@ Significant and compatibility-breaking changes. +Version 0.5: + - Compatibility with ghc 9.0.2 & 9.2.4 & 9.4.2 + - Compatibility with text-2.0 + - Fixed https://github.com/Quid2/flat/issues/23 that could cause an encoding failure for non byte aligned Arrays + - Fixed https://github.com/Quid2/flat/pull/26 that could cause the decoder to read beyond the end of the decoding buffer (causing a SEGFAULT on ghcjs) + - Merged https://github.com/Quid2/flat/pull/22 - fails correctly on invalid UTF-8 text + - Added a few ways to partially or incrementally decode values, see Flat.Repr and Flat.Decoder.Run.listTDecoder + - Moved strictDecoder from Flat.Decoder.Types to Flat.Decoder + - Removed Flat instance for Semigroup.Option from Flat.Instances.Base + - Moved overlapping/specialised Flat instance for [Char] to Flat.Instances.Extra + - Added a few extra functions + Version 0.4.4: - Added instances for Identity, Monoid.Dual/All/Any/Sum/Product/Alt, Semigroup.Min/Max/First/Last/Option diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,21 +1,66 @@ -[![Build Status](https://travis-ci.org/Quid2/flat.svg?branch=master)](https://travis-ci.org/Quid2/flat) +![Build Status](https://github.com/Quid2/flat/actions/workflows/haskell-ci.yml/badge.svg) + [![Hackage version](https://img.shields.io/hackage/v/flat.svg)](http://hackage.haskell.org/package/flat) -[![Stackage Nightly](http://stackage.org/package/flat/badge/nightly)](http://stackage.org/nightly/package/model) -[![Stackage LTS](http://stackage.org/package/flat/badge/lts)](http://stackage.org/lts/package/model) +[![Stackage LTS 16](http://stackage.org/package/flat/badge/lts-16)](http://stackage.org/lts/package/flat) +[![Stackage LTS 18](http://stackage.org/package/flat/badge/lts-18)](http://stackage.org/lts/package/flat) +[![Stackage LTS 19](http://stackage.org/package/flat/badge/lts-19)](http://stackage.org/lts/package/flat) +[![Stackage Nightly](http://stackage.org/package/flat/badge/nightly)](http://stackage.org/nightly/package/flat) -Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, language-independent and efficient binary data format. +Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, portable and compact binary data format ([specs](http://quid2.org)). + +### How To Use It For Fun and Profit + +```haskell +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +``` + +```haskell +import Flat +``` + + + +```haskell +data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) +``` + +Use **flat** to encode: + +```haskell +flat $ [North,South] +-> "\149" +``` + + +and **unflat** to decode: + +```haskell +unflat (flat $ [North,South]) :: Decoded [Direction] +-> Right [ North , South ] +``` + + +And thanks to Flat's bit-encoding, this little list fits in a single byte (rather than the five that would be required by a traditional byte encoding): + +```haskell +flatBits $ [North,South] +-> "10010101" +``` + + + ### Performance For some hard data, see this [comparison of the major haskell serialisation libraries](https://github.com/haskell-perf/serialization). Briefly: - * Transfer time (serialisation time + transport time on the network + deserialisation at the receiving end): `flat` is usually faster for all but the highest network speeds * Size: `flat` produces significantly smaller binaries than all other libraries (3/4 times usually) - * Serialization: `store`, `persist` and `flat` are faster - * Deserialization: `store`, `flat`, `persist` and `cereal` are faster + * Serialization time: `store`, `persist` and `flat` are faster + * Deserialization time: `store`, `flat`, `persist` and `cereal` are faster + * Transfer time (serialisation time + transport time on the network + deserialisation at the receiving end): `flat` is usually faster for all but the highest network speeds ### Documentation @@ -25,22 +70,57 @@ * [Flat Format Specification](http://quid2.org/docs/Flat.pdf) + ### Installation Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat). -### Other Stuff You Might Like +### Compatibility -#### [ZM - Language independent, reproducible, absolute types](https://github.com/Quid2/zm) +Tested with: -To decode `flat` encoded data you need to know the type of the serialised data. +* [GHC](https://www.haskell.org/ghc/) 7.10.3 to 9.4.2 (x64) -This is ok for applications that do not require long-term storage and that do not operate in open distributed systems. -For those who do, you might want to supplement `flat` with something like [ZM](https://github.com/Quid2/zm). +* [GHCJS](https://github.com/ghcjs/ghcjs) -#### Ports for other languages + * Note: versions of `flat` prior to 0.33 encode `Double` values incorrectly when they are not aligned with a byte boundary. -[TypeScript-JavaScript](https://github.com/Quid2/ts) and [Purescript](https://www.purescript.org/) ports are under development. + +### Known Bugs and Infelicities + +* Data types with more than 512 constructors are currently unsupported + +* Longish compilation times + + * `flat` relies more than other serialisation libraries on extensive inlining for its good performance, this unfortunately leads to longer compilation times. + + If you have many data types or very large ones this might become an issue. + + A couple of good practices that will eliminate or mitigate this problem are: + + * During development, turn optimisations off (`stack --fast` or `-O0` in the cabal file). + + * Keep your serialisation code in a separate module or modules. + +* See also the [full list of open issues](https://github.com/Quid2/flat/issues). + +### Ports for other languages + +[Rust](https://www.rust-lang.org/) and [TypeScript-JavaScript](https://github.com/Quid2/ts) ports are under development. + + Get in touch if you would like to help porting `flat` to other languages. + +### Acknowledgements + +`flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes bug fixes from a number of contributors. + +### Other Stuff You Might Like + +To decode `flat` encoded data you need to know the type of the serialised data. + +This is ok for applications that do not require long-term storage and that do not operate in open distributed systems. + +For those who do, you might want to supplement `flat` with [ZM - Language independent, reproducible, absolute types](https://github.com/Quid2/zm). diff --git a/flat.cabal b/flat.cabal --- a/flat.cabal +++ b/flat.cabal @@ -1,25 +1,19 @@ cabal-version: >=1.10 name: flat -version: 0.4.4 +version: 0.5 +homepage: http://quid2.org +synopsis: Principled and efficient bit-oriented binary serialization. +description: Reference implementation of `flat`, a principled and efficient binary serialization format. +category: Data,Parsing,Serialization license: BSD3 license-file: LICENSE -copyright: Copyright: (c) 2016-2020 Pasqualino `Titto` Assini +copyright: Copyright: (c) 2016-2022 Pasqualino `Titto` Assini maintainer: tittoassini@gmail.com author: Pasqualino `Titto` Assini -tested-with: - GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 - -homepage: http://quid2.org -synopsis: Principled and efficient bit-oriented binary serialization. -description: - Reference implementation of `flat`, a principled and efficient binary serialization format. - -category: Data,Parsing,Serialization +tested-with: GHC ==7.10.3 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 build-type: Simple extra-source-files: stack.yaml - stack-6.35.yaml - stack-9.21.yaml README.md CHANGELOG @@ -37,6 +31,7 @@ Flat.Class Flat.Decoder Flat.Decoder.Prim + Flat.Decoder.Run Flat.Decoder.Strict Flat.Decoder.Types Flat.Encoder @@ -52,6 +47,7 @@ Flat.Instances.ByteString Flat.Instances.Containers Flat.Instances.DList + Flat.Instances.Extra Flat.Instances.Mono Flat.Instances.Test Flat.Instances.Text @@ -60,6 +56,7 @@ Flat.Instances.Vector Flat.Memory Flat.Run + Flat.Repr Flat.Tutorial Flat.Types @@ -87,8 +84,10 @@ ghc-options: -Wall -O2 -funbox-strict-fields -fno-warn-orphans -fno-warn-name-shadowing + -- -Werror - -- -Werror + -- Stan options + -- -fwrite-ide-info -hiedir=.hie if impl(eta -any) build-depends: @@ -121,30 +120,60 @@ , deepseq >=1.4 , dlist >=0.6 , ghc-prim - , hashable , mono-traversable , pretty >=1.1.2 , primitive - , semigroups , text , unordered-containers , vector + , list-t > 1 + + if impl(ghc <8) + build-depends: + semigroups < 0.19 + , hashable >=1.2.4.0 && <=1.2.7.0 + else + build-depends: hashable >= 1.4.0.2 --- , base >=4.8.2.0 && <5 --- if impl(ghc <8.2) --- build-depends: semigroups >=0.8.4 && <0.17 +-- test-suite ref +-- type: exitcode-stdio-1.0 +-- main-is: Reference.hs +-- hs-source-dirs: test +-- other-modules: +-- Test.Data +-- Test.Data.Arbitrary +-- Test.Data.Flat +-- Test.Data.Values +-- Test.Data2 +-- Test.Data2.Flat +-- Test.E +-- Test.E.Arbitrary +-- Test.E.Flat + +-- default-language: Haskell2010 +-- build-depends: +-- base +-- , flat +-- , zm +-- , ghc-prim +-- , quickcheck-text +-- , tasty-hunit +-- , tasty-quickcheck +-- , text + + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs cpp-options: -DLIST_BIT -DTEST_DECBITS - if impl(ghc <8.6) - cpp-options: -DENUM_LARGE + -- if impl(ghc <8.6) + cpp-options: -DENUM_LARGE -- -DETA_VERSION -Dghcjs_HOST_OS - -- ghc-options: -O1 + ghc-options: -O0 if impl(ghc >8) ghc-options: -Wno-unused-top-binds -Wno-type-defaults -Wno-missing-signatures @@ -172,7 +201,7 @@ , text if impl(ghc <8) - build-depends: semigroups + build-depends: semigroups < 0.19 if impl(eta -any) build-depends: @@ -195,12 +224,13 @@ , deepseq , filepath , mono-traversable - , QuickCheck , tasty , text + , QuickCheck >= 2.14.2 --- dynamic doctests and generation of static doctests --- Usable only with recent versions of ghc (no ghcjs or eta) +-- -- dynamic doctests and generation of static doctests +-- -- Usable only with recent versions of ghc (no ghcjs or eta) + -- test-suite doc -- type: exitcode-stdio-1.0 -- main-is: DocSpec.hs @@ -212,8 +242,10 @@ -- , doctest ==0.16.3.1 -- , filemanip >=0.3.6.3 -- , text +-- , QuickCheck >= 2.14.2 -- static doctests (faster, useful for test coverage and to test ghcjs and eta) + test-suite doc-static type: exitcode-stdio-1.0 main-is: DocTests.hs @@ -225,6 +257,7 @@ DocTest.Flat.Bits DocTest.Flat.Decoder.Prim DocTest.Flat.Endian + DocTest.Flat.Repr DocTest.Flat.Instances.Array DocTest.Flat.Instances.Base DocTest.Flat.Instances.ByteString @@ -235,6 +268,8 @@ DocTest.Flat.Instances.Unordered DocTest.Flat.Instances.Vector DocTest.Flat.Tutorial + DocTest.Flat.Encoder.Prim + DocTest.Flat.Instances.Extra default-language: Haskell2010 build-depends: @@ -245,126 +280,42 @@ , dlist , flat , pretty - , quickcheck-instances , tasty , tasty-hunit , tasty-quickcheck , text , unordered-containers , vector + , QuickCheck >= 2.14.2 - -- >=0.3.22 - --, QuickCheck >= 2.13.2 && < 3 - --, hashable >= 1.2.6.1 && < 1.4 if impl(ghc <8) - build-depends: semigroups + build-depends: semigroups <0.19 ---ghc-options: -Wno-unused-top-binds -Wno-type-defaults +-- Test for Flat.Repr +test-suite repr + type: exitcode-stdio-1.0 + main-is: FlatRepr.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + base + , bytestring + , flat + , timeit + , list-t --- Additional development time tests and benchmarks --- test-suite core --- type: exitcode-stdio-1.0 --- main-is: Core.hs --- hs-source-dirs: test --- default-language: Haskell2010 --- ghc-options: -O2 --- other-modules: --- other-modules: --- Test.Data --- Test.Data.Values --- Test.Data2 --- Test.Data2.Flat --- Test.E --- Test.E.Flat --- Test.Data.Flat --- build-depends: --- base --- , benchpress --- , bytestring --- , containers --- , deepseq --- , flat --- , text --- ,inspection-testing + ghc-options: -rtsopts --- executable listTest --- main-is: ListTest.hs +-- test-suite ghcjs-cons +-- type: exitcode-stdio-1.0 +-- main-is: Cons.hs -- hs-source-dirs: test -- default-language: Haskell2010 -- build-depends: -- base -- , flat --- , text --- , time - --- benchmark microBench --- type: exitcode-stdio-1.0 --- main-is: Micro.hs --- hs-source-dirs: benchmarks test --- other-modules: --- Common --- Test.Data --- Test.Data.Values --- Test.Data2 --- Test.Data2.Flat --- Test.E --- Test.E.Flat --- Test.Data.Flat - --- default-language: Haskell2010 --- build-depends: --- base --- , benchpress -- , bytestring --- , containers --- , deepseq --- , flat --- , text - --- benchmark miniBench --- type: exitcode-stdio-1.0 --- main-is: Mini.hs --- hs-source-dirs: benchmarks test --- other-modules: --- Report --- Test.Data --- Test.Data.Values --- Test.Data2 --- Test.Data2.Flat --- Test.E --- Test.E.Flat --- Test.Data.Flat - --- default-language: Haskell2010 --- ghc-options: -O2 --- build-depends: --- base --- , flat --- , text +-- , jsaddle --- if impl(eta -any) --- build-depends: --- bytestring ==0.10.8.2 --- , containers ==0.5.9.1 --- , criterion ==1.5.1.0 --- , deepseq ==1.4.3.0 --- , directory ==1.3.1.0 --- , filepath ==1.4.1.1 --- , mono-traversable ==1.0.1 --- , process ==1.6.2.0 --- , statistics ==0.14.0.2 --- , text ==1.2.3.0 --- , vector-algorithms ==0.7.0.1 +-- ghc-options: -rtsopts --- else --- build-depends: --- bytestring --- , containers --- , criterion --- , deepseq --- , directory --- , filepath --- , mono-traversable --- , process --- , statistics --- , text diff --git a/src/Data/FloatCast.hs b/src/Data/FloatCast.hs --- a/src/Data/FloatCast.hs +++ b/src/Data/FloatCast.hs @@ -36,9 +36,11 @@ --- | Reinterpret-casts a `Word32` to a `Float`. -{-| + +{- | Reinterpret-casts a `Word32` to a `Float`. + prop> \f -> wordToFloat (floatToWord f ) == f ++++ OK, passed 100 tests. >>> floatToWord (-0.15625) 3189768192 @@ -62,9 +64,11 @@ -- >>> import Numeric (showHex) -- >>> import Data.Word --- | Reinterpret-casts a `Double` to a `Word64`. {-| +Reinterpret-casts a `Double` to a `Word64`. + prop> \f -> wordToDouble (doubleToWord f ) == f ++++ OK, passed 100 tests. >>> showHex (doubleToWord 1.0000000000000004) "" "3ff0000000000002" @@ -89,10 +93,9 @@ wordToDouble x = runST (cast x) -- wordToDouble x = runST (cast $ fix64 x) -{- | ->>> runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) -True --} +-- | +-- >>> runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) +-- True cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 diff --git a/src/Data/ZigZag.hs b/src/Data/ZigZag.hs --- a/src/Data/ZigZag.hs +++ b/src/Data/ZigZag.hs @@ -1,35 +1,36 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | of signed integrals. -module Data.ZigZag - ( ZigZag(..) - ) -where +module Data.ZigZag (ZigZag(..)) where -import Data.Word -import Data.Int -import Data.Bits -import Numeric.Natural +import Data.Bits (Bits (shiftL, shiftR, xor, (.&.)), + FiniteBits (finiteBitSize)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import Numeric.Natural (Natural) -- $setup -- >>> :set -XNegativeLiterals -XScopedTypeVariables -XFlexibleContexts -- >>> import Data.Word -- >>> import Data.Int -- >>> import Numeric.Natural --- >>> import Test.QuickCheck.Instances.Natural +-- >>> import Test.QuickCheck.Arbitrary +-- >>> instance Arbitrary Natural where arbitrary = arbitrarySizedNatural; shrink = shrinkIntegral {-| Convert between a signed integral and the corresponding ZigZag encoded unsigned integral (e.g. between Int8 and Word8 or Integral and Natural). -Invalid conversions produce a type error: +Allow conversion only between compatible types, invalid conversions produce a type error: -zigZag (-1::Int64) :: Word32 +@ +zigZag (-1::Int64) :: Word32 ... ... Couldn't match type ... ... - +@ >>> zigZag (0::Int8) 0 @@ -64,41 +65,63 @@ [0,-1,1,-2,2,-3,3] prop> \(f::Integer) -> zagZig (zigZag f) == f ++++ OK, passed 100 tests. prop> \(f::Natural) -> zigZag (zagZig f) == f ++++ OK, passed 100 tests. prop> \(f::Int8) -> zagZig (zigZag f) == f ++++ OK, passed 100 tests. + prop> \(f::Word8) -> zigZag (zagZig f) == f ++++ OK, passed 100 tests. + prop> \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ++++ OK, passed 100 tests. + prop> \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ++++ OK, passed 100 tests. prop> \(f::Int64) -> zagZig (zigZag f) == f ++++ OK, passed 100 tests. + prop> \(f::Word64) -> zigZag (zagZig f) == f ++++ OK, passed 100 tests. + prop> \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ++++ OK, passed 100 tests. + prop> \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ++++ OK, passed 100 tests. -} - --- Allow conversion only between compatible types -class (Integral signed,Integral unsigned) => ZigZag signed unsigned | unsigned -> signed,signed -> unsigned where +class (Integral signed, Integral unsigned) + => ZigZag signed unsigned | unsigned -> signed, signed -> unsigned where zigZag :: signed -> unsigned default zigZag :: FiniteBits signed => signed -> unsigned - zigZag s = fromIntegral ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1))) - {-# INLINE zigZag #-} + zigZag s = fromIntegral + ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1))) + {-# INLINE zigZag #-} zagZig :: unsigned -> signed default zagZig :: (Bits unsigned) => unsigned -> signed - zagZig u = fromIntegral ((u `shiftR` 1) `xor` (negate (u .&. 1))) + zagZig u = fromIntegral ((u `shiftR` 1) `xor` negate (u .&. 1)) -- default zagZig :: (Bits signed) => unsigned -> signed -- zagZig u = let (s::signed) = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1))) {-# INLINE zagZig #-} instance ZigZag Int8 Word8 + instance ZigZag Int16 Word16 + instance ZigZag Int32 Word32 + instance ZigZag Int64 Word64 + instance ZigZag Integer Natural where - zigZag x | x >= 0 = fromIntegral $ x `shiftL` 1 - | otherwise = fromIntegral $ negate (x `shiftL` 1) - 1 - zagZig u = - let s = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1))) + zigZag x + | x >= 0 = fromIntegral $ x `shiftL` 1 + | otherwise = fromIntegral $ negate (x `shiftL` 1) - 1 + + zagZig u = let s = fromIntegral u + in ((s `shiftR` 1) `xor` negate (s .&. 1)) diff --git a/src/Flat/Bits.hs b/src/Flat/Bits.hs --- a/src/Flat/Bits.hs +++ b/src/Flat/Bits.hs @@ -1,29 +1,34 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} + -- |Utilities to represent and display bit sequences -module Flat.Bits - ( Bits - , toBools - , fromBools - , bits - , paddedBits - , asBytes - , asBits - ) -where +module Flat.Bits ( + Bits, + toBools, + fromBools, + bits, + paddedBits, + asBytes, + asBits, + takeBits, + takeAllBits, +) where +-- TODO: AsBits Class? -import Data.Bits hiding ( Bits ) -import qualified Data.ByteString as B -import Flat.Class -import Flat.Decoder -import Flat.Filler -import Flat.Run -import qualified Data.Vector.Unboxed as V -import Data.Word -import Text.PrettyPrint.HughesPJClass +import Data.Bits (FiniteBits (finiteBitSize), + testBit) +import qualified Data.ByteString as B +import qualified Data.Vector.Unboxed as V +import Data.Word (Word8) +import Flat.Class (Flat) +import Flat.Decoder (Decoded) +import Flat.Filler (PostAligned (PostAligned), + fillerLength) +import Flat.Run (flat, unflatRaw) +import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), hsep, + text) -- |A sequence of bits type Bits = V.Vector Bool @@ -34,37 +39,43 @@ fromBools :: [Bool] -> Bits fromBools = V.fromList --- $setup --- >>> import Data.Word --- >>> import Flat.Instances.Base --- >>> import Flat.Instances.Test +{- $setup +>>> import Data.Word +>>> import Flat.Instances.Base +>>> import Flat.Instances.Test(tst,prettyShow) +-} {- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding) >>> bits True [True] -} -bits :: forall a . Flat a => a -> Bits +bits :: forall a. Flat a => a -> Bits bits v = - let lbs = flat v - Right (PostAligned _ f) = unflatRaw lbs :: Decoded (PostAligned a) - in takeBits (8 * B.length lbs - fillerLength f) lbs + let lbs = flat v + in case unflatRaw lbs :: Decoded (PostAligned a) of + Right (PostAligned _ f) -> takeBits (8 * B.length lbs - fillerLength f) lbs + Left _ -> error "incorrect coding or decoding, please inform the maintainer of this package" {- |The sequence of bits corresponding to the byte-padded serialization of the passed value >>> paddedBits True [True,False,False,False,False,False,False,True] -} -paddedBits :: forall a . Flat a => a -> Bits -paddedBits v = let lbs = flat v in takeBits (8 * B.length lbs) lbs +paddedBits :: forall a. Flat a => a -> Bits +paddedBits v = let lbs = flat v in takeAllBits lbs +takeAllBits :: B.ByteString -> Bits +takeAllBits lbs= takeBits (8 * B.length lbs) lbs + takeBits :: Int -> B.ByteString -> Bits -takeBits numBits lbs = V.generate - (fromIntegral numBits) - (\n -> - let (bb, b) = n `divMod` 8 - in testBit (B.index lbs (fromIntegral bb)) (7 - b) - ) +takeBits numBits lbs = + V.generate + (fromIntegral numBits) + ( \n -> + let (bb, b) = n `divMod` 8 + in testBit (B.index lbs (fromIntegral bb)) (7 - b) + ) {- |Convert an integral value to its equivalent bit representation @@ -75,7 +86,7 @@ asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s - 1 -)) {- |Convert a sequence of bits to the corresponding list of bytes - + >>> asBytes $ asBits (256+3::Word16) [1,3] -} @@ -84,8 +95,7 @@ -- |Convert to the corresponding value (most significant bit first) byteVal :: [Bool] -> Word8 -byteVal = sum . map (\(e, b) -> if b then e else 0) . zip - [ 2 ^ n | n <- [7 :: Int, 6 .. 0] ] +byteVal = sum . zipWith (\ e b -> (if b then e else 0)) ([2 ^ n | n <- [7 :: Int, 6 .. 0]]) -- |Split a list in groups of 8 elements or less bytes :: [t] -> [[t]] @@ -97,9 +107,8 @@ "00000001 00000011" -} instance Pretty Bits where - pPrint = hsep . map prettyBits . bytes . V.toList + pPrint = hsep . map prettyBits . bytes . V.toList prettyBits :: Foldable t => t Bool -> Doc prettyBits l = - text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l - + text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l diff --git a/src/Flat/Class.hs b/src/Flat/Class.hs --- a/src/Flat/Class.hs +++ b/src/Flat/Class.hs @@ -5,14 +5,12 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- |Generics-based generation of Flat instances @@ -22,17 +20,31 @@ Flat(..) , getSize , module GHC.Generics + , GFlatEncode,GFlatDecode,GFlatSize + , SizeOf(..) ) where -import Data.Bits -import Flat.Decoder -import Flat.Encoder -import Data.Word +import Data.Bits (Bits (unsafeShiftL, (.|.))) +import Data.Word (Word16) +import Flat.Decoder.Prim (ConsState (..), consBits, consBool, + consClose, consOpen, dBool) +import Flat.Decoder.Types (Get) +import Flat.Encoder (Encoding, NumBits, eBits16, mempty) +import GHC.Base (Any) import GHC.Generics -import GHC.TypeLits -import Prelude hiding (mempty) --- import Data.Proxy +import GHC.TypeLits (Nat, type (+), type (<=)) +import Prelude hiding (mempty) + +#if MIN_VERSION_base(4,9,0) +import Data.Kind +#endif + +#if ! MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + + -- External and Internal inlining #define INL 2 -- Internal inlining @@ -41,7 +53,7 @@ -- #define INL 0 #if INL == 1 -import GHC.Exts (inline) +import GHC.Exts (inline) #endif -- import Data.Proxy @@ -50,23 +62,32 @@ getSize :: Flat a => a -> NumBits getSize a = size a 0 --- |Class of types that can be encoded/decoded +{-| Class of types that can be encoded/decoded + +Encoding a value involves three steps: + +* calculate the maximum size of the serialised value, using `size` + +* preallocate a buffer of the required size + +* encode the value in the buffer, using `encode` +-} class Flat a where -- |Return the encoding corrresponding to the value encode :: a -> Encoding - default encode :: (Generic a, GEncode (Rep a)) => a -> Encoding + default encode :: (Generic a, GFlatEncode (Rep a)) => a -> Encoding encode = gencode . from -- |Decode a value decode :: Get a - default decode :: (Generic a, GDecode (Rep a)) => Get a + default decode :: (Generic a, GFlatDecode (Rep a)) => Get a decode = to `fmap` gget -- |Add maximum size in bits of the value to the total count - -- - -- Used to calculated maximum buffer size before encoding + -- + -- Used to calculated maximum buffer size before encoding size :: a -> NumBits -> NumBits - default size :: (Generic a, GSize (Rep a)) => a -> NumBits -> NumBits + default size :: (Generic a, GFlatSize (Rep a)) => a -> NumBits -> NumBits size !x !n = gsize n $ from x #if INL>=2 @@ -82,29 +103,44 @@ {-# NOINLINE encode #-} #endif +-- | Skip a value, return its size in bits +skip :: forall a. (GFlatSize (Rep a),GFlatDecode (Rep a)) => Get (SizeOf a) +skip = SizeOf . (gsize 0 :: Rep a Any -> NumBits) <$> (gget :: Get (Rep a Any)) +{-# INLINE skip #-} + +-- | Decode to the size in bits of a value rather than to the value itself (see "Flat.Repr") +newtype SizeOf a = SizeOf NumBits deriving Show + +instance (GFlatSize (Rep a),GFlatDecode (Rep a)) => Flat (SizeOf a) where + size = error "unused" + encode = error "unused" + + decode = skip + + -- |Generic Encoder -class GEncode f where gencode :: f a -> Encoding +class GFlatEncode f where gencode :: f a -> Encoding -instance {-# OVERLAPPABLE #-} GEncode f => GEncode (M1 i c f) where +instance {-# OVERLAPPABLE #-} GFlatEncode f => GFlatEncode (M1 i c f) where gencode = gencode . unM1 {-# INLINE gencode #-} -- Special case, single constructor datatype -instance {-# OVERLAPPING #-} GEncode a => GEncode (D1 i (C1 c a)) where +instance {-# OVERLAPPING #-} GFlatEncode a => GFlatEncode (D1 i (C1 c a)) where gencode = gencode . unM1 . unM1 {-# INLINE gencode #-} -- Type without constructors -instance GEncode V1 where +instance GFlatEncode V1 where gencode = unused {-# INLINE gencode #-} -- Constructor without arguments -instance GEncode U1 where +instance GFlatEncode U1 where gencode U1 = mempty {-# INLINE gencode #-} -instance Flat a => GEncode (K1 i a) where +instance Flat a => GFlatEncode (K1 i a) where {-# INLINE gencode #-} #if INL == 1 gencode x = inline encode (unK1 x) @@ -112,56 +148,56 @@ gencode = encode . unK1 #endif -instance (GEncode a, GEncode b) => GEncode (a :*: b) where +instance (GFlatEncode a, GFlatEncode b) => GFlatEncode (a :*: b) where --gencode (!x :*: (!y)) = gencode x <++> gencode y gencode (x :*: y) = gencode x <> gencode y {-# INLINE gencode #-} -instance (NumConstructors (a :+: b) <= 512,GEncodeSum (a :+: b)) => GEncode (a :+: b) where --- instance (GEncodeSum (a :+: b)) => GEncode (a :+: b) where +instance (NumConstructors (a :+: b) <= 512,GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where +-- instance (GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where gencode = gencodeSum 0 0 {-# INLINE gencode #-} -- Constructor Encoding -class GEncodeSum f where +class GFlatEncodeSum f where gencodeSum :: Word16 -> NumBits -> f a -> Encoding -instance (GEncodeSum a, GEncodeSum b) => GEncodeSum (a :+: b) where +instance (GFlatEncodeSum a, GFlatEncodeSum b) => GFlatEncodeSum (a :+: b) where gencodeSum !code !numBits s = case s of - L1 !x -> gencodeSum ((code `unsafeShiftL` 1)) (numBits+1) x + L1 !x -> gencodeSum (code `unsafeShiftL` 1) (numBits+1) x R1 !x -> gencodeSum ((code `unsafeShiftL` 1) .|. 1) (numBits+1) x {-# INLINE gencodeSum #-} -instance GEncode a => GEncodeSum (C1 c a) where +instance GFlatEncode a => GFlatEncodeSum (C1 c a) where gencodeSum !code !numBits x = eBits16 numBits code <> gencode x {-# INLINE gencodeSum #-} -- |Generic Decoding -class GDecode f where +class GFlatDecode f where gget :: Get (f t) -- |Metadata (constructor name, etc) -instance GDecode a => GDecode (M1 i c a) where +instance GFlatDecode a => GFlatDecode (M1 i c a) where gget = M1 <$> gget {-# INLINE gget #-} -- |Type without constructors -instance GDecode V1 where +instance GFlatDecode V1 where gget = unused {-# INLINE gget #-} -- |Constructor without arguments -instance GDecode U1 where +instance GFlatDecode U1 where gget = pure U1 {-# INLINE gget #-} -- |Product: constructor with parameters -instance (GDecode a, GDecode b) => GDecode (a :*: b) where +instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :*: b) where gget = (:*:) <$> gget <*> gget {-# INLINE gget #-} -- |Constants, additional parameters, and rank-1 recursion -instance Flat a => GDecode (K1 i a) where +instance Flat a => GFlatDecode (K1 i a) where #if INL == 1 gget = K1 <$> inline decode #else @@ -198,12 +234,12 @@ #define DEC_BOOL #ifdef DEC_BOOLG -instance (GDecode a, GDecode b) => GDecode (a :+: b) +instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b) #endif #ifdef DEC_BOOLC -- Special case for data types with two constructors -instance {-# OVERLAPPING #-} (GDecode a,GDecode b) => GDecode (C1 m1 a :+: C1 m2 b) +instance {-# OVERLAPPING #-} (GFlatDecode a,GFlatDecode b) => GFlatDecode (C1 m1 a :+: C1 m2 b) #endif #ifdef DEC_BOOL @@ -219,22 +255,22 @@ #ifdef DEC_CONS -- | Data types with up to 512 constructors -- Uses a custom constructor decoding state --- instance {-# OVERLAPPABLE #-} (GDecodeSum (a :+: b),GDecode a, GDecode b) => GDecode (a :+: b) where -instance {-# OVERLAPPABLE #-} (NumConstructors (a :+: b) <= 512, GDecodeSum (a :+: b)) => GDecode (a :+: b) where +-- instance {-# OVERLAPPABLE #-} (GFlatDecodeSum (a :+: b),GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b) where +instance {-# OVERLAPPABLE #-} (NumConstructors (a :+: b) <= 512, GFlatDecodeSum (a :+: b)) => GFlatDecode (a :+: b) where gget = do cs <- consOpen getSum cs {-# INLINE gget #-} -- |Constructor Decoder -class GDecodeSum f where +class GFlatDecodeSum f where getSum :: ConsState -> Get (f a) #ifdef DEC_CONS48 -- Decode constructors in groups of 2 or 3 bits -- Significantly reduce instance compilation time and slightly improve execution times -instance {-# OVERLAPPING #-} (GDecodeSum n1,GDecodeSum n2,GDecodeSum n3,GDecodeSum n4) => GDecodeSum ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- getSum = undefined +instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4) => GFlatDecodeSum ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- getSum = undefined where getSum cs = do -- error "DECODE4" @@ -246,7 +282,7 @@ _ -> R1 . R1 <$> getSum cs' {-# INLINE getSum #-} -instance {-# OVERLAPPING #-} (GDecodeSum n1,GDecodeSum n2,GDecodeSum n3,GDecodeSum n4,GDecodeSum n5,GDecodeSum n6,GDecodeSum n7,GDecodeSum n8) => GDecodeSum (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- getSum cs = undefined +instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4,GFlatDecodeSum n5,GFlatDecodeSum n6,GFlatDecodeSum n7,GFlatDecodeSum n8) => GFlatDecodeSum (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- getSum cs = undefined where getSum cs = do --error "DECODE8" @@ -262,9 +298,9 @@ _ -> R1 . R1 . R1 <$> getSum cs' {-# INLINE getSum #-} -instance {-# OVERLAPPABLE #-} (GDecodeSum a, GDecodeSum b) => GDecodeSum (a :+: b) where +instance {-# OVERLAPPABLE #-} (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where #else -instance (GDecodeSum a, GDecodeSum b) => GDecodeSum (a :+: b) where +instance (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where #endif getSum cs = do @@ -273,13 +309,13 @@ {-# INLINE getSum #-} -instance GDecode a => GDecodeSum (C1 c a) where +instance GFlatDecode a => GFlatDecodeSum (C1 c a) where getSum (ConsState _ usedBits) = consClose usedBits >> gget {-# INLINE getSum #-} #endif #ifdef DEC_BOOL48 -instance {-# OVERLAPPING #-} (GDecode n1,GDecode n2,GDecode n3,GDecode n4) => GDecode ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- gget = undefined +instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4) => GFlatDecode ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- gget = undefined where gget = do -- error "DECODE4" @@ -291,7 +327,7 @@ _ -> R1 <$> R1 <$> gget {-# INLINE gget #-} -instance {-# OVERLAPPING #-} (GDecode n1,GDecode n2,GDecode n3,GDecode n4,GDecode n5,GDecode n6,GDecode n7,GDecode n8) => GDecode (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- gget = undefined +instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4,GFlatDecode n5,GFlatDecode n6,GFlatDecode n7,GFlatDecode n8) => GFlatDecode (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- gget = undefined where gget = do --error "DECODE8" @@ -310,25 +346,25 @@ -- |Calculate the number of bits required for the serialisation of a value -- Implemented as a function that adds the maximum size to a running total -class GSize f where gsize :: NumBits -> f a -> NumBits +class GFlatSize f where gsize :: NumBits -> f a -> NumBits -- |Skip metadata -instance GSize f => GSize (M1 i c f) where +instance GFlatSize f => GFlatSize (M1 i c f) where gsize !n = gsize n . unM1 {-# INLINE gsize #-} -- |Type without constructors -instance GSize V1 where +instance GFlatSize V1 where gsize !n _ = n {-# INLINE gsize #-} -- |Constructor without arguments -instance GSize U1 where +instance GFlatSize U1 where gsize !n _ = n {-# INLINE gsize #-} -- |Skip metadata -instance Flat a => GSize (K1 i a) where +instance Flat a => GFlatSize (K1 i a) where #if INL == 1 gsize !n x = inline size (unK1 x) n #else @@ -336,8 +372,8 @@ #endif {-# INLINE gsize #-} -instance (GSize a, GSize b) => GSize (a :*: b) where - gsize !n (x :*: y) = +instance (GFlatSize a, GFlatSize b) => GFlatSize (a :*: b) where + gsize !n (x :*: y) = let !n' = gsize n x in gsize n' y -- gsize (gsize n x) y @@ -352,56 +388,56 @@ -- #define SIZ_MAX_PROX #ifdef SIZ_ADD -instance (GSizeSum (a :+: b)) => GSize (a :+: b) where +instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where gsize !n = gsizeSum n #endif #ifdef SIZ_NUM -instance (GSizeSum (a :+: b)) => GSize (a :+: b) where +instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where gsize !n x = n + gsizeSum 0 x #endif #ifdef SIZ_MAX -instance (GSizeNxt (a :+: b),GSizeMax (a:+:b)) => GSize (a :+: b) where +instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where gsize !n x = gsizeNxt (gsizeMax x + n) x {-# INLINE gsize #-} -- |Calculate the maximum size of a class constructor (that might be one bit more than the size of some of its constructors) #ifdef SIZ_MAX_VAL -class GSizeMax (f :: * -> *) where gsizeMax :: f a -> NumBits +class GFlatSizeMax (f :: * -> *) where gsizeMax :: f a -> NumBits -instance (GSizeMax f, GSizeMax g) => GSizeMax (f :+: g) where +instance (GFlatSizeMax f, GFlatSizeMax g) => GFlatSizeMax (f :+: g) where gsizeMax _ = 1 + max (gsizeMax (undefined::f a )) (gsizeMax (undefined::g a)) {-# INLINE gsizeMax #-} -instance (GSize a) => GSizeMax (C1 c a) where +instance (GFlatSize a) => GFlatSizeMax (C1 c a) where {-# INLINE gsizeMax #-} gsizeMax _ = 0 #endif #ifdef SIZ_MAX_PROX --- instance (GSizeNxt (a :+: b),GSizeMax (a:+:b)) => GSize (a :+: b) where +-- instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where -- gsize !n x = gsizeNxt (gsizeMax x + n) x -- {-# INLINE gsize #-} -- -- |Calculate size in bits of constructor --- class KnownNat n => GSizeMax (n :: Nat) (f :: * -> *) where gsizeMax :: f a -> Proxy n -> NumBits +-- class KnownNat n => GFlatSizeMax (n :: Nat) (f :: * -> *) where gsizeMax :: f a -> Proxy n -> NumBits --- instance (GSizeMax (n + 1) a, GSizeMax (n + 1) b, KnownNat n) => GSizeMax n (a :+: b) where +-- instance (GFlatSizeMax (n + 1) a, GFlatSizeMax (n + 1) b, KnownNat n) => GFlatSizeMax n (a :+: b) where -- gsizeMax !n x _ = case x of -- L1 !l -> gsizeMax n l (Proxy :: Proxy (n+1)) -- R1 !r -> gsizeMax n r (Proxy :: Proxy (n+1)) -- {-# INLINE gsizeMax #-} --- instance (GSize a, KnownNat n) => GSizeMax n (C1 c a) where +-- instance (GFlatSize a, KnownNat n) => GFlatSizeMax n (C1 c a) where -- {-# INLINE gsizeMax #-} -- gsizeMax !n !x _ = gsize (constructorSize + n) x -- where -- constructorSize :: NumBits -- constructorSize = fromInteger (natVal (Proxy :: Proxy n)) --- class KnownNat (ConsSize f) => GSizeMax (f :: * -> *) where +-- class KnownNat (ConsSize f) => GFlatSizeMax (f :: * -> *) where -- gsizeMax :: f a -> NumBits -- gsizeMax _ = fromInteger (natVal (Proxy :: Proxy (ConsSize f))) @@ -418,37 +454,46 @@ #endif -- |Calculate the size of a value, not taking in account its constructor -class GSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a -> NumBits +class GFlatSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a -> NumBits -instance (GSizeNxt a, GSizeNxt b) => GSizeNxt (a :+: b) where +instance (GFlatSizeNxt a, GFlatSizeNxt b) => GFlatSizeNxt (a :+: b) where gsizeNxt n x = case x of L1 !l-> gsizeNxt n l R1 !r-> gsizeNxt n r {-# INLINE gsizeNxt #-} -instance (GSize a) => GSizeNxt (C1 c a) where +instance (GFlatSize a) => GFlatSizeNxt (C1 c a) where {-# INLINE gsizeNxt #-} gsizeNxt !n !x = gsize n x #endif -- |Calculate size in bits of constructor -- vs proxy implementation: similar compilation time but much better run times (at least for Tree N, -70%) -class GSizeSum (f :: * -> *) where gsizeSum :: NumBits -> f a -> NumBits +#if MIN_VERSION_base(4,9,0) +class GFlatSizeSum (f :: Type -> Type) where +#else +class GFlatSizeSum (f :: * -> *) where +#endif + gsizeSum :: NumBits -> f a -> NumBits -instance (GSizeSum a, GSizeSum b) - => GSizeSum (a :+: b) where +instance (GFlatSizeSum a, GFlatSizeSum b) + => GFlatSizeSum (a :+: b) where gsizeSum !n x = case x of L1 !l-> gsizeSum (n+1) l R1 !r-> gsizeSum (n+1) r {-# INLINE gsizeSum #-} -instance (GSize a) => GSizeSum (C1 c a) where +instance (GFlatSize a) => GFlatSizeSum (C1 c a) where {-# INLINE gsizeSum #-} gsizeSum !n !x = gsize n x -- |Calculate number of constructors +#if MIN_VERSION_base(4,9,0) +type family NumConstructors (a :: Type -> Type) :: Nat where +#else type family NumConstructors (a :: * -> *) :: Nat where +#endif NumConstructors (C1 c a) = 1 NumConstructors (x :+: y) = NumConstructors x + NumConstructors y diff --git a/src/Flat/Decoder.hs b/src/Flat/Decoder.hs --- a/src/Flat/Decoder.hs +++ b/src/Flat/Decoder.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} -- |Strict Decoder module Flat.Decoder ( strictDecoder, - -- strictDecoderPart, + listTDecoder, Decoded, DecodeException(..), Get, @@ -46,5 +46,6 @@ ) where import Flat.Decoder.Prim +import Flat.Decoder.Run import Flat.Decoder.Strict import Flat.Decoder.Types diff --git a/src/Flat/Decoder/Prim.hs b/src/Flat/Decoder/Prim.hs --- a/src/Flat/Decoder/Prim.hs +++ b/src/Flat/Decoder/Prim.hs @@ -25,21 +25,33 @@ ConsState(..),consOpen,consClose,consBool,consBits ) where -import Control.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Flat.Decoder.Types -import Flat.Endian -import Flat.Memory -import Data.FloatCast -import Data.Word -import Foreign +import Control.Monad (when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.FloatCast (wordToDouble, wordToFloat) +import Data.Word (Word16, Word32, Word64, Word8) +import Flat.Decoder.Types (Get (Get), GetResult (..), S (..), + badEncoding, badOp, notEnoughSpace) +import Flat.Endian (toBE16, toBE32, toBE64) +import Flat.Memory (ByteArray, chunksToByteArray, + chunksToByteString, minusPtr) +import Foreign (Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)), + FiniteBits (finiteBitSize), Ptr, + Storable (peek), castPtr, plusPtr, + ptrToIntPtr) +#ifdef ghcjs_HOST_OS +import Foreign (shift) +#else +#endif + -- $setup -- >>> :set -XBinaryLiterals -- >>> import Data.Word -- >>> import Data.Int -- >>> import Flat.Run +-- >>> import Flat.Bits +-- >>> import Text.PrettyPrint.HughesPJClass (Pretty (pPrint)) {- |A special state, optimised for constructor decoding. @@ -59,14 +71,14 @@ consOpen :: Get ConsState consOpen = Get $ \endPtr s -> do let u = usedBits s - w <- case compare (currPtr s) endPtr of - LT -> do -- two different bytes - w16::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) - return $ fromIntegral w16 `unsafeShiftL` (u+(wordSize-16)) - EQ -> do - w8 :: Word8 <- peek (currPtr s) - return $ fromIntegral w8 `unsafeShiftL` (u+(wordSize-8)) - GT -> notEnoughSpace endPtr s + let d = ptrToIntPtr endPtr - ptrToIntPtr (currPtr s) + w <- if d > 1 then do -- two different bytes + w16::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) + return $ fromIntegral w16 `unsafeShiftL` (u+(wordSize-16)) + else if d == 1 then do -- single last byte left + w8 :: Word8 <- peek (currPtr s) + return $ fromIntegral w8 `unsafeShiftL` (u+(wordSize-8)) + else notEnoughSpace endPtr s return $ GetResult s (ConsState w 0) -- |Switch back to normal decoding @@ -98,7 +110,7 @@ -- consBool (ConsState w usedBits) = (ConsState (w `unsafeShiftL` 1) (1+usedBits),0 /= 32768 .&. w) -- |Decode from 1 to 3 bits --- +-- -- It could read more bits that are available, but it doesn't matter, errors will be checked in consClose. consBits :: ConsState -> Int -> (ConsState, Word) consBits cs 3 = consBits_ cs 3 7 @@ -162,9 +174,9 @@ -- bits = n' .|. 7 in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits} -{-# INLINE dBool #-} --- Inlining dBool Massively increases compilation time and decreases run time by a third --- TODO: test dBool inlining for 8.8.3 +{-# INLINE dBool #-} +-- Inlining dBool massively increases compilation time but decreases run time by a third +-- TODO: test dBool inlining for ghc >= 8.8.4 -- |Decode a boolean dBool :: Get Bool dBool = Get $ \endPtr s -> @@ -186,6 +198,9 @@ >>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 True + +>>> unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] +Left (BadOp "read8: cannot read 9 bits") -} dBEBits8 :: Int -> Get Word8 dBEBits8 n = Get $ \endPtr s -> do @@ -193,15 +208,25 @@ take8 s n {-# INLINE dBEBits16 #-} --- |Return the n most significant bits (up to maximum of 16) --- The bits are returned right shifted. +{- | Return the n most significant bits (up to maximum of 16) + +The bits are returned right shifted: + +>>> pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] +Right 00000101 10111111 + +If more than 16 bits are requested, only the last 16 are returned: + +>>> pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] +Right 00000111 11111111 +-} dBEBits16 :: Int -> Get Word16 dBEBits16 n = Get $ \endPtr s -> do ensureBits endPtr s n takeN n s {-# INLINE dBEBits32 #-} --- |Return the n most significant bits (up to maximum of 8) +-- |Return the n most significant bits (up to maximum of 32) -- The bits are returned right shifted. dBEBits32 :: Int -> Get Word32 dBEBits32 n = Get $ \endPtr s -> do @@ -209,7 +234,7 @@ takeN n s {-# INLINE dBEBits64 #-} --- |Return the n most significant bits (up to maximum of 8) +-- |Return the n most significant bits (up to maximum of 64) -- The bits are returned right shifted. dBEBits64 :: Int -> Get Word64 dBEBits64 n = Get $ \endPtr s -> do @@ -241,15 +266,15 @@ where --{-# INLINE read8 #-} read8 :: S -> Int -> IO Word8 - read8 s n | n >=0 && n <=8 = - if n <= 8 - usedBits s - then do -- all bits in the same byte - w <- peek (currPtr s) - return $ (w `unsafeShiftL` usedBits s) `shR` (8 - n) - else do -- two different bytes - w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) - return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n) - | otherwise = error $ unwords ["read8: cannot read",show n,"bits"] + read8 s n | n >=0 && n <=8 = + if n <= 8 - usedBits s + then do -- all bits in the same byte + w <- peek (currPtr s) + return $ (w `unsafeShiftL` usedBits s) `shR` (8 - n) + else do -- two different bytes + w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) + return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n) + | otherwise = badOp $ unwords ["read8: cannot read",show n,"bits"] -- {-# INLINE dropBits8 #-} -- -- Assume n <= 8 dropBits8 :: S -> Int -> S @@ -399,9 +424,9 @@ -- >>> shR (0b1111111111111111::Word16) 3 == 0b0001111111111111 -- True --- >>> shR (-1::Int16) 3 +-- >>> shR (-1::Int16) 3 -- -1 --- -} +-- -} {-# INLINE shR #-} shR :: Bits a => a -> Int -> a #ifdef ghcjs_HOST_OS diff --git a/src/Flat/Decoder/Run.hs b/src/Flat/Decoder/Run.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Decoder/Run.hs @@ -0,0 +1,68 @@ +module Flat.Decoder.Run(strictDecoder,listTDecoder) where + +import Control.Exception (Exception, try) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BS +import Flat.Decoder.Prim (dBool) +import Flat.Decoder.Types (DecodeException, Get (runGet), + GetResult (..), S (S), tooMuchSpace) +import Foreign (Ptr, plusPtr, withForeignPtr) +import ListT (ListT (..)) +import System.IO.Unsafe (unsafePerformIO) + +-- | Given a decoder and an input buffer returns either the decoded value or an error (if the input buffer is not fully consumed) +strictDecoder :: Get a -> B.ByteString -> Either DecodeException a +strictDecoder get bs = + strictDecoder_ get bs $ \(GetResult s'@(S ptr' o') a) endPtr -> + if ptr' /= endPtr || o' /= 0 + then tooMuchSpace endPtr s' + else return a + +strictDecoder_ :: + Exception e + => Get a1 + -> BS.ByteString + -> (GetResult a1 -> Ptr b -> IO a) + -> Either e a +strictDecoder_ get (BS.PS base off len) check = + unsafePerformIO . try $ + withForeignPtr base $ \base0 -> + let ptr = base0 `plusPtr` off + endPtr = ptr `plusPtr` len + in do res <- runGet get endPtr (S ptr 0) + check res endPtr +{-# NOINLINE strictDecoder_ #-} + + +-- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits) +-- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $ +-- withForeignPtr base $ \base0 -> +-- let ptr = base0 `plusPtr` off +-- endPtr = ptr `plusPtr` len +-- in do +-- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0) +-- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o') + +{-| +Decode a list of values, one value at a time. + +Useful in case that the decoded values takes a lot more memory than the encoded ones. + +See test/FlatRepr.hs for a test and an example of use. + +@since 0.5 +-} +listTDecoder :: Get a -> BS.ByteString -> IO (ListT IO a) +listTDecoder get (BS.PS base off len) = + withForeignPtr base $ \base0 -> do + let ptr = base0 `plusPtr` off + endPtr = ptr `plusPtr` len + s = S ptr 0 + go s = do + GetResult s' b <- runGet dBool endPtr s + if b + then do + GetResult s'' a <- runGet get endPtr s' + return $ Just (a, ListT $ go s'') + else return Nothing + return $ ListT (go s) diff --git a/src/Flat/Decoder/Strict.hs b/src/Flat/Decoder/Strict.hs --- a/src/Flat/Decoder/Strict.hs +++ b/src/Flat/Decoder/Strict.hs @@ -32,16 +32,19 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Short as SBS +#if !MIN_VERSION_bytestring(0,11,0) import qualified Data.ByteString.Short.Internal as SBS +#endif +import Control.Monad (unless) import qualified Data.DList as DL -import Flat.Decoder.Prim -import Flat.Decoder.Types import Data.Int import Data.Primitive.ByteArray import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Flat.Decoder.Prim +import Flat.Decoder.Types -#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) && ! MIN_VERSION_text(2,0,0) import qualified Data.Text.Array as TA import qualified Data.Text.Internal as T #endif @@ -49,8 +52,7 @@ import Data.Word import Data.ZigZag import GHC.Base (unsafeChr) -import Numeric.Natural - +import Numeric.Natural (Natural) #include "MachDeps.h" {-# INLINE decodeListWith #-} @@ -93,6 +95,7 @@ {-# INLINE dInt #-} dWord :: Get Word dInt :: Get Int + #if WORD_SIZE_IN_BITS == 64 dWord = (fromIntegral :: Word64 -> Word) <$> dWord64 @@ -105,6 +108,13 @@ #error expected WORD_SIZE_IN_BITS to be 32 or 64 #endif + + + + + + + {-# INLINE dInt8 #-} dInt8 :: Get Int8 dInt8 = zagZig <$> dWord8 @@ -162,7 +172,7 @@ charStep !shl !cont !n = do !tw <- fromIntegral <$> dWord8 let !w = tw .&. 127 - let !v = n .|. (w `shift` shl) + let !v = n .|. w `shift` shl if tw == w then return $ unsafeChr v else cont v @@ -172,21 +182,21 @@ lastCharStep !shl !n = do !tw <- fromIntegral <$> dWord8 let !w = tw .&. 127 - let !v = n .|. (w `shift` shl) + let !v = n .|. w `shift` shl if tw == w then if v > 0x10FFFF then charErr v else return $ unsafeChr v else charErr v - where - charErr v = fail $ concat ["Unexpected extra byte or non unicode char", show v] + where + charErr v = fail $ "Unexpected extra byte or non unicode char" ++ show v {-# INLINE wordStep #-} wordStep :: (Bits a, Num a) => Int -> (a -> Get a) -> a -> Get a wordStep shl k n = do tw <- fromIntegral <$> dWord8 let w = tw .&. 127 - let v = n .|. (w `shift` shl) + let v = n .|. w `shift` shl if tw == w then return v --else oneShot k v @@ -197,14 +207,14 @@ lastStep shl n = do tw <- fromIntegral <$> dWord8 let w = tw .&. 127 - let v = n .|. (w `shift` shl) + let v = n .|. w `shift` shl if tw == w then if countLeadingZeros w < shl then wordErr v else return v else wordErr v - where - wordErr v = fail $ concat ["Unexpected extra byte in unsigned integer", show v] + where + wordErr v = fail $ "Unexpected extra byte in unsigned integer" ++ show v -- {-# INLINE dUnsigned #-} dUnsigned :: (Num b, Bits b) => Get b @@ -223,7 +233,7 @@ dUnsigned_ shl n = do tw <- dWord8 let w = tw .&. 127 - let v = n .|. (fromIntegral w `shift` shl) + let v = n .|. fromIntegral w `shift` shl if tw == w then return (v, shl) else dUnsigned_ (shl + 7) v @@ -234,23 +244,28 @@ dUTF16 :: Get T.Text dUTF16 = do _ <- dFiller +#if MIN_VERSION_text(2,0,0) -- Checked decoding - -- T.decodeUtf16LE <$> dByteString_ + T.decodeUtf16LE <$> dByteString_ +#else -- Unchecked decoding (ByteArray array, lengthInBytes) <- dByteArray_ return (T.Text (TA.Array array) 0 (lengthInBytes `div` 2)) #endif +#endif + dUTF8 :: Get T.Text dUTF8 = do _ <- dFiller - T.decodeUtf8 <$> dByteString_ + bs <- dByteString_ + case T.decodeUtf8' bs of + Right t -> pure t + Left e -> fail $ "Input contains invalid UTF-8 data" ++ show e dFiller :: Get () dFiller = do tag <- dBool - case tag of - False -> dFiller - True -> return () + unless tag dFiller dLazyByteString :: Get L.ByteString dLazyByteString = dFiller >> dLazyByteString_ @@ -265,3 +280,7 @@ dByteString :: Get B.ByteString dByteString = dFiller >> dByteString_ + + + + diff --git a/src/Flat/Decoder/Types.hs b/src/Flat/Decoder/Types.hs --- a/src/Flat/Decoder/Types.hs +++ b/src/Flat/Decoder/Types.hs @@ -4,9 +4,8 @@ -- |Strict Decoder Types module Flat.Decoder.Types - ( strictDecoder - -- , strictDecoderPart - , Get(..) + ( + Get(..) , S(..) , GetResult(..) , Decoded @@ -14,61 +13,40 @@ , notEnoughSpace , tooMuchSpace , badEncoding + , badOp ) where -import Control.DeepSeq -import Control.Exception -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as BS -import Data.Word -import Foreign -import System.IO.Unsafe +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception, throwIO) +import Data.Word (Word8) +import Foreign (Ptr) + #if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail +import qualified Control.Monad.Fail as Fail #endif +{- | +A decoder. -strictDecoder :: Get a -> B.ByteString -> Either DecodeException a -strictDecoder get bs = - strictDecoder_ get bs $ \(GetResult s'@(S ptr' o') a) endPtr -> - if ptr' /= endPtr || o' /= 0 - then tooMuchSpace endPtr s' - else return a +Given: --- strictDecoderPart :: Get a -> B.ByteString -> Either DecodeException a --- strictDecoderPart get bs = --- strictDecoder_ get bs $ \(GetResult _ a) _ -> return a +* end of input buffer -strictDecoder_ :: - Exception e - => Get a1 - -> BS.ByteString - -> (GetResult a1 -> Ptr b -> IO a) - -> Either e a -strictDecoder_ get (BS.PS base off len) check = - unsafePerformIO . try $ - withForeignPtr base $ \base0 -> - let ptr = base0 `plusPtr` off - endPtr = ptr `plusPtr` len - in do res <- runGet get endPtr (S ptr 0) - check res endPtr +* current position in input buffer --- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits) --- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $ --- withForeignPtr base $ \base0 -> --- let ptr = base0 `plusPtr` off --- endPtr = ptr `plusPtr` len --- in do --- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0) --- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o') +Returns: +* decoded value --- |Decoder monad +* new position in input buffer +-} newtype Get a = Get - { runGet :: - Ptr Word8 -> S -> IO (GetResult a) - } -- deriving (Functor) + { runGet :: + Ptr Word8 + -> S + -> IO (GetResult a) + } -- Seems to give better performance than the derived version instance Functor Get where @@ -112,7 +90,6 @@ {-# INLINE (>>=) #-} #if !(MIN_VERSION_base(4,13,0)) fail = failGet - -- base < 4.13 #endif #if MIN_VERSION_base(4,9,0) @@ -143,6 +120,7 @@ = NotEnoughSpace Env | TooMuchSpace Env | BadEncoding Env String + | BadOp String deriving (Show, Eq, Ord) type Env = (Ptr Word8, S) @@ -155,5 +133,8 @@ badEncoding :: Ptr Word8 -> S -> String -> IO a badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr, s) msg + +badOp :: String -> IO a +badOp msg = throwIO $ BadOp msg instance Exception DecodeException diff --git a/src/Flat/Encoder.hs b/src/Flat/Encoder.hs --- a/src/Flat/Encoder.hs +++ b/src/Flat/Encoder.hs @@ -70,10 +70,10 @@ #endif ) where -import Flat.Encoder.Prim +import Flat.Encoder.Prim ( eTrueF, eFalseF ) import Flat.Encoder.Size(arrayBits) import Flat.Encoder.Strict -import Flat.Encoder.Types +import Flat.Encoder.Types ( NumBits, Size ) #if ! MIN_VERSION_base(4,11,0) import Data.Semigroup((<>)) diff --git a/src/Flat/Encoder/Prim.hs b/src/Flat/Encoder/Prim.hs --- a/src/Flat/Encoder/Prim.hs +++ b/src/Flat/Encoder/Prim.hs @@ -3,12 +3,12 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UnboxedTuples #-} -- |Encoding Primitives module Flat.Encoder.Prim - ( eBits16F + ( + -- Primitives whose name starts with 'e' encode a value in place + eBits16F , eBitsF , eFloatF , eDoubleF @@ -36,8 +36,12 @@ , eBoolF , eTrueF , eFalseF + , varWordF + + , updateWord8 , w7l + -- * Exported for testing only , eWord32BEF , eWord64BEF @@ -51,16 +55,20 @@ import qualified Data.ByteString.Lazy.Internal as L import qualified Data.ByteString.Short.Internal as SBS import Data.Char +import Data.FloatCast +import Data.Primitive.ByteArray +import qualified Data.Text as T import Flat.Encoder.Types import Flat.Endian import Flat.Memory import Flat.Types -import Data.FloatCast -import Data.Primitive.ByteArray -import qualified Data.Text as T -#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) + +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) && ! MIN_VERSION_text(2,0,0) import qualified Data.Text.Array as TA import qualified Data.Text.Internal as TI +-- import Data.FloatCast +-- import Data.Primitive.ByteArray +-- import qualified Data.Text as T #endif import qualified Data.Text.Encoding as TE import Data.ZigZag @@ -69,6 +77,14 @@ #include "MachDeps.h" -- traceShowId :: a -> a -- traceShowId = id + +-- $setup +-- >>> import Flat.Instances.Test +-- >>> import Flat.Bits +-- >>> import Flat.Encoder.Strict +-- >>> import Control.Monad +-- >>> let enc e = prettyShow $ encBits 256 (Encoding e) + {-# INLINE eFloatF #-} eFloatF :: Float -> Prim eFloatF = eWord32BEF . floatToWord @@ -93,6 +109,7 @@ eWordF :: Word -> Prim {-# INLINE eIntF #-} eIntF :: Int -> Prim + #if WORD_SIZE_IN_BITS == 64 eWordF = eWord64F . (fromIntegral :: Word -> Word64) @@ -104,6 +121,7 @@ #else #error expected WORD_SIZE_IN_BITS to be 32 or 64 #endif + {-# INLINE eInt8F #-} eInt8F :: Int8 -> Prim eInt8F = eWord8F . zigZag @@ -154,11 +172,16 @@ | o == 0 = foldM pokeWord' op vs >>= \op' -> return (S op' 0 0) | otherwise = foldM (flip eWord8F) s vs +{- +>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 0 s1 >>= \s2 -> eTrueF s2 +"10000000 01" +-} + {-# INLINE eWord8F #-} eWord8F :: Word8 -> Prim eWord8F t s@(S op _ o) | o == 0 = pokeWord op t - | otherwise = pokeByteUnaligned t s + | otherwise = eByteUnaligned t s {-# INLINE eWord32E #-} eWord32E :: (Word32 -> Word32) -> Word32 -> Prim @@ -191,8 +214,8 @@ {-# INLINE varWordF #-} varWordF :: (Bits t, Integral t) => t -> Prim varWordF t s@(S _ _ o) - | o == 0 = varWord pokeByteAligned t s - | otherwise = varWord pokeByteUnaligned t s + | o == 0 = varWord eByteAligned t s + | otherwise = varWord eByteUnaligned t s {-# INLINE varWord #-} varWord :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim @@ -229,20 +252,26 @@ low7 t = fromIntegral t .&. 0x7F -- | Encode text as UTF8 and encode the result as an array of bytes +-- -- PROB: encodeUtf8 calls a C primitive, not compatible with GHCJS (fixed in latest versions of GHCJS?) eUTF8F :: T.Text -> Prim eUTF8F = eBytesF . TE.encodeUtf8 --- PROB: Not compatible with GHCJS or ETA (that is big endian and writes contents in reverse order) -- | Encode text as UTF16 and encode the result as an array of bytes --- Efficient, as Text is already internally encoded as UTF16. +-- +-- PROB: Not compatible with GHCJS or ETA (that is big endian and writes contents in reverse order) #if ! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) + eUTF16F :: T.Text -> Prim +#if MIN_VERSION_text(2,0,0) +eUTF16F = eBytesF . TE.encodeUtf16LE +#else eUTF16F t = eFillerF >=> eUTF16F_ t where - eUTF16F_ !(TI.Text (TA.Array array) w16Off w16Len) s = + eUTF16F_ (TI.Text (TA.Array array) w16Off w16Len) s = writeArray array (2 * w16Off) (2 * w16Len) (nextPtr s) #endif +#endif -- |Encode a Lazy ByteString eLazyBytesF :: L.ByteString -> Prim @@ -257,10 +286,10 @@ {-# INLINE eShortBytesF #-} eShortBytesF :: SBS.ShortByteString -> Prim eShortBytesF bs = eFillerF >=> eShortBytesF_ bs - -eShortBytesF_ :: SBS.ShortByteString -> Prim -eShortBytesF_ bs@(SBS.SBS arr) = - \(S op _ 0) -> writeArray arr 0 (SBS.length bs) op + where + eShortBytesF_ :: SBS.ShortByteString -> Prim + eShortBytesF_ bs@(SBS.SBS arr) (S op _ 0) = writeArray arr 0 (SBS.length bs) op + eShortBytesF_ _ _ = error "impossible" -- data Array a = Array0 | Array1 a ... | Array255 ... writeArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO S @@ -329,8 +358,7 @@ -} -- {-# NOINLINE eBitsF_ #-} eBitsF_ :: NumBits -> Word8 -> Prim -eBitsF_ n t = - \(S op w o) -> +eBitsF_ n t (S op w o) = let o' = o + n -- used bits f = 8 - o' -- remaining free bits in if | f > 0 -> return $ S op (w .|. (t `unsafeShiftL` f)) o' @@ -345,18 +373,30 @@ eBoolF False = eFalseF eBoolF True = eTrueF +-- | >>> enc eTrueF +-- "1" {-# INLINE eTrueF #-} eTrueF :: Prim eTrueF (S op w o) | o == 7 = pokeWord op (w .|. 1) | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o + 1)) +-- | >>> enc eFalseF +-- "0" {-# INLINE eFalseF #-} eFalseF :: Prim eFalseF (S op w o) | o == 7 = pokeWord op w | otherwise = return (S op w (o + 1)) +{- | + +>>> enc $ eTrueF >=> eFillerF +"10000001" + +>>> enc eFillerF +"00000001" +-} {-# INLINE eFillerF #-} eFillerF :: Prim eFillerF (S op w _) = pokeWord op (w .|. 1) @@ -365,15 +405,87 @@ -- TODO TEST -- poke16 :: Word16 -> Prim -- poke16 t (S op w o) | o == 0 = poke op w >> skipBytes op 2 -{-# INLINE pokeByteUnaligned #-} -pokeByteUnaligned :: Word8 -> Prim -pokeByteUnaligned t (S op w o) = +{- +To be used only when usedBits /= 0 + +>>> enc (eFalseF >=> eFalseF >=> eByteUnaligned 255) +"00111111 11" +-} +{-# INLINE eByteUnaligned #-} +eByteUnaligned :: Word8 -> Prim +eByteUnaligned t (S op w o) = poke op (w .|. (t `unsafeShiftR` o)) >> return (S (plusPtr op 1) (t `unsafeShiftL` (8 - o)) o) -{-# INLINE pokeByteAligned #-} -pokeByteAligned :: Word8 -> Prim -pokeByteAligned t (S op _ _) = pokeWord op t +{- To be used only when usedBits = 0 + +>>> enc (eFalseF >=> eFalseF >=> eFalseF >=> eByteAligned 255) +"11111111" +-} +{-# INLINE eByteAligned #-} +eByteAligned :: Word8 -> Prim +eByteAligned t (S op _ _) = pokeWord op t + +{-| +>>> enc $ \s-> eWord8F 0 s >>= updateWord8 255 s +"11111111" + +>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eWord8F 255 >>= updateWord8 0 s1 +"10000000 01111111 1" + +>>> enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 +"01111111 1" + +>>> enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 >>= eFalseF +"01111111 10" + +>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eTrueF >>= updateWord8 0 s1 >>= eTrueF +"10000000 011" + +@since 0.5 +-} +updateWord8 :: Word8 -> S -> Prim +updateWord8 t mem s = do + uncache s + pokeWord8 t mem + cache s + +uncache :: S -> IO () +uncache s = poke (nextPtr s) (currByte s) + +cache :: Prim +cache s = do + w <- (mask s .&.) <$> peek (nextPtr s) + return $ s {currByte = w} + +mask :: S -> Word8 +mask s = 255 `unsafeShiftL` (8 - usedBits s) + +{-# INLINE pokeWord8 #-} +pokeWord8 :: Word8 -> S -> IO () +pokeWord8 t (S op _ 0) = poke op t +pokeWord8 t (S op w o) = do + poke op (w .|. (t `unsafeShiftR` o)) + let op' :: Ptr Word8 = plusPtr op 1 + v :: Word8 <- peek op' + poke op' (t `unsafeShiftL` (8 - o) .|. ((v `unsafeShiftL` o) `unsafeShiftR` o)) + +-- | o == 0 = pokeByteAligned t s +-- | otherwise = pokeByteUnaligned t s +-- where +-- {-# INLINE pokeByteUnaligned #-} +-- pokeByteUnaligned :: Word8 -> S -> IO () +-- pokeByteUnaligned t (S op w o) = do +-- let op' = plusPtr op 1 +-- poke op (w .|. (t `unsafeShiftR` o)) +-- v :: Word8 <- peek op' +-- poke op' (t `unsafeShiftL` (8 - o) .|. ((v `unsafeShiftL` o) `unsafeShiftR` o)) + +-- {-# INLINE pokeByteAligned #-} +-- pokeByteAligned :: Word8 -> S -> IO () +-- pokeByteAligned t (S op _ _) = poke op t + +-- FIX: not really pokes {-# INLINE pokeWord #-} pokeWord :: Storable a => Ptr a -> a -> IO S diff --git a/src/Flat/Encoder/Size.hs b/src/Flat/Encoder/Size.hs --- a/src/Flat/Encoder/Size.hs +++ b/src/Flat/Encoder/Size.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} --- |Primitives to calculate the encoding size of a value +-- |Primitives to calculate the maximum size in bits of the encoding of a value module Flat.Encoder.Size where -import Data.Bits +import Data.Bits (Bits) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Short.Internal as SBS -import Data.Char -import Flat.Encoder.Prim (w7l) -import Flat.Encoder.Types -import Flat.Types +import Data.Char (ord) import qualified Data.Text as T +import Flat.Encoder.Prim (w7l) +import Flat.Types (Int16, Int32, Int64, Natural, + NumBits, Text, Word16, Word32, + Word64) #ifndef ghcjs_HOST_OS import qualified Data.Text.Internal as TI #endif @@ -119,7 +119,7 @@ --sUTF8 :: T.Text -> NumBits --sUTF8 t = fold --- Wildly pessimistic but fast +-- TOFIX: Wildly pessimistic and also slow as T.length is O(n) {-# INLINE sUTF8Max #-} sUTF8Max :: Text -> NumBits sUTF8Max = blobBits . (4 *) . T.length @@ -149,7 +149,7 @@ -- 4 {-# INLINE textBytes #-} textBytes :: T.Text -> Int -textBytes !(TI.Text _ _ w16Len) = w16Len * 2 +textBytes (TI.Text _ _ w16Len) = w16Len * 2 #endif {-# INLINE bitsToBytes #-} diff --git a/src/Flat/Encoder/Strict.hs b/src/Flat/Encoder/Strict.hs --- a/src/Flat/Encoder/Strict.hs +++ b/src/Flat/Encoder/Strict.hs @@ -1,30 +1,32 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- |Strict encoder module Flat.Encoder.Strict where -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L +import Control.Monad (when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Foldable import Flat.Encoder.Prim -import qualified Flat.Encoder.Size as S +import qualified Flat.Encoder.Size as S import Flat.Encoder.Types import Flat.Memory import Flat.Types -import Data.Foldable -- import Data.Semigroup -- import Data.Semigroup (Semigroup (..)) #if !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup (..)) +import Data.Semigroup (Semigroup (..)) #endif #ifdef ETA_VERSION -- import Data.Function(trampoline) -import GHC.IO (trampolineIO) +import GHC.IO (trampolineIO) trampolineEncoding :: Encoding -> Encoding trampolineEncoding (Encoding op) = Encoding (\s -> trampolineIO (op s)) #else @@ -34,13 +36,28 @@ -- |Strict encoder strictEncoder :: NumBits -> Encoding -> B.ByteString -strictEncoder numBits (Encoding op) = - let bufSize = S.bitsToBytes numBits - in fst $ - unsafeCreateUptoN' bufSize $ \ptr -> do - (S ptr' 0 0) <- op (S ptr 0 0) - return (ptr' `minusPtr` ptr, ()) +strictEncoder numBits enc = + let (bs,numBitsUsed) = strictEncoderPartial numBits enc + bitsInLastByte = numBitsUsed `mod` 8 + in if bitsInLastByte /=0 + then error $ unwords ["encoder: did not end on byte boundary, bits used in last byte=",show bitsInLastByte] + else bs +numEncodedBits :: Int -> Encoding -> NumBits +numEncodedBits numBits enc =snd $ strictEncoderPartial numBits enc + +strictEncoderPartial :: + Int -- ^ the maximum size in bits of the encoding + -> Encoding -- ^ the encoder + -> (B.ByteString, NumBits) -- ^ the encoded bytestring + the actual number of encoded bits +strictEncoderPartial numBits (Encoding op) + = let bufSize = S.bitsToBytes numBits + in unsafeCreateUptoN' bufSize $ \ptr -> do + S{..} <- op (S ptr 0 0) + let numBitsUsed = nextPtr `minusPtr` ptr * 8 + usedBits + when (numBitsUsed > numBits) $ error $ unwords ["encoder: size mismatch, expected <=",show numBits,"actual=",show numBitsUsed,"bits"] + return (nextPtr `minusPtr` ptr,numBitsUsed) + newtype Encoding = Encoding { run :: Prim @@ -51,20 +68,27 @@ instance Semigroup Encoding where {-# INLINE (<>) #-} - (<>) = mappend + (<>) = encodingAppend instance Monoid Encoding where {-# INLINE mempty #-} mempty = Encoding return + +#if !(MIN_VERSION_base(4,11,0)) {-# INLINE mappend #-} - -- mappend (Encoding f) (Encoding g) = Encoding (f >=> g) - mappend (Encoding f) (Encoding g) = Encoding m + mappend = encodingAppend +#endif + + {-# INLINE mconcat #-} + mconcat = foldl' mappend mempty + +{-# INLINE encodingAppend #-} +encodingAppend :: Encoding -> Encoding -> Encoding +encodingAppend (Encoding f) (Encoding g) = Encoding m where m s@(S !_ !_ !_) = do !s1 <- f s g s1 - {-# INLINE mconcat #-} - mconcat = foldl' mappend mempty -- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists) -- TODO: check with newest GHC versions @@ -76,9 +100,13 @@ {-# NOINLINE encodersS #-} encodersS :: [Encoding] -> Encoding --- without the explicit parameter the rules won't fire +-- Without the explicit parameter the rules won't fire! encodersS ws = foldl' mappend mempty ws +sizeListWith :: (Foldable t1, Num t2) => (t3 -> t2 -> t2) -> t1 t3 -> t2 -> t2 +sizeListWith size l sz = foldl' (\s e -> size e (s + 1)) (sz + 1) l +{-# INLINE sizeListWith #-} + -- encodersS ws = error $ unwords ["encodersS CALLED",show ws] {-# INLINE encodeListWith #-} -- |Encode as a List @@ -87,7 +115,7 @@ where go [] = eFalse go (x:xs) = eTrue <> enc x <> go xs - + -- {-# INLINE encodeList #-} -- encodeList :: (Foldable t, Flat a) => t a -> Encoding -- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse @@ -101,12 +129,15 @@ encodeArrayWith f ws = Encoding $ go ws where go l s = do + -- write a placeholder for the number of elements in current block s' <- eWord8F 0 s - (n, s'', l) <- gol l 0 s' - _ <- eWord8F n s + (n, sn, l) <- gol l 0 s' + -- update actual number of elements + s'' <- updateWord8 n s sn if null l then eWord8F 0 s'' else go l s'' + -- encode up to 255 elements and returns (numberOfWrittenElements,elementsLeftToWrite,currentState) gol [] !n !s = return (n, s, []) gol l@(x:xs) !n !s | n == 255 = return (255, s, l) diff --git a/src/Flat/Encoder/Types.hs b/src/Flat/Encoder/Types.hs --- a/src/Flat/Encoder/Types.hs +++ b/src/Flat/Encoder/Types.hs @@ -9,7 +9,7 @@ import Flat.Types import GHC.Ptr (Ptr (..)) --- |Calculate the size (in bits) of the encoding of a value +-- |Add the maximum size in bits of the encoding of value a to a NumBits type Size a = a -> NumBits -> NumBits -- |Strict encoder state diff --git a/src/Flat/Endian.hs b/src/Flat/Endian.hs --- a/src/Flat/Endian.hs +++ b/src/Flat/Endian.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} -- | Endian utilities +-- -- Exported for testing purposes, but not meant to be used outside this package. module Flat.Endian ( @@ -12,7 +13,8 @@ #include "MachDeps.h" -import Data.Word +import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, + byteSwap64) -- #ifdef ghcjs_HOST_OS -- import Data.Bits diff --git a/src/Flat/Filler.hs b/src/Flat/Filler.hs --- a/src/Flat/Filler.hs +++ b/src/Flat/Filler.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} -- |Pre-value and post-value byte alignments module Flat.Filler ( @@ -11,18 +11,20 @@ preAligned, PostAligned(..), postAligned, + preAlignedDecoder, postAlignedDecoder ) where -import Flat.Class -import Flat.Encoder -import Flat.Decoder -import Control.DeepSeq -import Data.Typeable +import Flat.Class ( Generic, Flat(..) ) +import Flat.Encoder.Strict ( eFiller, sFillerMax ) +import Flat.Decoder.Types ( Get ) +import Control.DeepSeq ( NFData ) +import Data.Typeable ( Typeable ) -- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse) --- Useful to align an encoded value at byte/word boundaries. -data Filler = FillerBit Filler +-- +-- Used to align encoded values at byte/word boundaries. +data Filler = FillerBit !Filler | FillerEnd deriving (Show, Eq, Ord, Typeable, Generic, NFData) @@ -33,6 +35,7 @@ -- use generated decode -- |A Post aligned value, a value followed by a filler +-- -- Useful to complete the encoding of a top-level value data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler } #ifdef ETA_VERSION @@ -48,6 +51,7 @@ -- |A Pre aligned value, a value preceded by a filler +-- -- Useful to prealign ByteArrays, Texts and any structure that can be encoded more efficiently when byte aligned. data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a } deriving (Show, Eq, Ord, Typeable, Generic, NFData, Flat) @@ -65,11 +69,17 @@ preAligned :: a -> PreAligned a preAligned = PreAligned FillerEnd --- postAlignedDecoder :: Get a -> Get (PostAligned a) -- |Decode a value assuming that is PostAligned postAlignedDecoder :: Get b -> Get b postAlignedDecoder dec = do v <- dec _::Filler <- decode - -- return (postAligned v) return v + +-- |Decode a value assuming that is PreAligned +-- +-- @since 0.5 +preAlignedDecoder :: Get b -> Get b +preAlignedDecoder dec = do + _::Filler <- decode + dec diff --git a/src/Flat/Instances/Base.hs b/src/Flat/Instances/Base.hs --- a/src/Flat/Instances/Base.hs +++ b/src/Flat/Instances/Base.hs @@ -1,44 +1,48 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances ,StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} + -- | Flat instances for the base library -module Flat.Instances.Base() where +module Flat.Instances.Base () where -import Data.Bool -import Data.Char -import Data.Fixed -import Flat.Instances.Util -import Data.Complex(Complex(..)) -import Data.Ratio -import Prelude hiding ( mempty ) -import Control.Monad ( liftM2 ) +import Control.Monad (liftM2) +import Data.Bool +import Data.Char +import Data.Complex (Complex (..)) +import Data.Fixed -- #if MIN_VERSION_base(4,9,0) -import qualified Data.List.NonEmpty as B +import qualified Data.List.NonEmpty as B -- #endif #if ! MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid (mempty) +import Control.Applicative +import Data.Monoid (mempty) #endif #if MIN_VERSION_base(4,9,0) -import qualified Data.Semigroup as Semigroup +import qualified Data.Semigroup as Semigroup #endif -import qualified Data.Monoid as Monoid +import qualified Data.Monoid as Monoid +import Data.Ratio +import Flat.Instances.Util +import Prelude hiding (mempty) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif +-- #if !MIN_VERSION_base(4,9,0) +-- import Data.Monoid ((<>)) +-- #endif -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity (..)) +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Identity (Identity (..)) #endif -#if !MIN_VERSION_base(4,9,0) -deriving instance Generic (Complex a) -#endif +-- #if !MIN_VERSION_base(4,9,0) +-- deriving instance Generic (Complex a) +-- #endif +{- ORMOLU_DISABLE -} -- $setup -- >>> :set -XNegativeLiterals -- >>> import Flat.Instances.Test @@ -52,8 +56,35 @@ -- >>> import Data.Monoid -- >>> import qualified Data.List.NonEmpty as B -- >>> let test = tstBits +-- >>> let y = 33 +{- ORMOLU_ENABLE -} +-- >>> y + +-- | @since 0.4.4 #if MIN_VERSION_base(4,8,0) +instance Flat Monoid.All where + encode (Monoid.All a) = encode a + size (Monoid.All a) = size a + decode = Monoid.All <$> decode + +{- | + +>>> let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w +True + +>>> let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w +True + +@since 0.4.4 +-} +instance Flat (f a) => Flat (Monoid.Alt f a) where + encode (Monoid.Alt a) = encode a + size (Monoid.Alt a) = size a + decode = Monoid.Alt <$> decode +#endif + +#if MIN_VERSION_base(4,9,0) -- | @since 0.4.4 instance Flat a => Flat (Identity a) where encode (Identity a) = encode a @@ -68,12 +99,6 @@ decode = Monoid.Dual <$> decode -- | @since 0.4.4 -instance Flat Monoid.All where - encode (Monoid.All a) = encode a - size (Monoid.All a) = size a - decode = Monoid.All <$> decode - --- | @since 0.4.4 instance Flat Monoid.Any where encode (Monoid.Any a) = encode a size (Monoid.Any a) = size a @@ -92,20 +117,6 @@ decode = Monoid.Product <$> decode #if MIN_VERSION_base(4,9,0) -{- | ->>> let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w -True - ->>> let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w -True - -@since 0.4.4 --} -instance Flat (f a) => Flat (Monoid.Alt f a) where - encode (Monoid.Alt a) = encode a - size (Monoid.Alt a) = size a - decode = Monoid.Alt <$> decode - -- | @since 0.4.4 instance Flat a => Flat (Semigroup.Min a) where encode (Semigroup.Min a) = encode a @@ -129,12 +140,6 @@ encode (Semigroup.Last a) = encode a size (Semigroup.Last a) = size a decode = Semigroup.Last <$> decode - --- | @since 0.4.4 -instance Flat a => Flat (Semigroup.Option a) where - encode (Semigroup.Option a) = encode a - size (Semigroup.Option a) = size a - decode = Semigroup.Option <$> decode #endif {- | @@ -150,7 +155,7 @@ decode = pure () -{-| +{- | One bit is plenty for a Bool. >>> test False @@ -166,10 +171,10 @@ decode = dBool -{-| +{- | Char's are mapped to Word32 and then encoded. -For ascii characters, the encoding is standard ascii. +For ascii characters, the encoding is standard ascii. >>> test 'a' (True,8,"01100001") @@ -203,16 +208,16 @@ -} instance Flat a => Flat (Maybe a) -{-| +{- | >>> test (Left False::Either Bool ()) (True,2,"00") >>> test (Right ()::Either Bool ()) (True,1,"1") -} -instance ( Flat a, Flat b ) => Flat (Either a b) +instance (Flat a, Flat b) => Flat (Either a b) -{-| +{- | >>> test (MkFixed 123 :: Fixed E0) (True,16,"11110110 00000001") @@ -272,11 +277,11 @@ | V127 @ -Values between as 0 and 127 fit in a single byte. +Values between as 0 and 127 fit in a single byte. 127 (0b1111111) is represented as Elem V127 and encoded as: Elem=0 127=1111111 ->>> test (127::Word) +>>> test (127::Word) (True,8,"01111111") 254 (0b11111110) is represented as Cons V126 (Elem V1) (254=128+126) and encoded as: Cons=1 V126=1111110 (Elem=0 V1=0000001): @@ -302,7 +307,7 @@ decode = dWord {- | -Naturals are encoded just as the fixed size Words. +Naturals are encoded just as the fixed size Words. >>> test (0::Natural) (True,8,"00000000") @@ -317,7 +322,6 @@ decode = dNatural - instance Flat Word16 where encode = eWord16 @@ -339,7 +343,6 @@ size = sWord64 - {- | Integer, Int, Int16, Int32 and Int64 are defined as the encoded version of the equivalent unsigned Word: @@ -382,7 +385,7 @@ decode = dInt {- | -Integers are encoded just as the fixed size Ints. +Integers are encoded just as the fixed size Ints. >>> test (0::Integer) (True,8,"00000000") @@ -412,7 +415,7 @@ decode = dInteger -{-| +{- | >>> test (0::Int8) (True,8,"00000000") @@ -490,7 +493,6 @@ decode = dInt64 - {- | Floats are encoded as standard IEEE binary32 values: @@ -532,35 +534,44 @@ decode = dDouble -{-| +{- | >>> test (4 :+ 2 :: Complex Word8) (True,16,"00000100 00000010") -} instance Flat a => Flat (Complex a) -{-| +{- | Ratios are encoded as tuples of (numerator,denominator) >>> test (3%4::Ratio Word8) (True,16,"00000011 00000100") -} -instance ( Integral a, Flat a ) => Flat (Ratio a) where - size a = size ( numerator a, denominator a ) +instance (Integral a, Flat a) => Flat (Ratio a) where + size a = size (numerator a, denominator a) - encode a = encode ( numerator a, denominator a ) + encode a = encode (numerator a, denominator a) -- decode = uncurry (%) <$> decode decode = liftM2 (%) decode decode -{-| +{- | >>> test ([]::[Bool]) (True,1,"0") >>> test [False,False] (True,5,"10100") + +This instance and other similar ones are declared as @OVERLAPPABLE@, because for better encoding/decoding +performance it can be useful to declare instances of concrete types, such as @[Char]@ (not provided out of the box). -} -instance {-# OVERLAPPABLE #-}Flat a => Flat [ a ] +instance {-# OVERLAPPABLE #-} Flat a => Flat [a] +{- +>>> import Weigh +>>> flat [1..10::Int] +-} + + -- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901) -- where --size [] n = n+1 @@ -578,27 +589,17 @@ -- trampolineIO = id -- #endif -{- | -For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char]. - ->>> test "" -(True,1,"0") - ->>> test "aaa" -(True,28,"10110000 11011000 01101100 0010") --} -instance {-# OVERLAPPING #-}Flat [ Char ] - - -- #if MIN_VERSION_base(4,9,0) -{-| + +{- | >>> test (B.fromList [True]) (True,2,"10") >>> test (B.fromList [False,False]) (True,4,"0100") -} -instance {-# OVERLAPPABLE #-}Flat a => Flat (B.NonEmpty a) +instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a) + -- #endif {- | @@ -620,26 +621,33 @@ -} -- Not sure if these should be OVERLAPPABLE -instance {-# OVERLAPPABLE #-}( Flat a, Flat b ) => Flat ( a, b ) - -instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c ) => Flat ( a, b, c ) - -instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c, Flat d ) - => Flat ( a, b, c, d ) +instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b) -instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c, Flat d, Flat e ) - => Flat ( a, b, c, d, e ) +instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a, b, c) -instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c, Flat d, Flat e, Flat f ) - => Flat ( a, b, c, d, e, f ) +instance + {-# OVERLAPPABLE #-} + (Flat a, Flat b, Flat c, Flat d) => + Flat (a, b, c, d) -instance {-# OVERLAPPABLE #-}( Flat a - , Flat b - , Flat c - , Flat d - , Flat e - , Flat f - , Flat g - ) => Flat ( a, b, c, d, e, f, g ) +instance + {-# OVERLAPPABLE #-} + (Flat a, Flat b, Flat c, Flat d, Flat e) => + Flat (a, b, c, d, e) +instance + {-# OVERLAPPABLE #-} + (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) => + Flat (a, b, c, d, e, f) +instance + {-# OVERLAPPABLE #-} + ( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + ) => + Flat (a, b, c, d, e, f, g) diff --git a/src/Flat/Instances/DList.hs b/src/Flat/Instances/DList.hs --- a/src/Flat/Instances/DList.hs +++ b/src/Flat/Instances/DList.hs @@ -2,9 +2,9 @@ () where -import Flat.Class -import Flat.Instances.Mono -import Data.DList +import Data.DList (DList, fromList, toList) +import Flat.Class (Flat (..)) +import Flat.Instances.Mono (decodeList, encodeList, sizeList) -- $setup -- >>> import Flat.Instances.Test diff --git a/src/Flat/Instances/Extra.hs b/src/Flat/Instances/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Extra.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances #-} +module Flat.Instances.Extra where + +import Flat.Instances.Base () +import Flat.Class ( Flat ) + +-- $setup +-- >>> import Flat.Instances.Test + +{- | +For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char]. + +>>> tstBits "" +(True,1,"0") + +>>> tstBits "aaa" +(True,28,"10110000 11011000 01101100 0010") +-} +instance {-# OVERLAPPING #-} Flat [Char] + diff --git a/src/Flat/Instances/Mono.hs b/src/Flat/Instances/Mono.hs --- a/src/Flat/Instances/Mono.hs +++ b/src/Flat/Instances/Mono.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances,UndecidableInstances ,NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE UndecidableInstances #-} module Flat.Instances.Mono ( sizeSequence , encodeSequence @@ -20,24 +22,20 @@ ) where -import Data.MonoTraversable ( Element - , ofoldl' - , otoList - --, olength - , MonoFoldable - ) -import Data.Sequences ( IsSequence ) -import qualified Data.Sequences as S import Data.Containers +import qualified Data.Foldable as F +import Data.MonoTraversable (Element, MonoFoldable, ofoldl', otoList) +import Data.Sequences (IsSequence) +import qualified Data.Sequences as S import Flat.Instances.Util -import qualified Data.Foldable as F --- $setup --- >>> import Flat.Instances.Base() --- >>> import Flat.Instances.Test --- >>> import Data.Word --- >>> import qualified Data.Set --- >>> import qualified Data.Map +{- $setup +>>> import Flat.Instances.Base() +>>> import Flat.Instances.Test +>>> import Data.Word +>>> import qualified Data.Set +>>> import qualified Data.Map +-} {-| Sequences are defined as Arrays: @@ -55,23 +53,55 @@ List a ≡ Nil | Cons a (List a) -The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays +In practice, this means that the list elements will be prefixed with a 1 bit and followed by a final 0 bit. ->>> tst $ AsArray ([]::[()]) -(True,8,[0]) +The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays. ->>> tst $ AsArray [11::Word8,22,33] -(True,40,[3,11,22,33,0]) +Let's see some examples. ->>> tst $ AsList ([]::[()]) -(True,1,[0]) +>>> flatBits $ AsList [True,True,True] +"1111110" +So we have Cons True (11) repeated three times, followed by a final Nil (0). + +The list encoding is the default one for lists so AsList is in this case unnecessary: + +>>> flatBits $ [True,True,True] +"1111110" + +We can force a list to be encoded as an Array with AsArray: + +>>> flatBits $ AsArray [True,True,True] +"00000011 11100000 000" + +We have the initial block with a count of 3 (3 == 00000011) followed by the elements True True True (111) and then the final block of 0 elements ("00000 000"). + +>>> flatBits $ [AsArray [True,True,True]] +"10000001 11110000 00000" + +>>> flatBits $ (True,True,True,AsArray $ replicate 7 True) +"11100000 11111111 11000000 00" + +>>> flatBits $ AsArray ([]::[()]) +"00000000" + +>>> flatBits $ AsList ([]::[()]) +"0" + >>> tst (AsList [11::Word8,22,33]) (True,28,[133,197,164,32]) >>> tst (AsSet (Data.Set.fromList [11::Word8,22,33])) (True,28,[133,197,164,32]) +>>> tst [AsArray [1..3], AsArray [4..8]] +(True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0]) + +>>> tst $ [AsArray [(1::Word8)..3], AsArray [4..8]] +(True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0]) + +>>> tst $ [AsArray [(1::Int)..3]] +(True,42,[129,129,2,3,0,0]) -} newtype AsArray a = AsArray @@ -83,9 +113,13 @@ encode (AsArray a) = encodeSequence a decode = AsArray <$> decodeSequence --- |Calculate size of an instance of IsSequence as the sum: --- * of the size of all the elements --- * plus the size of the array constructors (1 byte every 255 elements plus one final byte) +{- | +Calculate size of an instance of IsSequence as the sum: + +* of the size of all the elements + +* plus the size of the array constructors (1 byte every 255 elements plus one final byte) +-} sizeSequence :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits sizeSequence s acc = @@ -145,7 +179,7 @@ decode = AsSet <$> decodeSet sizeSet :: (IsSet set, Flat (Element set)) => Size set -sizeSet l acc = ofoldl' (\acc e -> size e (acc + 1)) (acc + 1) $ l +sizeSet l acc = ofoldl' (\acc e -> size e (acc + 1)) (acc + 1) l {-# INLINE sizeSet #-} encodeSet :: (IsSet set, Flat (Element set)) => set -> Encoding diff --git a/src/Flat/Instances/Test.hs b/src/Flat/Instances/Test.hs --- a/src/Flat/Instances/Test.hs +++ b/src/Flat/Instances/Test.hs @@ -1,36 +1,36 @@ -- | doctest utilities -module Flat.Instances.Test - ( tst - , tstBits - , asList - , flatBits - , allBits - , prettyShow - , module Data.Word - ) -where +module Flat.Instances.Test ( + tst, + tstBits, + asList, + flatBits, + allBits, + encBits, + prettyShow, + module Data.Word, +) where -import Flat.Class ( Flat(..) ) -import Flat.Run ( flat - , unflat - ) -import Flat.Bits ( bits - , asBytes - , paddedBits - ) -import Flat.Types ( NumBits ) +import Control.Monad ((>=>)) import Data.Word -import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import Flat.Bits (Bits, asBytes, bits, + paddedBits, takeBits) +import Flat.Class (Flat (..)) +import Flat.Encoder.Prim (eFillerF) +import Flat.Encoder.Strict (Encoding (Encoding), + numEncodedBits, strictEncoder) +import Flat.Run (flat, unflat) +import Flat.Types (NumBits) +import Text.PrettyPrint.HughesPJClass (prettyShow) --- |Returns: result of flat/unflat test, encoding size in bits, byte encoding +-- | Returns: result of flat/unflat test, encoding size in bits, byte encoding tst :: (Eq a, Flat a) => a -> (Bool, NumBits, [Word8]) tst v = (unflat (flat v) == Right v, size v 0, showBytes v) --- |Returns: result of flat/unflat test, encoding size in bits, bits encoding +-- | Returns: result of flat/unflat test, encoding size in bits, bits encoding tstBits :: (Eq a, Flat a) => a -> (Bool, NumBits, String) tstBits v = (unflat (flat v) == Right v, Flat.Class.size v 0, flatBits v) --- |Test that container is serialised as a List +-- | Test that container is serialised as a List asList :: (Eq a1, Eq a2, Flat a1, Flat a2) => (a2 -> a1) -> a2 -> Bool asList f l = tst (f l) == tst l @@ -39,6 +39,10 @@ allBits :: Flat a => a -> String allBits = prettyShow . paddedBits + +-- |@since 0.5 +encBits :: NumBits -> Encoding -> Bits +encBits maxNumBits e@(Encoding enc) = takeBits (numEncodedBits maxNumBits e) (strictEncoder maxNumBits (Encoding $ enc >=> eFillerF)) showBytes :: Flat a => a -> [Word8] showBytes = asBytes . bits diff --git a/src/Flat/Instances/Text.hs b/src/Flat/Instances/Text.hs --- a/src/Flat/Instances/Text.hs +++ b/src/Flat/Instances/Text.hs @@ -39,7 +39,7 @@ (True,120,[1,12,240,144,141,136,240,144,141,136,240,144,141,136,0]) #endif -Strict and Lazy Text has the same encoding: +Strict and Lazy Text have the same encoding: >>> tst (T.pack "abc") == tst (TL.pack "abc") True diff --git a/src/Flat/Memory.hs b/src/Flat/Memory.hs --- a/src/Flat/Memory.hs +++ b/src/Flat/Memory.hs @@ -5,7 +5,7 @@ {- | Memory access primitives. -Includes code from the store-core package. +Includes code from the [store-core](https://hackage.haskell.org/package/store-core) package. -} module Flat.Memory ( chunksToByteString @@ -15,10 +15,11 @@ , pokeByteString , unsafeCreateUptoN' , minusPtr + --, peekByteString ) where -import Control.Monad +import Control.Monad ( foldM_, when ) import Control.Monad.Primitive ( PrimMonad(..) ) import qualified Data.ByteString.Internal as BS import Data.Primitive.ByteArray ( MutableByteArray(..) @@ -27,7 +28,7 @@ , newByteArray , unsafeFreezeByteArray ) -import Foreign hiding ( void ) +import Foreign ( Word8, Ptr, withForeignPtr, minusPtr, plusPtr ) import GHC.Prim ( copyAddrToByteArray# , copyByteArrayToAddr# ) @@ -35,7 +36,7 @@ import GHC.Types ( IO(..) , Int(..) ) -import System.IO.Unsafe +import System.IO.Unsafe ( unsafeDupablePerformIO, unsafePerformIO ) import qualified Data.ByteString as B unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a) @@ -64,6 +65,11 @@ sourceLength return (destPointer `plusPtr` sourceLength) +-- Create a new bytestring, copying from sourcePtr sourceLength number of bytes +-- peekByteString :: Ptr Word8 -> Int -> BS.ByteString +-- peekByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength + +-- |Copy ByteArray to given pointer, returns new pointer pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8) pokeByteArray sourceArr sourceOffset len dest = do copyByteArrayToAddr sourceArr sourceOffset dest len @@ -71,19 +77,18 @@ return dest' {-# INLINE pokeByteArray #-} + -- | Wrapper around @copyByteArrayToAddr#@ primop. +-- -- Copied from the store-core package copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) = IO (\s -> (# copyByteArrayToAddr# arr offset addr len s, () #)) {-# INLINE copyByteArrayToAddr #-} --- toByteString :: Ptr Word8 -> Int -> BS.ByteString --- toByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength - chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString chunksToByteString (sourcePtr0, lens) = - BS.unsafeCreate (sum lens) $ \destPtr0 -> void $ foldM + BS.unsafeCreate (sum lens) $ \destPtr0 -> foldM_ (\(destPtr, sourcePtr) sourceLength -> BS.memcpy destPtr sourcePtr sourceLength >> return @@ -110,6 +115,7 @@ -- | Wrapper around @copyAddrToByteArray#@ primop. +-- -- Copied from the store-core package copyAddrToByteArray :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () diff --git a/src/Flat/Repr.hs b/src/Flat/Repr.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Repr.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Flat.Repr where + +import qualified Data.ByteString as B +import Flat.Class (Flat (..)) +import Flat.Decoder.Types (Get) +import Flat.Run (flat, unflat) + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> import Flat.Instances.Base +-- >>> import Flat.Decoder.Types +-- >>> import Flat.Types +-- >>> import Flat.Run +-- >>> import Flat.Class + +{- | Flat representation of a value + +== Repr +It is occasionally useful to keep a decoded value, or part of it, in its encoded binary representation and decode it later on demand. + +To do so, just decode a value `a` to a `Repr a`. + +For example, we encode a list of Ints and then decode it to a list of Repr Int: + +>>> unflat (flat [1::Int .. 5]) :: Decoded ([Repr Int]) +Right [Repr {repr = "\STX\SOH"},Repr {repr = "\EOT\SOH"},Repr {repr = "\ACK\SOH"},Repr {repr = "\b\SOH"},Repr {repr = "\n\SOH"}] + +To decode a `Repr a` to an `a`, we use `unrepr`: + +>>> let Right l = unflat (flat [1..5]) :: Decoded [Repr Int] in unrepr (l !! 2) +3 + +See "test/FlatRepr.hs" for a test and a longer example of use. + +== SizeOf +If a decoded value is not required, it can be skipped completely using `SizeOf a`. + +For example, to ignore the second and fourth component of the following tuple, it can be decoded as: + +>>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,SizeOf String,Char,SizeOf Bool) +Right ('a',SizeOf 28,'z',SizeOf 1) + +The unused values have not been decoded and instead their size (in bits) is returned. +-} + +newtype Repr a = Repr {repr :: B.ByteString} deriving Show + +-- Get the underlying value +unrepr :: Flat a => Repr a -> a +unrepr (Repr bs)= + case unflat bs of + Right a -> a + Left _ -> error "impossible" + +instance Flat a => Flat (Repr a) where + size = error "unused" + encode = error "unused" + + -- To create the representation we just re 'flat' the parsed value (this could be optimised by copying directly the parsed representation) + decode = Repr . flat <$> (decode :: Get a) diff --git a/src/Flat/Run.hs b/src/Flat/Run.hs --- a/src/Flat/Run.hs +++ b/src/Flat/Run.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + -- |Encoding and decoding functions module Flat.Run ( flat, @@ -10,21 +11,21 @@ unflatWith, unflatRaw, unflatRawWith, - ) where +) where -import qualified Data.ByteString as B -import Data.ByteString.Convert -import Flat.Class -import Flat.Decoder -import qualified Flat.Encoder as E -import Flat.Filler +import qualified Data.ByteString as B +import Data.ByteString.Convert (AsByteString (..)) +import Flat.Class (Flat (decode, encode), getSize) +import Flat.Decoder (Decoded, Get, strictDecoder) +import qualified Flat.Encoder as E +import Flat.Filler (postAligned, postAlignedDecoder) -- |Encode padded value. flat :: Flat a => a -> B.ByteString flat = flatRaw . postAligned -- |Decode padded value. -unflat :: (Flat a,AsByteString b) => b -> Decoded a +unflat :: (Flat a, AsByteString b) => b -> Decoded a unflat = unflatWith decode -- |Decode padded value, using the provided unpadded decoder. @@ -32,7 +33,7 @@ unflatWith dec = unflatRawWith (postAlignedDecoder dec) -- |Decode unpadded value. -unflatRaw :: (Flat a,AsByteString b) => b -> Decoded a +unflatRaw :: (Flat a, AsByteString b) => b -> Decoded a unflatRaw = unflatRawWith decode -- |Unflat unpadded value, using provided decoder @@ -41,16 +42,18 @@ -- |Encode unpadded value flatRaw :: (Flat a, AsByteString b) => a -> b -flatRaw a = fromByteString $ - E.strictEncoder - (getSize a) -#ifdef ETA_VERSION +flatRaw a = + fromByteString $ + E.strictEncoder + (getSize a) + +#ifdef ETA_VERSION (E.trampolineEncoding (encode a)) #else (encode a) #endif --- #ifdef ETA_VERSION +-- #ifdef ETA_VERSION -- deriving (Show, Eq, Ord, Typeable, Generic, NFData) -- instance Flat a => Flat (PostAligned a) where @@ -59,6 +62,3 @@ -- #else -- deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat) -- #endif - - - diff --git a/src/Flat/Tutorial.hs b/src/Flat/Tutorial.hs --- a/src/Flat/Tutorial.hs +++ b/src/Flat/Tutorial.hs @@ -100,62 +100,6 @@ >>> flatBits $ Just True "11" - -== Compatibility -#compatibility# - -=== - -* x32 and x64: 7.10.3, 8.0.2, 8.2.2, 8.4.4, 8.6.5, 8.8.3. - -* and : 8.0.2. - -=== - -* @ghcjs-8.4.0.1@. - -NOTE: Some tests are not run for @ghcjs@ as they are related to unsupported features such as UTF16 encoding of Text and short . - -For details of what tests are skipped search @test/Spec.hs@ for @ghcjs_HOST_OS@. - -NOTE: Some older versions of @ghcjs@ and versions of @flat@ prior to 0.33 encoded @Double@ values incorrectly when not aligned with a byte boundary. - -=== - -It builds (with @etlas 1.5.0.0@ and @eta-0.8.6b2@) and passes the @doctest-static@ test but it won't complete the main @spec@ test probably because of a recursive iteration issue, see . - -Support for @eta@ is not currently being actively mantained. - -== Known Bugs and Infelicities -#known-bugs-and-infelicities# - -=== Longish compilation times - -Relies more than other serialisation libraries on extensive inlining for its good performance, this unfortunately leads to longer compilation times. - -If you have many data types or very large ones this might become an issue. - -A couple of good practices that will eliminate or mitigate this problem are: - -- During development, turn optimisations off (@stack --fast@ or @-O0@ - in the cabal file). - -- Keep your serialisation code in a separate module(s). - -=== Data types with more than 512 constructors are currently unsupported - -This limit could be easily extended, shout if you need it. - -=== Other - -. - -== Acknowledgements -#acknowledgements# - -@flat@ reuses ideas and readapts code from various packages, mainly: -@store@, @binary-bits@ and @binary@ and includes contributions from -Justus Sagemüller. -} diff --git a/stack-6.35.yaml b/stack-6.35.yaml deleted file mode 100644 --- a/stack-6.35.yaml +++ /dev/null @@ -1,13 +0,0 @@ -resolver: lts-6.35 - -packages: - - . - -allow-newer: true - -extra-deps: - - quickcheck-instances-0.3.22 - - QuickCheck-2.13.2 - - splitmix-0.0.2 - - time-compat-1.9.3 - - hashable-1.2.6.1 diff --git a/stack-9.21.yaml b/stack-9.21.yaml deleted file mode 100644 --- a/stack-9.21.yaml +++ /dev/null @@ -1,13 +0,0 @@ -resolver: lts-9.21 - -packages: - - . - -allow-newer: true - -extra-deps: - - quickcheck-instances-0.3.22 - - QuickCheck-2.13.2 - - splitmix-0.0.2 - - time-compat-1.9.3 - - hashable-1.2.6.1 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,43 @@ -resolver: lts-14.27 +# For ghc 7.10.3, use cabal instead +# Supported stack versions + +# resolver: lts-9.21 # ghc 8.0.2 + +# resolver: lts-11.22 # ghc 8.2.2 + +# resolver: lts-12.26 # ghc 8.4.4 + +# resolver: lts-14.27 # ghc 8.6.5 + +# resolver: lts-16.31 # ghc 8.8.4 + +resolver: lts-18.28 # ghc 8.10.7 + +# resolver: lts-19.26 # ghc 9.0.2 + +# resolver: nightly-2022-09-30 # ghc 9.2.4 + packages: - . -# - ../EXTERNAL/doctest + # for test only + # - ../EXTERNAL/doctest + extra-deps: - # Modified doctest, used to generate static tests - # - git: https://github.com/tittoassini/doctest - # commit: c9cdbe4eee086cb8aa46e96532160320dd367f09 + # Modified doctest, used to generate static tests (run by doc-static) + - git: https://github.com/tittoassini/doctest + commit: 3954e94449901764e28cfed1c35490af970e9b01 + + # - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005 + + # for ghcjs-cons + # - jsaddle-0.9.8.2@sha256:e8c003801eb9364fcd6b1e0cda34f072a537bcfa767e6eb8c626836dae77ba04,4419 + # - ref-tf-0.4.0.2@sha256:69de3550250e0cd69f45d080359cb314a9487c915024349c75b78732bbee9332,1134 + + # for text-2.0: + # - text-2.0 + # - Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459 + # - parsec-3.1.15.0@sha256:a162d4cc8884014ba35192545cad293af0529fe11497aad8834bbaaa3dfffc26,4429 + +allow-newer: true diff --git a/test/DocTest/Data/FloatCast.hs b/test/DocTest/Data/FloatCast.hs --- a/test/DocTest/Data/FloatCast.hs +++ b/test/DocTest/Data/FloatCast.hs @@ -8,4 +8,4 @@ import Data.Word tests :: IO TestTree -tests = testGroup "Data.FloatCast" <$> sequence [ DocTest.testProp "src/Data/FloatCast.hs:41" ( \f -> wordToFloat (floatToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:43" "[ExpectedLine [LineChunk \"3189768192\"]]" (DocTest.asPrint( floatToWord (-0.15625) )), DocTest.test "src/Data/FloatCast.hs:46" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToFloat 3189768192 )), DocTest.test "src/Data/FloatCast.hs:49" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( floatToWord (-5.828125) == 0xC0BA8000 )), DocTest.testProp "src/Data/FloatCast.hs:67" ( \f -> wordToDouble (doubleToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:69" "[ExpectedLine [LineChunk \"\\\"3ff0000000000002\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord 1.0000000000000004) "" )), DocTest.test "src/Data/FloatCast.hs:72" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( doubleToWord 1.0000000000000004 == 0x3FF0000000000002 )), DocTest.test "src/Data/FloatCast.hs:75" "[ExpectedLine [LineChunk \"\\\"bfc4000000000000\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord (-0.15625)) "" )), DocTest.test "src/Data/FloatCast.hs:78" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToDouble 0xbfc4000000000000 )), DocTest.test "src/Data/FloatCast.hs:93" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) ))] +tests = testGroup "Data.FloatCast" <$> sequence [ DocTest.testProp "src/Data/FloatCast.hs:42" ( \f -> wordToFloat (floatToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:45" "[ExpectedLine [LineChunk \"3189768192\"]]" (DocTest.asPrint( floatToWord (-0.15625) )), DocTest.test "src/Data/FloatCast.hs:48" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToFloat 3189768192 )), DocTest.test "src/Data/FloatCast.hs:51" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( floatToWord (-5.828125) == 0xC0BA8000 )), DocTest.testProp "src/Data/FloatCast.hs:70" ( \f -> wordToDouble (doubleToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:73" "[ExpectedLine [LineChunk \"\\\"3ff0000000000002\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord 1.0000000000000004) "" )), DocTest.test "src/Data/FloatCast.hs:76" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( doubleToWord 1.0000000000000004 == 0x3FF0000000000002 )), DocTest.test "src/Data/FloatCast.hs:79" "[ExpectedLine [LineChunk \"\\\"bfc4000000000000\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord (-0.15625)) "" )), DocTest.test "src/Data/FloatCast.hs:82" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToDouble 0xbfc4000000000000 )), DocTest.test "src/Data/FloatCast.hs:97" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) ))] diff --git a/test/DocTest/Data/ZigZag.hs b/test/DocTest/Data/ZigZag.hs --- a/test/DocTest/Data/ZigZag.hs +++ b/test/DocTest/Data/ZigZag.hs @@ -8,7 +8,8 @@ import Data.Word import Data.Int import Numeric.Natural -import Test.QuickCheck.Instances.Natural +import Test.QuickCheck.Arbitrary +instance Arbitrary Natural where arbitrary = arbitrarySizedNatural; shrink = shrinkIntegral tests :: IO TestTree -tests = testGroup "Data.ZigZag" <$> sequence [ DocTest.testProp "src/Data/ZigZag.hs:66" ( \(f::Integer) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:68" ( \(f::Natural) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:70" ( \(f::Int8) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:71" ( \(f::Word8) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:72" ( \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:73" ( \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.testProp "src/Data/ZigZag.hs:75" ( \(f::Int64) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:76" ( \(f::Word64) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:77" ( \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:78" ( \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.test "src/Data/ZigZag.hs:33" "[ExpectedLine [LineChunk \"0\"]]" (DocTest.asPrint( zigZag (0::Int8) )), DocTest.test "src/Data/ZigZag.hs:36" "[ExpectedLine [LineChunk \"1\"]]" (DocTest.asPrint( zigZag (-1::Int16) )), DocTest.test "src/Data/ZigZag.hs:39" "[ExpectedLine [LineChunk \"2\"]]" (DocTest.asPrint( zigZag (1::Int32) )), DocTest.test "src/Data/ZigZag.hs:42" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( zigZag (-2::Int16) )), DocTest.test "src/Data/ZigZag.hs:45" "[ExpectedLine [LineChunk \"99\"]]" (DocTest.asPrint( zigZag (-50::Integer) )), DocTest.test "src/Data/ZigZag.hs:48" "[ExpectedLine [LineChunk \"100\"]]" (DocTest.asPrint( zigZag (50::Integer) )), DocTest.test "src/Data/ZigZag.hs:51" "[ExpectedLine [LineChunk \"128\"]]" (DocTest.asPrint( zigZag (64::Integer) )), DocTest.test "src/Data/ZigZag.hs:54" "[ExpectedLine [LineChunk \"511\"]]" (DocTest.asPrint( zigZag (-256::Integer) )), DocTest.test "src/Data/ZigZag.hs:57" "[ExpectedLine [LineChunk \"512\"]]" (DocTest.asPrint( zigZag (256::Integer) )), DocTest.test "src/Data/ZigZag.hs:60" "[ExpectedLine [LineChunk \"[5,3,1,0,2,4,6]\"]]" (DocTest.asPrint( map zigZag [-3..3::Integer] )), DocTest.test "src/Data/ZigZag.hs:63" "[ExpectedLine [LineChunk \"[0,-1,1,-2,2,-3,3]\"]]" (DocTest.asPrint( map zagZig [0..6::Word8] ))] +tests = testGroup "Data.ZigZag" <$> sequence [ DocTest.testProp "src/Data/ZigZag.hs:67" ( \(f::Integer) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:70" ( \(f::Natural) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:73" ( \(f::Int8) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:76" ( \(f::Word8) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:79" ( \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:82" ( \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.testProp "src/Data/ZigZag.hs:85" ( \(f::Int64) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:88" ( \(f::Word64) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:91" ( \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:94" ( \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.test "src/Data/ZigZag.hs:34" "[ExpectedLine [LineChunk \"0\"]]" (DocTest.asPrint( zigZag (0::Int8) )), DocTest.test "src/Data/ZigZag.hs:37" "[ExpectedLine [LineChunk \"1\"]]" (DocTest.asPrint( zigZag (-1::Int16) )), DocTest.test "src/Data/ZigZag.hs:40" "[ExpectedLine [LineChunk \"2\"]]" (DocTest.asPrint( zigZag (1::Int32) )), DocTest.test "src/Data/ZigZag.hs:43" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( zigZag (-2::Int16) )), DocTest.test "src/Data/ZigZag.hs:46" "[ExpectedLine [LineChunk \"99\"]]" (DocTest.asPrint( zigZag (-50::Integer) )), DocTest.test "src/Data/ZigZag.hs:49" "[ExpectedLine [LineChunk \"100\"]]" (DocTest.asPrint( zigZag (50::Integer) )), DocTest.test "src/Data/ZigZag.hs:52" "[ExpectedLine [LineChunk \"128\"]]" (DocTest.asPrint( zigZag (64::Integer) )), DocTest.test "src/Data/ZigZag.hs:55" "[ExpectedLine [LineChunk \"511\"]]" (DocTest.asPrint( zigZag (-256::Integer) )), DocTest.test "src/Data/ZigZag.hs:58" "[ExpectedLine [LineChunk \"512\"]]" (DocTest.asPrint( zigZag (256::Integer) )), DocTest.test "src/Data/ZigZag.hs:61" "[ExpectedLine [LineChunk \"[5,3,1,0,2,4,6]\"]]" (DocTest.asPrint( map zigZag [-3..3::Integer] )), DocTest.test "src/Data/ZigZag.hs:64" "[ExpectedLine [LineChunk \"[0,-1,1,-2,2,-3,3]\"]]" (DocTest.asPrint( map zagZig [0..6::Word8] ))] diff --git a/test/DocTest/Flat/Bits.hs b/test/DocTest/Flat/Bits.hs --- a/test/DocTest/Flat/Bits.hs +++ b/test/DocTest/Flat/Bits.hs @@ -6,7 +6,7 @@ import Flat.Bits import Data.Word import Flat.Instances.Base -import Flat.Instances.Test +import Flat.Instances.Test(tst,prettyShow) tests :: IO TestTree -tests = testGroup "Flat.Bits" <$> sequence [ DocTest.test "src/Flat/Bits.hs:44" "[ExpectedLine [LineChunk \"[True]\"]]" (DocTest.asPrint( bits True )), DocTest.test "src/Flat/Bits.hs:55" "[ExpectedLine [LineChunk \"[True,False,False,False,False,False,False,True]\"]]" (DocTest.asPrint( paddedBits True )), DocTest.test "src/Flat/Bits.hs:71" "[ExpectedLine [LineChunk \"[False,False,False,False,False,True,False,True]\"]]" (DocTest.asPrint( asBits (5::Word8) )), DocTest.test "src/Flat/Bits.hs:79" "[ExpectedLine [LineChunk \"[1,3]\"]]" (DocTest.asPrint( asBytes $ asBits (256+3::Word16) )), DocTest.test "src/Flat/Bits.hs:96" "[ExpectedLine [LineChunk \"\\\"00000001 00000011\\\"\"]]" (DocTest.asPrint( prettyShow $ asBits (256+3::Word16) ))] +tests = testGroup "Flat.Bits" <$> sequence [ DocTest.test "src/Flat/Bits.hs:50" "[ExpectedLine [LineChunk \"[True]\"]]" (DocTest.asPrint( bits True )), DocTest.test "src/Flat/Bits.hs:62" "[ExpectedLine [LineChunk \"[True,False,False,False,False,False,False,True]\"]]" (DocTest.asPrint( paddedBits True )), DocTest.test "src/Flat/Bits.hs:82" "[ExpectedLine [LineChunk \"[False,False,False,False,False,True,False,True]\"]]" (DocTest.asPrint( asBits (5::Word8) )), DocTest.test "src/Flat/Bits.hs:90" "[ExpectedLine [LineChunk \"[1,3]\"]]" (DocTest.asPrint( asBytes $ asBits (256+3::Word16) )), DocTest.test "src/Flat/Bits.hs:106" "[ExpectedLine [LineChunk \"\\\"00000001 00000011\\\"\"]]" (DocTest.asPrint( prettyShow $ asBits (256+3::Word16) ))] diff --git a/test/DocTest/Flat/Decoder/Prim.hs b/test/DocTest/Flat/Decoder/Prim.hs --- a/test/DocTest/Flat/Decoder/Prim.hs +++ b/test/DocTest/Flat/Decoder/Prim.hs @@ -8,6 +8,8 @@ import Data.Word import Data.Int import Flat.Run +import Flat.Bits +import Text.PrettyPrint.HughesPJClass (Pretty (pPrint)) tests :: IO TestTree -tests = testGroup "Flat.Decoder.Prim" <$> sequence [ DocTest.test "src/Flat/Decoder/Prim.hs:187" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 ))] +tests = testGroup "Flat.Decoder.Prim" <$> sequence [ DocTest.test "src/Flat/Decoder/Prim.hs:199" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 )), DocTest.test "src/Flat/Decoder/Prim.hs:202" "[ExpectedLine [LineChunk \"Left (BadOp \\\"read8: cannot read 9 bits\\\")\"]]" (DocTest.asPrint( unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] )), DocTest.test "src/Flat/Decoder/Prim.hs:215" "[ExpectedLine [LineChunk \"Right 00000101 10111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] )), DocTest.test "src/Flat/Decoder/Prim.hs:220" "[ExpectedLine [LineChunk \"Right 00000111 11111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] ))] diff --git a/test/DocTest/Flat/Encoder/Prim.hs b/test/DocTest/Flat/Encoder/Prim.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Encoder/Prim.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Encoder.Prim where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Encoder.Prim +import Flat.Instances.Test +import Flat.Bits +import Flat.Encoder.Strict +import Control.Monad +enc e = prettyShow $ encBits 256 (Encoding e) + +tests :: IO TestTree +tests = testGroup "Flat.Encoder.Prim" <$> sequence [ DocTest.test "src/Flat/Encoder/Prim.hs:376" "[ExpectedLine [LineChunk \"\\\"1\\\"\"]]" (DocTest.asPrint( enc eTrueF )), DocTest.test "src/Flat/Encoder/Prim.hs:384" "[ExpectedLine [LineChunk \"\\\"0\\\"\"]]" (DocTest.asPrint( enc eFalseF )), DocTest.test "src/Flat/Encoder/Prim.hs:394" "[ExpectedLine [LineChunk \"\\\"10000001\\\"\"]]" (DocTest.asPrint( enc $ eTrueF >=> eFillerF )), DocTest.test "src/Flat/Encoder/Prim.hs:397" "[ExpectedLine [LineChunk \"\\\"00000001\\\"\"]]" (DocTest.asPrint( enc eFillerF )), DocTest.test "src/Flat/Encoder/Prim.hs:430" "[ExpectedLine [LineChunk \"\\\"11111111\\\"\"]]" (DocTest.asPrint( enc $ \s-> eWord8F 0 s >>= updateWord8 255 s )), DocTest.test "src/Flat/Encoder/Prim.hs:433" "[ExpectedLine [LineChunk \"\\\"10000000 01111111 1\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eWord8F 255 >>= updateWord8 0 s1 )), DocTest.test "src/Flat/Encoder/Prim.hs:436" "[ExpectedLine [LineChunk \"\\\"01111111 1\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 )), DocTest.test "src/Flat/Encoder/Prim.hs:439" "[ExpectedLine [LineChunk \"\\\"01111111 10\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 >>= eFalseF )), DocTest.test "src/Flat/Encoder/Prim.hs:442" "[ExpectedLine [LineChunk \"\\\"10000000 011\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eTrueF >>= updateWord8 0 s1 >>= eTrueF ))] diff --git a/test/DocTest/Flat/Endian.hs b/test/DocTest/Flat/Endian.hs --- a/test/DocTest/Flat/Endian.hs +++ b/test/DocTest/Flat/Endian.hs @@ -7,4 +7,4 @@ import Numeric (showHex) tests :: IO TestTree -tests = testGroup "Flat.Endian" <$> sequence [ DocTest.test "src/Flat/Endian.hs:36" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE64 0xF0F1F2F3F4F5F6F7 == if isBigEndian then 0xF0F1F2F3F4F5F6F7 else 0xF7F6F5F4F3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:49" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE32 0xF0F1F2F3 == if isBigEndian then 0xF0F1F2F3 else 0xF3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:62" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE16 0xF0F1 == if isBigEndian then 0xF0F1 else 0xF1F0 ))] +tests = testGroup "Flat.Endian" <$> sequence [ DocTest.test "src/Flat/Endian.hs:38" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE64 0xF0F1F2F3F4F5F6F7 == if isBigEndian then 0xF0F1F2F3F4F5F6F7 else 0xF7F6F5F4F3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:51" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE32 0xF0F1F2F3 == if isBigEndian then 0xF0F1F2F3 else 0xF3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:64" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE16 0xF0F1 == if isBigEndian then 0xF0F1 else 0xF1F0 ))] diff --git a/test/DocTest/Flat/Instances/Base.hs b/test/DocTest/Flat/Instances/Base.hs --- a/test/DocTest/Flat/Instances/Base.hs +++ b/test/DocTest/Flat/Instances/Base.hs @@ -16,6 +16,7 @@ import Data.Monoid import qualified Data.List.NonEmpty as B test = tstBits +y = 33 tests :: IO TestTree -tests = testGroup "Flat.Instances.Base" <$> sequence [ DocTest.test "src/Flat/Instances/Base.hs:96" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w )), DocTest.test "src/Flat/Instances/Base.hs:99" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w )), DocTest.test "src/Flat/Instances/Base.hs:143" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test () )), DocTest.test "src/Flat/Instances/Base.hs:156" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test False )), DocTest.test "src/Flat/Instances/Base.hs:159" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test True )), DocTest.test "src/Flat/Instances/Base.hs:174" "[ExpectedLine [LineChunk \"(True,8,\\\"01100001\\\")\"]]" (DocTest.asPrint( test 'a' )), DocTest.test "src/Flat/Instances/Base.hs:179" "[ExpectedLine [LineChunk \"(True,16,\\\"11001000 00000001\\\")\"]]" (DocTest.asPrint( test 'È' )), DocTest.test "src/Flat/Instances/Base.hs:182" "[ExpectedLine [LineChunk \"(True,24,\\\"10001101 10011100 00000001\\\")\"]]" (DocTest.asPrint( test '不' )), DocTest.test "src/Flat/Instances/Base.hs:198" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (Nothing::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:201" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (Just False::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:207" "[ExpectedLine [LineChunk \"(True,2,\\\"00\\\")\"]]" (DocTest.asPrint( test (Left False::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:210" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test (Right ()::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:216" "[ExpectedLine [LineChunk \"(True,16,\\\"11110110 00000001\\\")\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) )), DocTest.test "src/Flat/Instances/Base.hs:219" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) )), DocTest.test "src/Flat/Instances/Base.hs:232" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:235" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (255::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:279" "[ExpectedLine [LineChunk \"(True,8,\\\"01111111\\\")\"]]" (DocTest.asPrint( test (127::Word) )), DocTest.test "src/Flat/Instances/Base.hs:284" "[ExpectedLine [LineChunk \"(True,16,\\\"11111110 00000001\\\")\"]]" (DocTest.asPrint( test (254::Word) )), DocTest.test "src/Flat/Instances/Base.hs:289" "[ExpectedLine [LineChunk \"(True,24,\\\"10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (32768::Word32) )), DocTest.test "src/Flat/Instances/Base.hs:294" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] )), DocTest.test "src/Flat/Instances/Base.hs:307" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:310" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (2^120::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:362" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int) )), DocTest.test "src/Flat/Instances/Base.hs:365" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:368" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:371" "[ExpectedLine [LineChunk \"(True,8,\\\"00000011\\\")\"]]" (DocTest.asPrint( test (-2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:374" "[ExpectedLine [LineChunk \"(True,8,\\\"00000100\\\")\"]]" (DocTest.asPrint( test (2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:387" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:390" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:393" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:396" "[ExpectedLine [LineChunk \"(True,8,\\\"00011111\\\")\"]]" (DocTest.asPrint( test (-(2^4)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:399" "[ExpectedLine [LineChunk \"(True,8,\\\"00100000\\\")\"]]" (DocTest.asPrint( test (2^4::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:402" "[ExpectedLine [LineChunk \"(True,144,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (-(2^120)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:405" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100\\\")\"]]" (DocTest.asPrint( test (2^120::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:416" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:419" "[ExpectedLine [LineChunk \"(True,8,\\\"11111110\\\")\"]]" (DocTest.asPrint( test (127::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:422" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (-128::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:433" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:436" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:439" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:442" "[ExpectedLine [LineChunk \"(True,24,\\\"11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (minBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:447" "[ExpectedLine [LineChunk \"(True,24,\\\"11111110 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (maxBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:460" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:463" "[ExpectedLine [LineChunk \"(True,40,\\\"11111111 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (minBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:466" "[ExpectedLine [LineChunk \"(True,40,\\\"11111110 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (maxBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:477" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:480" "[ExpectedLine [LineChunk \"(True,80,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (minBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:483" "[ExpectedLine [LineChunk \"(True,80,\\\"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (maxBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:503" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000000\\\")\"]]" (DocTest.asPrint( test (0::Float) )), DocTest.test "src/Flat/Instances/Base.hs:506" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000001\\\")\"]]" (DocTest.asPrint( test (1.4012984643E-45::Float) )), DocTest.test "src/Flat/Instances/Base.hs:509" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 01111111 11111111 11111111\\\")\"]]" (DocTest.asPrint( test (1.1754942107E-38::Float) )), DocTest.test "src/Flat/Instances/Base.hs:536" "[ExpectedLine [LineChunk \"(True,16,\\\"00000100 00000010\\\")\"]]" (DocTest.asPrint( test (4 :+ 2 :: Complex Word8) )), DocTest.test "src/Flat/Instances/Base.hs:544" "[ExpectedLine [LineChunk \"(True,16,\\\"00000011 00000100\\\")\"]]" (DocTest.asPrint( test (3%4::Ratio Word8) )), DocTest.test "src/Flat/Instances/Base.hs:556" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test ([]::[Bool]) )), DocTest.test "src/Flat/Instances/Base.hs:559" "[ExpectedLine [LineChunk \"(True,5,\\\"10100\\\")\"]]" (DocTest.asPrint( test [False,False] )), DocTest.test "src/Flat/Instances/Base.hs:584" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test "" )), DocTest.test "src/Flat/Instances/Base.hs:587" "[ExpectedLine [LineChunk \"(True,28,\\\"10110000 11011000 01101100 0010\\\")\"]]" (DocTest.asPrint( test "aaa" )), DocTest.test "src/Flat/Instances/Base.hs:595" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (B.fromList [True]) )), DocTest.test "src/Flat/Instances/Base.hs:598" "[ExpectedLine [LineChunk \"(True,4,\\\"0100\\\")\"]]" (DocTest.asPrint( test (B.fromList [False,False]) )), DocTest.test "src/Flat/Instances/Base.hs:607" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (False,()) )), DocTest.test "src/Flat/Instances/Base.hs:610" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test ((),()) )), DocTest.test "src/Flat/Instances/Base.hs:615" "[ExpectedLine [LineChunk \"(True,7,\\\"0111011\\\")\"]]" (DocTest.asPrint( test (False,True,True,True,False,True,True) ))] +tests = testGroup "Flat.Instances.Base" <$> sequence [ DocTest.test "src/Flat/Instances/Base.hs:73" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w )), DocTest.test "src/Flat/Instances/Base.hs:76" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w )), DocTest.test "src/Flat/Instances/Base.hs:148" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test () )), DocTest.test "src/Flat/Instances/Base.hs:161" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test False )), DocTest.test "src/Flat/Instances/Base.hs:164" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test True )), DocTest.test "src/Flat/Instances/Base.hs:179" "[ExpectedLine [LineChunk \"(True,8,\\\"01100001\\\")\"]]" (DocTest.asPrint( test 'a' )), DocTest.test "src/Flat/Instances/Base.hs:184" "[ExpectedLine [LineChunk \"(True,16,\\\"11001000 00000001\\\")\"]]" (DocTest.asPrint( test 'È' )), DocTest.test "src/Flat/Instances/Base.hs:187" "[ExpectedLine [LineChunk \"(True,24,\\\"10001101 10011100 00000001\\\")\"]]" (DocTest.asPrint( test '不' )), DocTest.test "src/Flat/Instances/Base.hs:203" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (Nothing::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:206" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (Just False::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:212" "[ExpectedLine [LineChunk \"(True,2,\\\"00\\\")\"]]" (DocTest.asPrint( test (Left False::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:215" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test (Right ()::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:221" "[ExpectedLine [LineChunk \"(True,16,\\\"11110110 00000001\\\")\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) )), DocTest.test "src/Flat/Instances/Base.hs:224" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) )), DocTest.test "src/Flat/Instances/Base.hs:237" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:240" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (255::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:284" "[ExpectedLine [LineChunk \"(True,8,\\\"01111111\\\")\"]]" (DocTest.asPrint( test (127::Word) )), DocTest.test "src/Flat/Instances/Base.hs:289" "[ExpectedLine [LineChunk \"(True,16,\\\"11111110 00000001\\\")\"]]" (DocTest.asPrint( test (254::Word) )), DocTest.test "src/Flat/Instances/Base.hs:294" "[ExpectedLine [LineChunk \"(True,24,\\\"10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (32768::Word32) )), DocTest.test "src/Flat/Instances/Base.hs:299" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] )), DocTest.test "src/Flat/Instances/Base.hs:312" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:315" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (2^120::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:365" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int) )), DocTest.test "src/Flat/Instances/Base.hs:368" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:371" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:374" "[ExpectedLine [LineChunk \"(True,8,\\\"00000011\\\")\"]]" (DocTest.asPrint( test (-2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:377" "[ExpectedLine [LineChunk \"(True,8,\\\"00000100\\\")\"]]" (DocTest.asPrint( test (2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:390" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:393" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:396" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:399" "[ExpectedLine [LineChunk \"(True,8,\\\"00011111\\\")\"]]" (DocTest.asPrint( test (-(2^4)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:402" "[ExpectedLine [LineChunk \"(True,8,\\\"00100000\\\")\"]]" (DocTest.asPrint( test (2^4::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:405" "[ExpectedLine [LineChunk \"(True,144,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (-(2^120)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:408" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100\\\")\"]]" (DocTest.asPrint( test (2^120::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:419" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:422" "[ExpectedLine [LineChunk \"(True,8,\\\"11111110\\\")\"]]" (DocTest.asPrint( test (127::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:425" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (-128::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:436" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:439" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:442" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:445" "[ExpectedLine [LineChunk \"(True,24,\\\"11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (minBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:450" "[ExpectedLine [LineChunk \"(True,24,\\\"11111110 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (maxBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:463" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:466" "[ExpectedLine [LineChunk \"(True,40,\\\"11111111 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (minBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:469" "[ExpectedLine [LineChunk \"(True,40,\\\"11111110 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (maxBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:480" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:483" "[ExpectedLine [LineChunk \"(True,80,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (minBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:486" "[ExpectedLine [LineChunk \"(True,80,\\\"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (maxBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:505" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000000\\\")\"]]" (DocTest.asPrint( test (0::Float) )), DocTest.test "src/Flat/Instances/Base.hs:508" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000001\\\")\"]]" (DocTest.asPrint( test (1.4012984643E-45::Float) )), DocTest.test "src/Flat/Instances/Base.hs:511" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 01111111 11111111 11111111\\\")\"]]" (DocTest.asPrint( test (1.1754942107E-38::Float) )), DocTest.test "src/Flat/Instances/Base.hs:538" "[ExpectedLine [LineChunk \"(True,16,\\\"00000100 00000010\\\")\"]]" (DocTest.asPrint( test (4 :+ 2 :: Complex Word8) )), DocTest.test "src/Flat/Instances/Base.hs:546" "[ExpectedLine [LineChunk \"(True,16,\\\"00000011 00000100\\\")\"]]" (DocTest.asPrint( test (3%4::Ratio Word8) )), DocTest.test "src/Flat/Instances/Base.hs:558" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test ([]::[Bool]) )), DocTest.test "src/Flat/Instances/Base.hs:561" "[ExpectedLine [LineChunk \"(True,5,\\\"10100\\\")\"]]" (DocTest.asPrint( test [False,False] )), DocTest.test "src/Flat/Instances/Base.hs:595" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (B.fromList [True]) )), DocTest.test "src/Flat/Instances/Base.hs:598" "[ExpectedLine [LineChunk \"(True,4,\\\"0100\\\")\"]]" (DocTest.asPrint( test (B.fromList [False,False]) )), DocTest.test "src/Flat/Instances/Base.hs:608" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (False,()) )), DocTest.test "src/Flat/Instances/Base.hs:611" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test ((),()) )), DocTest.test "src/Flat/Instances/Base.hs:616" "[ExpectedLine [LineChunk \"(True,7,\\\"0111011\\\")\"]]" (DocTest.asPrint( test (False,True,True,True,False,True,True) ))] diff --git a/test/DocTest/Flat/Instances/Extra.hs b/test/DocTest/Flat/Instances/Extra.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Extra.hs @@ -0,0 +1,10 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Extra where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Extra +import Flat.Instances.Test + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Extra" <$> sequence [ DocTest.test "src/Flat/Instances/Extra.hs:13" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( tstBits "" )), DocTest.test "src/Flat/Instances/Extra.hs:16" "[ExpectedLine [LineChunk \"(True,28,\\\"10110000 11011000 01101100 0010\\\")\"]]" (DocTest.asPrint( tstBits "aaa" ))] diff --git a/test/DocTest/Flat/Instances/Mono.hs b/test/DocTest/Flat/Instances/Mono.hs --- a/test/DocTest/Flat/Instances/Mono.hs +++ b/test/DocTest/Flat/Instances/Mono.hs @@ -11,4 +11,4 @@ import qualified Data.Map tests :: IO TestTree -tests = testGroup "Flat.Instances.Mono" <$> sequence [ DocTest.test "src/Flat/Instances/Mono.hs:60" "[ExpectedLine [LineChunk \"(True,8,[0])\"]]" (DocTest.asPrint( tst $ AsArray ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:63" "[ExpectedLine [LineChunk \"(True,40,[3,11,22,33,0])\"]]" (DocTest.asPrint( tst $ AsArray [11::Word8,22,33] )), DocTest.test "src/Flat/Instances/Mono.hs:66" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst $ AsList ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:69" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Mono.hs:72" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsSet (Data.Set.fromList [11::Word8,22,33])) )), DocTest.test "src/Flat/Instances/Mono.hs:162" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) )), DocTest.test "src/Flat/Instances/Mono.hs:165" "[ExpectedLine [LineChunk \"(True,18,[129,132,128])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) ))] +tests = testGroup "Flat.Instances.Mono" <$> sequence [ DocTest.test "src/Flat/Instances/Mono.hs:62" "[ExpectedLine [LineChunk \"\\\"1111110\\\"\"]]" (DocTest.asPrint( flatBits $ AsList [True,True,True] )), DocTest.test "src/Flat/Instances/Mono.hs:69" "[ExpectedLine [LineChunk \"\\\"1111110\\\"\"]]" (DocTest.asPrint( flatBits $ [True,True,True] )), DocTest.test "src/Flat/Instances/Mono.hs:74" "[ExpectedLine [LineChunk \"\\\"00000011 11100000 000\\\"\"]]" (DocTest.asPrint( flatBits $ AsArray [True,True,True] )), DocTest.test "src/Flat/Instances/Mono.hs:79" "[ExpectedLine [LineChunk \"\\\"10000001 11110000 00000\\\"\"]]" (DocTest.asPrint( flatBits $ [AsArray [True,True,True]] )), DocTest.test "src/Flat/Instances/Mono.hs:82" "[ExpectedLine [LineChunk \"\\\"11100000 11111111 11000000 00\\\"\"]]" (DocTest.asPrint( flatBits $ (True,True,True,AsArray $ replicate 7 True) )), DocTest.test "src/Flat/Instances/Mono.hs:85" "[ExpectedLine [LineChunk \"\\\"00000000\\\"\"]]" (DocTest.asPrint( flatBits $ AsArray ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:88" "[ExpectedLine [LineChunk \"\\\"0\\\"\"]]" (DocTest.asPrint( flatBits $ AsList ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:91" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Mono.hs:94" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsSet (Data.Set.fromList [11::Word8,22,33])) )), DocTest.test "src/Flat/Instances/Mono.hs:97" "[ExpectedLine [LineChunk \"(True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0])\"]]" (DocTest.asPrint( tst [AsArray [1..3], AsArray [4..8]] )), DocTest.test "src/Flat/Instances/Mono.hs:100" "[ExpectedLine [LineChunk \"(True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0])\"]]" (DocTest.asPrint( tst $ [AsArray [(1::Word8)..3], AsArray [4..8]] )), DocTest.test "src/Flat/Instances/Mono.hs:103" "[ExpectedLine [LineChunk \"(True,42,[129,129,2,3,0,0])\"]]" (DocTest.asPrint( tst $ [AsArray [(1::Int)..3]] )), DocTest.test "src/Flat/Instances/Mono.hs:196" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) )), DocTest.test "src/Flat/Instances/Mono.hs:199" "[ExpectedLine [LineChunk \"(True,18,[129,132,128])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) ))] diff --git a/test/DocTest/Flat/Repr.hs b/test/DocTest/Flat/Repr.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Repr.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Repr where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Repr +import Flat.Instances.Base +import Flat.Decoder.Types +import Flat.Types +import Flat.Run +import Flat.Class + +tests :: IO TestTree +tests = testGroup "Flat.Repr" <$> sequence [ DocTest.test "src/Flat/Repr.hs:27" "[ExpectedLine [LineChunk \"Right [Repr {repr = \\\"\\\\STX\\\\SOH\\\"},Repr {repr = \\\"\\\\EOT\\\\SOH\\\"},Repr {repr = \\\"\\\\ACK\\\\SOH\\\"},Repr {repr = \\\"\\\\b\\\\SOH\\\"},Repr {repr = \\\"\\\\n\\\\SOH\\\"}]\"]]" (DocTest.asPrint( unflat (flat [1::Int .. 5]) :: Decoded ([Repr Int]) )), DocTest.test "src/Flat/Repr.hs:32" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( let Right l = unflat (flat [1..5]) :: Decoded [Repr Int] in unrepr (l !! 2) )), DocTest.test "src/Flat/Repr.hs:42" "[ExpectedLine [LineChunk \"Right ('a',SizeOf 28,'z',SizeOf 1)\"]]" (DocTest.asPrint( let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,SizeOf String,Char,SizeOf Bool) ))] diff --git a/test/DocTests.hs b/test/DocTests.hs --- a/test/DocTests.hs +++ b/test/DocTests.hs @@ -2,19 +2,22 @@ import Test.Tasty import Test.Tasty.HUnit import qualified DocTest.Flat.Bits +import qualified DocTest.Flat.Repr import qualified DocTest.Flat.Instances.Array import qualified DocTest.Flat.Instances.ByteString import qualified DocTest.Flat.Instances.DList +import qualified DocTest.Flat.Instances.Extra import qualified DocTest.Flat.Instances.Containers import qualified DocTest.Flat.Instances.Base import qualified DocTest.Flat.Instances.Unordered import qualified DocTest.Flat.Instances.Vector import qualified DocTest.Flat.Instances.Mono import qualified DocTest.Flat.Instances.Text +import qualified DocTest.Flat.Encoder.Prim import qualified DocTest.Flat.Tutorial import qualified DocTest.Flat.Decoder.Prim import qualified DocTest.Flat.Endian import qualified DocTest.Data.ZigZag import qualified DocTest.Data.FloatCast -main = (testGroup "DocTests" <$> sequence [DocTest.Flat.Bits.tests,DocTest.Flat.Instances.Array.tests,DocTest.Flat.Instances.ByteString.tests,DocTest.Flat.Instances.DList.tests,DocTest.Flat.Instances.Containers.tests,DocTest.Flat.Instances.Base.tests,DocTest.Flat.Instances.Unordered.tests,DocTest.Flat.Instances.Vector.tests,DocTest.Flat.Instances.Mono.tests,DocTest.Flat.Instances.Text.tests,DocTest.Flat.Tutorial.tests,DocTest.Flat.Decoder.Prim.tests,DocTest.Flat.Endian.tests,DocTest.Data.ZigZag.tests,DocTest.Data.FloatCast.tests]) >>= defaultMain +main = (testGroup "DocTests" <$> sequence [DocTest.Flat.Bits.tests,DocTest.Flat.Repr.tests,DocTest.Flat.Instances.Array.tests,DocTest.Flat.Instances.ByteString.tests,DocTest.Flat.Instances.DList.tests,DocTest.Flat.Instances.Extra.tests,DocTest.Flat.Instances.Containers.tests,DocTest.Flat.Instances.Base.tests,DocTest.Flat.Instances.Unordered.tests,DocTest.Flat.Instances.Vector.tests,DocTest.Flat.Instances.Mono.tests,DocTest.Flat.Instances.Text.tests,DocTest.Flat.Encoder.Prim.tests,DocTest.Flat.Tutorial.tests,DocTest.Flat.Decoder.Prim.tests,DocTest.Flat.Endian.tests,DocTest.Data.ZigZag.tests,DocTest.Data.FloatCast.tests]) >>= defaultMain diff --git a/test/FlatRepr.hs b/test/FlatRepr.hs new file mode 100644 --- /dev/null +++ b/test/FlatRepr.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where +import qualified Data.ByteString as B +import Data.List (foldl') +import Flat (Decoded, Flat (..), flat, unflat, unflatWith) +import Flat.Decoder (Get, listTDecoder) +import Flat.Repr (Repr, unrepr) +import qualified ListT as L +import System.TimeIt (timeIt) + +-- Big is a type that has a small encoded representation but a very large in-memory footprint. +-- It is a very large bytestring whose bytes are all set to 0 +newtype Big = Big B.ByteString + +newBig :: Int -> Big +newBig gigas = Big $ B.replicate (gigas*giga) 0 + +-- length of Big in gigas +gigas :: Big -> Int +gigas (Big b) = B.length b `div` giga + +giga :: Int +giga = 1000000000 + +instance Show Big where show b = "Big of " ++ show (gigas b) ++ "Gbytes" + +instance Flat Big where + -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros) + size big = size (gigas big) + encode big = encode (gigas big) + + -- The decoded form is massive + decode = newBig <$> decode + +-- Run this as: cabal run FlatRepr -- +RTS -M2g +main :: IO () +main = tbig + +tbig = do + let numOfBigs = 5 + + -- A serialised list of Big values + let bigsFile = flat $ replicate numOfBigs $ newBig 1 + timeIt $ print $ B.length bigsFile + + -- tstSize bigsFile + + tstListT bigsFile + + tstRepr bigsFile + + tstBig bigsFile + +-- If we unserialise a list of Bigs and then process them (e.g. print them out) we end up in trouble, too much memory is required. +tstBig :: B.ByteString -> IO () +tstBig bigsFile = timeIt $ do + print "Decode to [Big]:" + let Right (bs :: [Big]) = unflat bigsFile + mapM_ print bs + +-- So instead we unserialise them to a list of their flat representations, to be unflatted on demand later on +tstRepr :: B.ByteString -> IO () +tstRepr bigsFile = timeIt $ do + print "Decode to [FlatRepl Big]:" + let Right (bsR :: [Repr Big]) = unflat bigsFile + let bs = map unrepr bsR + mapM_ print bs + +-- Or: we extract one element at the time via a ListT +-- See http://hackage.haskell.org/package/list-t-1.0.4/docs/ListT.html +tstListT :: B.ByteString -> IO () +tstListT bigsFile = timeIt $ do + print "Decode to ListT IO Big:" + stream :: L.ListT IO Big <- listTDecoder decode bigsFile + L.traverse_ print stream diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -26,6 +26,7 @@ import Data.Int import Data.Proxy import qualified Data.Sequence as Seq +import Data.String (fromString) import qualified Data.Text as T import Data.Word import Numeric.Natural @@ -260,9 +261,9 @@ dropBits (len * 8 - numBitsToTake - pre) return r -- we expect the first numBitsToTake bits of the value - expectedD @ (Right expected) :: Decoded a = Right + expectedD@(Right expected) :: Decoded a = Right $ val `shR` (sz - numBitsToTake) -- ghcjs: shiftR fails, see: https://github.com/ghcjs/ghcjs/issues/706 - actualD @ (Right actual) :: Decoded a = unflatRawWith dec vs + actualD@(Right actual) :: Decoded a = unflatRawWith dec vs in testCase (unwords [ "take" @@ -420,6 +421,7 @@ errDec (Proxy :: Proxy Bool) [] -- no data , errDec (Proxy :: Proxy Bool) [128] -- no filler , errDec (Proxy :: Proxy Bool) [128 + 1, 1, 2, 4, 8] -- additional bytes + , errDec (Proxy :: Proxy Text) (B.unpack (flat ((fromString "\x80") :: B.ByteString))) -- invalid UTF-8 , encRaw () [] , encRaw ((), (), Unit) [] , encRaw (Unit, 'a', Unit, 'a', Unit, 'a', Unit) [97, 97, 97] diff --git a/test/Test/Data/Arbitrary.hs b/test/Test/Data/Arbitrary.hs --- a/test/Test/Data/Arbitrary.hs +++ b/test/Test/Data/Arbitrary.hs @@ -16,7 +16,7 @@ import Numeric.Natural (Natural) --- #if MIN_VERSION_base(4,9,0) && MIN_VERSION_QuickCheck(2,10,0) +#if MIN_VERSION_base(4,8,0) && MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary a => Arbitrary (BI.NonEmpty a) where arbitrary = BI.fromList . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList a)) shrink xs = BI.fromList <$> shrink (BI.toList xs) @@ -24,7 +24,7 @@ instance Arbitrary Natural where arbitrary = arbitrarySizedNatural shrink = shrinkIntegral --- #endif +#endif -- Copied from quickcheck-instances (not used directly as it requires old-time that is incompatible with ghcjs) diff --git a/test/Test/Data/Flat.hs b/test/Test/Data/Flat.hs --- a/test/Test/Data/Flat.hs +++ b/test/Test/Data/Flat.hs @@ -1,6 +1,5 @@ - {-# LANGUAGE UndecidableInstances, DeriveGeneric - , FlexibleContexts, FlexibleInstances, StandaloneDeriving #-} + , FlexibleContexts, FlexibleInstances, StandaloneDeriving , CPP #-} module Test.Data.Flat ( module Test.Data @@ -33,9 +32,11 @@ -- instance Flat C0 -- instance Flat D0 -- instance Flat E0 +#if MIN_VERSION_base(4,9,0) && ! MIN_VERSION_base(4,16,0) deriving instance Generic (a, b, c, d, e, f, g, h) deriving instance Generic (a, b, c, d, e, f, g, h, i) +#endif instance {-# OVERLAPPABLE #-}( Flat a , Flat b