flat 0.3.2 → 0.3.4

raw patch · 27 files changed

+2204/−701 lines, 27 filesdep +QuickCheckdep −doctestdep −filemanipdep −quickcheck-instancesdep ~arraydep ~basedep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck

Dependencies removed: doctest, filemanip, quickcheck-instances

Dependency ranges changed: array, base, bytestring, containers, deepseq, dlist, mono-traversable, pretty, tasty, tasty-hunit, tasty-quickcheck

API changes (from Hackage documentation)

Files

• CHANGELOG +4/−0
• README.md +39/−28
• flat.cabal +66/−42
• src/Data/Flat.hs +9/−6
• src/Data/Flat/Class.hs +343/−137
• src/Data/Flat/Decoder.hs +5/−3
• src/Data/Flat/Decoder/Prim.hs +156/−26
• src/Data/Flat/Decoder/Types.hs +8/−1
• src/Data/Flat/Encoder.hs +1/−0
• src/Data/Flat/Encoder/Prim.hs +54/−23
• src/Data/Flat/Encoder/Strict.hs +33/−34
• src/Data/Flat/Endian.hs +61/−0
• src/Data/Flat/Instances.hs +31/−16
• src/Data/Flat/Run.hs +1/−0
• src/Data/Flat/Types.hs +0/−1
• src/Data/FloatCast.hs +37/−10
• src/System/Endian.hs +0/−35
• stack.yaml +13/−3
• test/DocSpec.hs +0/−15
• test/Spec.hs +432/−215
• test/Test/Data.hs +2/−68
• test/Test/Data/Arbitrary.hs +102/−15
• test/Test/Data/Flat.hs +15/−10
• test/Test/Data/Values.hs +31/−13
• test/Test/E.hs +42/−0
• test/Test/E/Arbitrary.hs +659/−0
• test/Test/E/Flat.hs +60/−0

@@ -1,5 +1,9 @@ Significant and compatibility-breaking changes. +Version 0.3.4:+	- Redisegned Generics-based instance generation (Data.Flat.Class) to reduce compilation time and improve encoding and decoding performance+	- Fixed GHCJS Double bug and tested GHCJS with full test suite+ Version 0.3: 	- Removed 'flatStrict' and 'unflatStrict' (use 'flat' and 'unflat' instead that also encode/decode strictly) 	- `unflatWith` now takes a decoder for the unpadded value (previously it expected a padded decoder) and decodes the padded value

@@ -1,8 +1,6 @@  [![Build Status](https://travis-ci.org/Quid2/flat.svg?branch=master)](https://travis-ci.org/Quid2/flat) [![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/flat)-[![Stackage LTS](http://stackage.org/package/flat/badge/lts)](http://stackage.org/lts/package/flat)  Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, portable and efficient binary data format ([specs](http://quid2.org)). @@ -108,7 +106,6 @@ -> "10010111 01110111 10000001" ``` - The padding is a sequence of 0s terminated by a 1 running till the next byte boundary (if we are already at a byte boundary it will add an additional byte of value 1, that's unfortunate but there is a good reason for this, check the [specs](http://quid2.org/docs/Flat.pdf)).  Byte-padding is automatically added by the function `flat` and removed by `unflat`.@@ -120,45 +117,59 @@ Briefly:  * Size: `flat` produces significantly smaller binaries than all other libraries (3/4 times usually)  * Encoding: `store` and `flat` are usually faster- * Decoding: `store`, `cereal` and `flat` are usually faster+ * Decoding: `store`, `flat` and `cereal` are usually 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 - One thing that is not shown by the benchmarks is that, if the serialized data is to be transferred over a network, the total transfer time (encoding time + transmission time + decoding time) is usually dominated by the transmission time and that's where the smaller binaries produced by flat give it a significant advantage.+### Compatibility - Consider for example the Cars dataset. As you can see in the following comparison with `store`, the overall top performer for encoding/decoding speed, the transfer time is actually significantly lower for `flat` for all except the highest transmission speeds (about 4 times faster at typical ADSL speeds, 2 times faster at 4G-LTE mobile speeds).+#### [GHC](https://www.haskell.org/ghc/)  -||Store|Flat|-|---|---|---|-|Encoding (mSec)|  3.1|  7.0|-|Decoding (mSec)| 22.6| 30.0|-|Size (bytes)|702728|114841|-|Transmission (mSec) @ 1 MegaByte/Sec|702.7|114.8|-|Transmission (mSec) @ 10 MegaByte/Sec| 70.3| 11.5|-|Transmission (mSec) @ 100 MegaByte/Sec|  7.0|  1.1|-|Total Transfer (mSec) @ 1 MegaByte/Sec|728.4|151.8|-|Total Transfer (mSec) @ 10 MegaByte/Sec| 96.0| 48.5|-|Total Transfer (mSec) @ 100 MegaByte/Sec| 32.7| 38.1|+Tested with:+  * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.2, 8.2.2, 8.4.4 and 8.6.1 (x64) +Should also work with (not recently tested):+  * [ghc](https://www.haskell.org/ghc/) 7.10.3/LLVM 3.5.2 (Arm7) -### Haskell Compatibility+####  [GHCJS](https://github.com/ghcjs/ghcjs)+ +Passes all tests in the `flat` testsuite, except for those relative to short bytestrings (Data.ByteString.Short) that are unsupported by `ghcjs`. -Tested with:-  * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.2, 8.2.2, 8.4.2 and 8.4.3 (x64)-  * [ghc](https://www.haskell.org/ghc/) 7.10.3/LLVM 3.5.2 (Arm7)-  * [ghcjs](https://github.com/ghcjs/ghcjs)+Check [stack-ghcjs.yaml](https://github.com/Quid2/flat/blob/master/stack-ghcjs.yaml) to see with what versions of `ghcjs` it has been tested. -It also seems to be working with [Eta](https://eta-lang.org/) though the full test suite could not be run due to Eta's issues compiling `quickcheck` and `doctest`.+If you use a different version of `ghcjs`, you might want to run the test suite by setting your compiler in [stack-ghcjs.yaml](https://github.com/Quid2/flat/blob/master/stack-ghcjs.yaml) and then running: +`stack test --stack-yaml=stack-ghcjs.yaml`++NOTE: Versions prior to 0.33 encode `Double` values incorrectly when they are not aligned with a byte boundary.++NOTE: A native [TypeScript/JavaScript version](https://github.com/Quid2/ts) of `flat` is under development.++#### [ETA](https://eta-lang.org/)++It builds (with etlas 1.5.0.0 and eta eta-0.8.6b2 under macOS Sierra) and seems to be working, though the full test suite could not be run due to Eta's issues compiling some of the test suite dependencies.+ ### Installation  Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat). -### Acknowledgements+### Known Bugs and Infelicities - `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes contributions from Justus Sagemüller.+#### Longish compilation times -### Known Bugs and Infelicities+'flat` relies more than other serialisation libraries on extensive inlining for its good performance, this unfortunately leads to longer compilation times.  -* A performance issue with GHC 8.0.2 for some data types+If you have many data types or very large ones this might become an issue. -* Longish compilation times for generated Flat instances+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++See also the [full list of open issues](https://github.com/Quid2/flat/issues).++### Acknowledgements++ `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes contributions from Justus Sagemüller.

@@ -1,18 +1,17 @@ name: flat-version: 0.3.2+version: 0.3.4 synopsis: Principled and efficient bit-oriented binary serialization. description: Principled and efficient bit-oriented binary serialization, check the <http://github.com/Quid2/flat online tutorial>.-homepage: http://github.com/Quid2/flat+homepage: http://quid2.org category: Data,Parsing,Serialization license:             BSD3 license-file:        LICENSE author:              Pasqualino `Titto` Assini maintainer:          tittoassini@gmail.com-copyright:           Copyright: (c) 2016 Pasqualino `Titto` Assini+copyright:           Copyright: (c) 2016-2018 Pasqualino `Titto` Assini cabal-version: >=1.10 build-type: Simple--- The library (but not its tests) compiles with ETA == 0.7.2 (see https://eta-lang.org/) -Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.2+Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.1  extra-source-files:     stack.yaml@@ -38,79 +37,104 @@         Data.Flat.Encoder.Strict         Data.Flat.Encoder.Types         Data.Flat.Filler-        Data.Flat.Instances         Data.Flat.Memory         Data.Flat.Run         Data.Flat.Types         Data.Flat         Data.FloatCast         Data.ZigZag-    other-modules: System.Endian                  +        Data.Flat.Instances+        Data.Flat.Endian                  +     build-depends:-                  array >= 0.5.1.0 && <0.6,-                  base >=4.8 && <5,-                  bytestring>=0.10.6.0 && < 0.11,-                  containers == 0.5.*,-                  deepseq == 1.4.*,-                  dlist >=0.6 && <0.9,-                  ghc-prim,-                  mono-traversable >=0.10.0.2 && <1.1,-                  pretty >= 1.1.2 && < 1.2,-                  primitive,-                  text,-                  vector+        base >=4.8 && <5+        , bytestring>=0.10.6+        , deepseq >= 1.4+        , ghc-prim+        , primitive+        , text+        , array >= 0.5.1.0+        , dlist >= 0.6+        , vector+        , pretty >= 1.1.2+        +        -- Required by Data.Flat.Instances+        , containers+        , mono-traversable>=0.10.0.2+     if impl(ghc < 8.0)       build-depends: semigroups      default-language: Haskell2010-    default-extensions: CPP     other-extensions: DataKinds DefaultSignatures DeriveAnyClass                       DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable                       FlexibleContexts FlexibleInstances NoMonomorphismRestriction                       OverloadedStrings PolyKinds ScopedTypeVariables TupleSections                       TypeFamilies TypeOperators UndecidableInstances     hs-source-dirs: src-    ghc-options: -O2 -funbox-strict-fields -Wall -fno-warn-orphans -fno-warn-name-shadowing+    ghc-options: -Wall -O2 -funbox-strict-fields -fno-warn-orphans -fno-warn-name-shadowing +-- Full test suite test-suite spec     type: exitcode-stdio-1.0     main-is: Spec.hs     build-depends:-                  base >=4.8 && <5+                  base                 , ghc-prim-                , tasty >= 0.11-                , tasty-hunit >= 0.8-                , tasty-quickcheck >=0.8.1-                , containers == 0.5.*+                , tasty +                -- >= 1+                , tasty-hunit +                -- >= 0.8+                , tasty-quickcheck +                -- >=0.9+                , containers                 , deepseq == 1.4.*-                , quickcheck-instances>=0.3.12+                , QuickCheck >= 2.10                 , text                 , bytestring+                , array                 , flat      default-language: Haskell2010     hs-source-dirs: test-    cpp-options: -DLIST_BIT+    cpp-options: -DLIST_BIT +    -- Add large data types test+    -- cpp-options: -DENUM_LARGE+    -- Add low level decoding test  +    -- cpp-options: -DTEST_DECBITS     other-modules:         Test.Data         Test.Data2+        Test.E+        Test.E.Flat+        Test.E.Arbitrary         Test.Data.Arbitrary         Test.Data.Flat         Test.Data2.Flat         Test.Data.Values-    -- if impl(eta)-    --    cpp-options: -DETA_COMPILER -test-suite docs-  default-language:   Haskell2010-  type:               exitcode-stdio-1.0-  main-is:            DocSpec.hs-  build-depends:      base, doctest>=0.11.2 && <0.16,filemanip>=0.3.6.3 && < 0.3.7-  HS-Source-Dirs:     test---- executable qtest+-- Tests embedded in code documentation (won't compile with ghcjs)+-- test-suite docs --   default-language:   Haskell2010---   main-is:             Test.hs---   hs-source-dirs:      test---   build-depends:      base,  flat, time- +--   type:               exitcode-stdio-1.0+--   main-is:            DocSpec.hs+--   build-depends:      base, doctest>=0.11.2,filemanip>=0.3.6.3+--   HS-Source-Dirs:     test++-- Simple benchmark (won't compile with ghcjs)+-- benchmark sbench+--     main-is: Mini.hs+--     type: exitcode-stdio-1.0+--     default-language:   Haskell2010+--     build-depends:+--         base+--         , deepseq+--         ,criterion+--         ,bytestring,text,containers,process,filepath,statistics,directory+--         -- ,timeit+--         ,flat+--     hs-source-dirs: benchmarks test+--     ghc-options: -O2 -dumpdir /tmp/dump -ddump-to-file -dsuppress-all -ddump-simpl -fprint-potential-instances+--     -- cpp-options: -DENUM_LARGE+--     other-modules:+--         Test.E,Test.Data,Test.Data.Flat,Test.Data.Values,Test.Data2,Test.Data2.Flat,Test.E.Flat,Report

@@ -1,6 +1,9 @@ module Data.Flat (-    -- |Check the <https://github.com/tittoassini/flat tutorial and github repo>.-    module X,+    -- |Check the <https://github.com/Quid2/flat tutorial and github repo>.+    module Data.Flat.Class,+    module Data.Flat.Filler,+    module Data.Flat.Instances,+    module Data.Flat.Run,     UTF8Text(..),     UTF16Text(..),     Get,@@ -8,9 +11,9 @@     DecodeException,     ) where -import           Data.Flat.Class     as X+import           Data.Flat.Class import           Data.Flat.Decoder-import           Data.Flat.Filler    as X-import           Data.Flat.Instances as X-import           Data.Flat.Run       as X+import           Data.Flat.Filler+import           Data.Flat.Instances+import           Data.Flat.Run import           Data.Flat.Types

@@ -1,15 +1,14 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE DefaultSignatures         #-}-{-# LANGUAGE DeriveGeneric             #-}-{-# LANGUAGE EmptyCase                 #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE KindSignatures            #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE StandaloneDeriving        #-} {-# LANGUAGE Trustworthy               #-} {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE TypeOperators             #-}@@ -17,149 +16,124 @@ {-# LANGUAGE UndecidableInstances      #-}  -- |Generics-based generation of Flat instances-module Data.Flat.Class (+module Data.Flat.Class+  (   -- * The Flat class-  Flat(..)-  ,getSize-  ,module GHC.Generics-  ) where+    Flat(..)+  , getSize+  , module GHC.Generics+  )+where -import           Data.Flat.Decoder (Get, dBool)+import           Data.Bits+import           Data.Flat.Decoder import           Data.Flat.Encoder-import           Data.Proxy+import           Data.Word import           GHC.Generics import           GHC.TypeLits import           Prelude           hiding (mempty)--- import GHC.Magic(inline) +-- External and Internal inlining+#define INL 2+-- Internal inlining+-- #define INL 1+-- No inlining+-- #define INL 0++#if INL == 1+import           GHC.Exts          (inline)+#endif++-- import           Data.Proxy++-- $setup+-- >>> {-# LANGUAGE DataKinds                 #-}+-- >>> import           Data.Proxy++-- |Calculate the maximum size in bits of the serialisation of the value+getSize :: Flat a => a -> NumBits+getSize a = size a 0+ -- |Class of types that can be encoded/decoded class Flat a where--    {-# INLINE encode #-}     encode :: a -> Encoding     default encode :: (Generic a, GEncode (Rep a)) => a -> Encoding-    encode = genericEncode+    encode = gencode . from -    {-# INLINE decode #-}     decode :: Get a     default decode :: (Generic a, GDecode (Rep a)) => Get a-    decode = genericDecode+    decode = to `fmap` gget -    {-# INLINE size #-}     size :: a -> NumBits -> NumBits     default size :: (Generic a, GSize (Rep a)) => a -> NumBits -> NumBits-    size = genericSize--{-# INLINE genericEncode #-}-genericEncode :: (GEncode (Rep a), Generic a) => a -> Encoding-genericEncode = gencode . from--{-# INLINE genericDecode #-}-genericDecode :: (GDecode (Rep b), Generic b) => Get b-genericDecode = to `fmap` gget--{-# INLINE genericSize #-}-genericSize :: (GSize (Rep a), Generic a) => a -> NumBits -> NumBits-genericSize !x !n = gsize n $ from x+    size !x !n = gsize n $ from x --- |Calculate the size in bits of the serialisation of the value-getSize :: Flat a => a -> NumBits-getSize a = size a 0+#if INL>=2+    -- With these, generated code is optimised for specific data types (e.g.: Tree Bool will fuse the code of Tree and Bool)+    -- This can improve performance very significantly (up to 10X) but also increases compilation times.+    {-# INLINE size #-}+    {-# INLINE decode #-}+    {-# INLINE encode #-}+#elif INL == 1+#elif INL == 0+    {-# NOINLINE size #-}+    {-# NOINLINE decode #-}+    {-# NOINLINE encode #-}+#endif --- |Generic Encoder-class GEncode f where-  gencode :: f t -> Encoding+-- Generic Encoder+class GEncode f where gencode :: f a -> Encoding --- Metadata (constructor name, etc)-instance {-# OVERLAPPABLE #-} GEncode a => GEncode (M1 i c a) where-  gencode = gencode . unM1-  {-# INLINE  gencode #-}+instance {-# OVERLAPPABLE #-} GEncode f => GEncode (M1 i c f) where+      gencode = gencode . unM1+      {-# INLINE gencode #-} --- Special case, single constructor datatype-instance {-# OVERLAPPING #-} (GEncoders a) => GEncode (D1 i (C1 c a)) where-  gencode !x = encodersS $ gencoders x id []-  {-# INLINE  gencode #-}+  -- Special case, single constructor datatype+instance {-# OVERLAPPING #-} GEncode a => GEncode (D1 i (C1 c a)) where+      gencode = gencode . unM1 . unM1+      {-# INLINE gencode #-} --- Type without constructors+  -- Type without constructors instance GEncode V1 where-  gencode _ = unused-  {-# INLINE  gencode #-}+      gencode = unused+      {-# INLINE gencode #-} --- Constructor without arguments+  -- Constructor without arguments instance GEncode U1 where-  gencode U1 = mempty-  {-# INLINE  gencode #-}---- Product: constructor with parameters-instance GEncode (a :*: b) where-  gencode _ = unused-  {-# INLINE gencode #-}+      gencode U1 = mempty+      {-# INLINE gencode #-} --- Constants, additional parameters, and rank-1 recursion instance Flat a => GEncode (K1 i a) where-  --gencode = inline encode . unK1-  gencode = encode . unK1-  {-# INLINE gencode #-}---- Build constructor representation as single tag-instance (NumConstructors (a :+: b) <= 255, GEncodeSum 0 0 (a :+: b)) => GEncode (a :+: b) where-  gencode x = gencodeSum x (Proxy :: Proxy 0) (Proxy :: Proxy 0)-  {-# INLINE gencode #-}---class GEncoders f where-  -- |Determine the list of encoders corresponding to a type-  gencoders :: f t -> ([Encoding] -> [Encoding]) -> ([Encoding] -> [Encoding])--instance {-# OVERLAPPABLE #-} GEncoders a => GEncoders (M1 i c a) where-    gencoders m !l = gencoders (unM1 m) l-    {-# INLINE gencoders #-}--instance {-# OVERLAPPING #-} GEncoders a => GEncoders (D1 i (C1 c a)) where-    gencoders x !l = gencoders (unM1 . unM1 $ x) l-    {-# INLINE gencoders #-}---- Type without constructors-instance GEncoders V1 where-    gencoders _ _ = unused---- Constructor without arguments-instance GEncoders U1 where-    gencoders U1 !l = l-    {-# INLINE gencoders #-}---- Constants, additional parameters, and rank-1 recursion-instance Flat a => GEncoders (K1 i a) where-  gencoders k !l = l . (gencode k :)-  {-# INLINE gencoders #-}+      {-# INLINE gencode #-}+#if INL == 1+      gencode x = inline encode (unK1 x)+#else+      gencode = encode . unK1+#endif --- Product: constructor with parameters-instance (GEncoders a, GEncoders b) => GEncoders (a :*: b) where-  gencoders (x :*: y) !l = gencoders y (gencoders x l)-  {-# INLINE gencoders #-}+instance (GEncode a, GEncode b) => GEncode (a :*: b) where+      --gencode (!x :*: (!y)) = gencode x <++> gencode y+      gencode (x :*: y) = gencode x <> gencode y+      {-# INLINE gencode #-} -class (KnownNat code, KnownNat numBits) =>-      GEncodeSum (numBits:: Nat) (code :: Nat) (f :: * -> *) where-  gencodeSum :: f a -> Proxy numBits -> Proxy code -> Encoding+instance (NumConstructors (a :+: b) <= 512,GEncodeSum (a :+: b)) => GEncode (a :+: b) where+-- instance (GEncodeSum (a :+: b)) => GEncode (a :+: b) where+      gencode = gencodeSum 0 0+      {-# INLINE gencode #-} -instance (GEncodeSum (n+1) (m*2) a,GEncodeSum (n+1) (m*2+1) b, KnownNat n,KnownNat m)-         => GEncodeSum n m (a :+: b) where-    gencodeSum !x _ _ = case x of-                         L1 l -> gencodeSum l (Proxy :: Proxy (n+1)) (Proxy :: Proxy (m*2))-                         R1 r -> gencodeSum r (Proxy :: Proxy (n+1)) (Proxy :: Proxy (m*2+1))-    {-# INLINE gencodeSum #-}+-- Constructor Encoding+class GEncodeSum f where+  gencodeSum :: Word16 -> NumBits -> f a -> Encoding -instance (GEncoders a, KnownNat n,KnownNat m) => GEncodeSum n m (C1 c a) where-    {-# INLINE gencodeSum #-}-    gencodeSum !x _ _  = encodersS $ gencoders x (eBits numBits code:) []-      where-        numBits = fromInteger (natVal (Proxy :: Proxy n))-        code = fromInteger (natVal (Proxy :: Proxy m))+instance (GEncodeSum a, GEncodeSum b) => GEncodeSum (a :+: b) where+  gencodeSum !code !numBits s = case s of+                           L1 !x -> gencodeSum ((code `unsafeShiftL` 1)) (numBits+1) x+                           R1 !x -> gencodeSum ((code `unsafeShiftL` 1) .|. 1) (numBits+1) x+  {-# INLINE  gencodeSum #-} --- |Calculate number of constructors-type family NumConstructors (a :: * -> *) :: Nat where-    NumConstructors (C1 c a) = 1-    NumConstructors (x :+: y) = NumConstructors x + NumConstructors y+instance GEncode a => GEncodeSum (C1 c a) where+  gencodeSum !code !numBits x = eBits16 numBits code <> gencode x+  {-# INLINE  gencodeSum #-}  -- Generic Decoding class GDecode f where@@ -187,20 +161,157 @@  -- Constants, additional parameters, and rank-1 recursion instance Flat a => GDecode (K1 i a) where+#if INL == 1+  gget = K1 <$> inline decode+#else   gget = K1 <$> decode+#endif   {-# INLINE gget #-} --- Build constructor representation as single tag-instance (GDecode a, GDecode b) => GDecode (a :+: b) where++-- Different valid decoding setups+-- #define DEC_BOOLG+-- #define DEC_BOOL++-- #define DEC_BOOLG+-- #define DEC_BOOL+-- #define DEC_BOOL48++-- #define DEC_CONS+-- #define DEC_BOOLC+-- #define DEC_BOOL++-- #define DEC_CONS+-- #define DEC_BOOLC+-- #define DEC_BOOL+-- #define DEC_BOOL48++-- #define DEC_CONS++-- #define DEC_CONS+-- #define DEC_CONS48++#define DEC_CONS+#define DEC_CONS48+#define DEC_BOOLC+#define DEC_BOOL++#ifdef DEC_BOOLG+instance (GDecode a, GDecode b) => GDecode (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)+#endif++#ifdef DEC_BOOL+  where+      gget = do+        -- error "DECODE2_C2"+        !tag <- dBool+        !r <- if tag then R1 <$> gget else L1 <$> gget+        return r+      {-# INLINE gget #-}+#endif++#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   gget = do-    !tag <- dBool-    !r <- if tag then R1 <$> gget else L1 <$> gget-    return r+    cs <- consOpen+    getSum cs   {-# INLINE gget #-} --- |Calculate the size of a value in bits+-- Constructor Decoder+class GDecodeSum 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+      where+          getSum cs = do+            -- error "DECODE4"+            let (cs',tag) = consBits cs 2+            case tag of+              0 -> L1 . L1 <$> getSum cs'+              1 -> L1 . R1 <$> getSum cs'+              2 -> R1 . L1 <$> getSum cs'+              _ -> 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+     where+      getSum cs = do+        --error "DECODE8"+        let (cs',tag) = consBits cs 3+        case tag of+          0 -> L1 . L1 . L1 <$> getSum cs'+          1 -> L1 . L1 . R1 <$> getSum cs'+          2 -> L1 . R1 . L1 <$> getSum cs'+          3 -> L1 . R1 . R1 <$> getSum cs'+          4 -> R1 . L1 . L1 <$> getSum cs'+          5 -> R1 . L1 . R1 <$> getSum cs'+          6 -> R1 . R1 . L1 <$> getSum cs'+          _ -> R1 . R1 . R1 <$> getSum cs'+      {-# INLINE getSum #-}++instance {-# OVERLAPPABLE #-} (GDecodeSum a, GDecodeSum b) => GDecodeSum (a :+: b) where+#else+instance (GDecodeSum a, GDecodeSum b) => GDecodeSum (a :+: b) where+#endif++  getSum cs = do+    let (cs',tag) = consBool cs+    if tag then R1 <$> getSum cs' else L1 <$> getSum cs'+  {-# INLINE getSum #-}+++instance GDecode a => GDecodeSum (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+  where+      gget = do+        -- error "DECODE4"+        !tag <- dBEBits8 2+        case tag of+          0 -> L1 <$> L1 <$> gget+          1 -> L1 <$> R1 <$> gget+          2 -> R1 <$> L1 <$> gget+          _ -> 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+ where+  gget = do+    --error "DECODE8"+    !tag <- dBEBits8 3+    case tag of+      0 -> L1 <$> L1 <$> L1 <$> gget+      1 -> L1 <$> L1 <$> R1 <$> gget+      2 -> L1 <$> R1 <$> L1 <$> gget+      3 -> L1 <$> R1 <$> R1 <$> gget+      4 -> R1 <$> L1 <$> L1 <$> gget+      5 -> R1 <$> L1 <$> R1 <$> gget+      6 -> R1 <$> R1 <$> L1 <$> gget+      _ -> R1 <$> R1 <$> R1 <$> gget+  {-# INLINE gget #-}+#endif++-- |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 +-- Skip metadata instance GSize f => GSize (M1 i c f) where     gsize !n = gsize n . unM1     {-# INLINE gsize #-}@@ -215,33 +326,128 @@     gsize !n _ = n     {-# INLINE gsize #-} +-- Skip metadata instance Flat a => GSize (K1 i a) where-    gsize !n x = size (unK1 x) n-    {-# INLINE gsize #-}+#if INL == 1+  gsize !n x = inline size (unK1 x) n+#else+  gsize !n x = size (unK1 x) n+#endif+  {-# INLINE gsize #-}  instance (GSize a, GSize b) => GSize (a :*: b) where     gsize !n (x :*: y) = gsize (gsize n x) y     {-# INLINE gsize #-} -instance (NumConstructors (a :+: b) <= 255, GSizeSum 0 (a :+: b)) => GSize (a :+: b) where-    gsize !n x = gsizeSum n x (Proxy :: Proxy 0)-    {-# INLINE gsize #-}+-- Different size implementations+#define SIZ_ADD+-- #define SIZ_NUM --- |Calculate size in bits of constructor-class KnownNat n => GSizeSum (n :: Nat) (f :: * -> *) where gsizeSum :: NumBits -> f a -> Proxy n -> NumBits+-- #define SIZ_MAX+-- #define SIZ_MAX_VAL+-- #define SIZ_MAX_PROX -instance (GSizeSum (n + 1) a, GSizeSum (n + 1) b, KnownNat n)-         => GSizeSum n (a :+: b) where-    gsizeSum !n x _ = case x of-                        L1 !l -> gsizeSum n l (Proxy :: Proxy (n+1))-                        R1 !r -> gsizeSum n r (Proxy :: Proxy (n+1))+#ifdef SIZ_ADD+instance (GSizeSum (a :+: b)) => GSize (a :+: b) where+  gsize !n = gsizeSum n+#endif++#ifdef SIZ_NUM+instance (GSizeSum (a :+: b)) => GSize (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+  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++instance (GSizeMax f, GSizeMax g) => GSizeMax (f :+: g) where+    gsizeMax _ = 1 + max (gsizeMax (undefined::f a )) (gsizeMax (undefined::g a))+    {-# INLINE gsizeMax #-}++instance (GSize a) => GSizeMax (C1 c a) where+    {-# INLINE gsizeMax #-}+    gsizeMax _ = 0+#endif++#ifdef SIZ_MAX_PROX+-- instance (GSizeNxt (a :+: b),GSizeMax (a:+:b)) => GSize (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++-- instance (GSizeMax (n + 1) a, GSizeMax (n + 1) b, KnownNat n) => GSizeMax 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+--     {-# 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+--   gsizeMax :: f a ->  NumBits+--   gsizeMax _ = fromInteger (natVal (Proxy :: Proxy (ConsSize f)))++type family ConsSize (a :: * -> *) :: Nat where+      ConsSize (C1 c a) = 0+      ConsSize (x :+: y) = 1 + Max (ConsSize x) (ConsSize y)++type family Max (n :: Nat) (m :: Nat) :: Nat where+   Max n m  = If (n <=? m) m n++type family If c (t::Nat) (e::Nat) where+    If 'True  t e = t+    If 'False t e = e+#endif++-- Calculate the size of a value, not taking in account its constructor+class GSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a ->  NumBits++instance (GSizeNxt a, GSizeNxt b) => GSizeNxt (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+    {-# 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++instance (GSizeSum a, GSizeSum b)+         => GSizeSum (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, KnownNat n) => GSizeSum n (C1 c a) where+instance (GSize a) => GSizeSum (C1 c a) where     {-# INLINE gsizeSum #-}-    gsizeSum !n !x _ = gsize (constructorSize + n) x-      where-        constructorSize = fromInteger (natVal (Proxy :: Proxy n))+    gsizeSum !n !x = gsize n x+++-- |Calculate number of constructors+type family NumConstructors (a :: * -> *) :: Nat where+  NumConstructors (C1 c a) = 1+  NumConstructors (x :+: y) = NumConstructors x + NumConstructors y+  unused :: forall a . a unused = error $ "Now, now, you could not possibly have meant this.."

@@ -38,8 +38,10 @@     dBEBits32,     dBEBits64,     dropBits,++    ConsState(..),consOpen,consClose,consBool,consBits     ) where -import Data.Flat.Decoder.Prim-import Data.Flat.Decoder.Strict-import Data.Flat.Decoder.Types+import           Data.Flat.Decoder.Prim+import           Data.Flat.Decoder.Strict+import           Data.Flat.Decoder.Types

@@ -1,5 +1,7 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-} -- |Strict Decoder Primitives module Data.Flat.Decoder.Prim (     dBool,@@ -19,18 +21,113 @@     dByteString_,     dLazyByteString_,     dByteArray_,++    ConsState(..),consOpen,consClose,consBool,consBits     ) where  import           Control.Monad import qualified Data.ByteString         as B import qualified Data.ByteString.Lazy    as L import           Data.Flat.Decoder.Types+import           Data.Flat.Endian import           Data.Flat.Memory import           Data.FloatCast import           Data.Word import           Foreign-import           System.Endian +-- $setup+-- >>> :set -XBinaryLiterals+-- >>> import Data.Flat.Run++-- |A special state, optimised for constructor decoding, consists of:+-- The bits to parse, top bit being the first to parse (could use a Word16 instead, no difference in performance)+-- The number of decoded bits+-- Supports up to 512 constructors (9 bits)+data ConsState =+  ConsState {-# UNPACK #-} !Word !Int++-- |Switch to constructor decoding+-- {-# INLINE consOpen  #-}+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+  return $ GetResult s (ConsState w 0)++-- |Switch back to normal decoding+-- {-# NOINLINE consClose  #-}+consClose :: Int -> Get ()+consClose n =  Get $ \endPtr s -> do+  let u' = n+usedBits s+  if u' < 8+     then return $ GetResult (s {usedBits=u'}) ()+     else if currPtr s >= endPtr+            then notEnoughSpace endPtr s+          else return $ GetResult (s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}) ()++  {- ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s+  dropBits8 s n =+    let u' = n+usedBits s+    in if u' < 8+        then s {usedBits=u'}+        else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}+  -}++  --ensureBits endPtr s n+  --return $ GetResult (dropBits8 s n) ()++-- |Decode a single bit+consBool :: ConsState -> (ConsState,Bool)+consBool cs =  (0/=) <$> consBits cs 1++-- consBool (ConsState w usedBits) = (ConsState (w `unsafeShiftL` 1) (1+usedBits),0 /= 32768 .&. w)++-- |Decode from 1 to 3 bits+-- This 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+consBits cs 2 = consBits_ cs 2 3+consBits cs 1 = consBits_ cs 1 1+consBits _  _ = error "unsupported"++consBits_ :: ConsState -> Int -> Word -> (ConsState, Word)++-- Different decoding primitives+-- All with equivalent performance+-- #define CONS_ROT+-- #define CONS_SHL+#define CONS_STA++#ifdef CONS_ROT+consBits_ (ConsState w usedBits) numBits mask =+  let usedBits' = numBits+usedBits+      w' = w `rotateL` numBits -- compiles to an or+shiftl+shiftr+  in (ConsState w' usedBits',w' .&. mask)+#endif++#ifdef CONS_SHL+consBits_ (ConsState w usedBits) numBits mask =+  let usedBits' = numBits+usedBits+      w' = w `unsafeShiftL` numBits+  in (ConsState w' usedBits', (w `shR` (wordSize - numBits)) .&. mask)+#endif++#ifdef CONS_STA+consBits_ (ConsState w usedBits) numBits mask =+  let usedBits' = numBits+usedBits+  in (ConsState w usedBits', (w `shR` (wordSize - usedBits')) .&. mask)+#endif++wordSize :: Int+wordSize = finiteBitSize (0 :: Word)+ {-# INLINE ensureBits #-} -- |Ensure that the specified number of bits is available ensureBits :: Ptr Word8 -> S -> Int -> IO ()@@ -46,11 +143,18 @@   | n == 0 = return ()   | otherwise = error $ unwords ["dropBits",show n] +{-# INLINE dropBits_ #-} dropBits_ :: S -> Int -> S-dropBits_ s n = let (bytes,bits) = (n+usedBits s) `divMod` 8-                in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}+dropBits_ s n =+  let (bytes,bits) = (n+usedBits s) `divMod` 8+  -- let+  --   n' = n+usedBits s+  --   bytes = n' `shR` 3+  --   bits = n' .|. 7+  in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}  {-# INLINE dBool #-}+-- {-# INLINE dBool #-} -- INLINE Massively increases compilation time and decreases run time by a third -- |Decode a boolean dBool :: Get Bool dBool = Get $ \endPtr s ->@@ -58,19 +162,19 @@     then notEnoughSpace endPtr s     else do       !w <- peek (currPtr s)-      let !b = 0 /= (w .&. (128 `shiftR` usedBits s))-      -- let b = testBit w (7-usedBits s)+      let !b = 0 /= (w .&. (128 `shR` usedBits s))       let !s' = if usedBits s == 7                   then s { currPtr = currPtr s `plusPtr` 1, usedBits = 0 }                   else s { usedBits = usedBits s + 1 }       return $ GetResult s' b + {-# INLINE dBEBits8  #-} -- |Return the n most significant bits (up to maximum of 8) -- -- The bits are returned right shifted:------ unflatWith (dBEBits8 3) [128+64+32+1::Word8] == Right 7+-- >>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111+-- True dBEBits8 :: Int -> Get Word8 dBEBits8 n = Get $ \endPtr s -> do       ensureBits endPtr s n@@ -109,31 +213,41 @@ --   | n <= 8 - usedBits s = do --       w <- peek (currPtr s) --       let (bytes,bits) = (n+usedBits s) `divMod` 8---       return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) ((w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n))+--       return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) ((w `unsafeShiftL` usedBits s) `shR` (8 - n))  --   -- two different bytes --   | n <= 8 = do --       w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)---       return $ GetResult (S {currPtr=currPtr s `plusPtr` 1,usedBits=(usedBits s + n) `mod` 8}) (fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n))+--       return $ GetResult (S {currPtr=currPtr s `plusPtr` 1,usedBits=(usedBits s + n) `mod` 8}) (fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n))  --   | otherwise = error $ unwords ["take8: cannot take",show n,"bits"]  {-# INLINE take8 #-} take8 :: S -> Int -> IO (GetResult Word8)-take8 s n = GetResult (dropBits_ s n) <$> read8 s n--{-# INLINE read8 #-}-read8 :: S -> Int -> IO Word8-read8 s n | n >=0 && n <=8 =+-- take8 s n = GetResult (dropBits_ s n) <$> read8 s n+take8 s n = GetResult (dropBits8 s n) <$> read8 s n+  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) `unsafeShiftR` (8 - n)+              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) `unsafeShiftR` (16 - n)+              return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)           | otherwise = error $ unwords ["read8: cannot read",show n,"bits"]+    -- {-# INLINE dropBits8 #-}+    -- -- Assume n <= 8+    dropBits8 :: S -> Int -> S+    dropBits8 s n =+      let u' = n+usedBits s+      in if u' < 8+          then s {usedBits=u'}+          else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8} + {-# INLINE takeN #-} takeN :: (Num a, Bits a) => Int -> S -> IO (GetResult a) takeN n s = read s 0 (n - (n `min` 8)) n@@ -150,15 +264,15 @@ --   r <- case bytes of --     0 -> do --       w <- peek (currPtr s)---       return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n))+--       return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `shR` (8 - n)) --     1 -> do --       w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)---       return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n)+--       return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n) --     2 -> do --       let r = 0 --       w1 <- fromIntegral <$> r8 s --       w2 <- fromIntegral <$> r16 s---       w1 +--       w1 --   return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) r  -- r8 s = peek (currPtr s)@@ -178,7 +292,7 @@             then return w1             else do                    !w2 <- peek (currPtr s `plusPtr` 1)-                   return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `unsafeShiftR` (8-usedBits s))+                   return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `shR` (8-usedBits s))       return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w  {-# INLINE dBE16 #-}@@ -191,7 +305,7 @@         then return w1         else do            !(w2::Word8) <- peek (currPtr s `plusPtr` 2)-           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))   return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w  {-# INLINE dBE32 #-}@@ -204,7 +318,7 @@         then return w1         else do            !(w2::Word8) <- peek (currPtr s `plusPtr` 4)-           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))   return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w  {-# INLINE dBE64 #-}@@ -212,13 +326,18 @@ dBE64 :: Get Word64 dBE64 = Get $ \endPtr s -> do   ensureBits endPtr s 64-  !w1 <- toBE64 <$> peek (castPtr $ currPtr s)+  -- !w1 <- toBE64 <$> peek (castPtr $ currPtr s)+  !w1 <- toBE64 <$> peek64 (castPtr $ currPtr s)   !w <- if usedBits s == 0         then return w1         else do            !(w2::Word8) <- peek (currPtr s `plusPtr` 8)-           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))   return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) w+    where+      -- {-# INLINE peek64 #-}+      peek64 :: Ptr Word64 -> IO Word64+      peek64 ptr = fix64 <$> peek ptr  {-# INLINE dFloat #-} -- |Decode a Float@@ -259,3 +378,14 @@    when (usedBits s /=0) $ badEncoding endPtr s "usedBits /= 0"    (currPtr',ns) <- getChunks (currPtr s) id    return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns)++-- Fix for ghcjs bug:  https://github.com/ghcjs/ghcjs/issues/706+-- TODO: verify if actually needed here and if also needed in encoder+{-# INLINE shR #-}+shR :: Bits a => a -> Int -> a+#ifdef ghcjs_HOST_OS+shR val 0 = val+shR val n = shift val (-n)+#else+shR = unsafeShiftR+#endif

@@ -59,7 +59,14 @@                         Ptr Word8 -- End Ptr                         -> S                         -> IO (GetResult a)-                    } deriving (Functor)+                    } -- deriving (Functor)++-- Seems to give better performance than the derived version                    +instance Functor Get where+    fmap f g = Get $ \end s -> do+        GetResult s' a <- runGet g end s+        return $ GetResult s' (f a) +    {-# INLINE  fmap #-}  -- Is this correct? instance NFData (Get a) where rnf !_ = ()

@@ -16,6 +16,7 @@     eWord64,     eWord8,     eBits,+    eBits16,     eFiller,     eBool,     eTrue,

@@ -7,6 +7,7 @@ {-# LANGUAGE UnboxedTuples       #-} -- |Encoding Primitives module Data.Flat.Encoder.Prim (+    eBits16F,     eBitsF,     eFloatF,     eDoubleF,@@ -34,6 +35,8 @@     eFalseF,     varWordF,     w7l,+    -- * Exported for testing only+    eWord32BEF,eWord64BEF,eWord32E,eWord64E     ) where  import           Control.Monad@@ -43,6 +46,7 @@ import qualified Data.ByteString.Short.Internal as SBS import           Data.Char import           Data.Flat.Encoder.Types+import           Data.Flat.Endian import           Data.Flat.Memory import           Data.Flat.Types import           Data.FloatCast@@ -53,7 +57,6 @@ import qualified Data.Text.Internal             as T import           Data.ZigZag import           Foreign-import           System.Endian  -- import Debug.Trace #include "MachDeps.h"@@ -128,7 +131,7 @@  w7l :: (Bits t, Integral t) => t -> [Word8] w7l t = let l  = low7 t-            t' = t `shiftR` 7+            t' = t `unsafeShiftR` 7         in if t' == 0            then [l]            else w7 l : w7l t'@@ -153,12 +156,12 @@ {-# INLINE eWord32E #-} eWord32E :: (Word32 -> Word32) -> Word32 -> Prim eWord32E conv t (S op w o) | o==0 = pokeW conv op t >> skipBytes op 4-                           | otherwise = pokeW conv op (fromIntegral w `shiftL` 24 .|. t `shiftR` o) >> return (S (plusPtr op 4) (fromIntegral t `shiftL` (8-o)) o)+                           | otherwise = pokeW conv op (asWord32 w `unsafeShiftL` 24 .|. t `unsafeShiftR` o) >> return (S (plusPtr op 4) (asWord8 t `unsafeShiftL` (8-o)) o)  {-# INLINE eWord64E #-} eWord64E :: (Word64 -> Word64) -> Word64 -> Prim-eWord64E conv t (S op w o) | o==0 = pokeW conv op t >> skipBytes op 8-                           | otherwise = pokeW conv op (fromIntegral w `shiftL` 56 .|. t `shiftR` o) >> return (S (plusPtr op 8) (fromIntegral t `shiftL` (8-o)) o)+eWord64E conv t (S op w o) | o==0 = poke64 conv op t >> skipBytes op 8+                           | otherwise = poke64 conv op (asWord64 w `unsafeShiftL` 56 .|. t `unsafeShiftR` o) >> return (S (plusPtr op 8) (asWord8 t `unsafeShiftL` (8-o)) o)  {-# INLINE eWord16F #-} eWord16F :: Word16 -> Prim@@ -187,10 +190,10 @@     where       {-# INLINE varWord2_ #-}       -- TODO: optimise, using a single Write16?-      varWord2_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `shiftR` 7) .&. 0x7F)+      varWord2_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `unsafeShiftR` 7) .&. 0x7F)        {-# INLINE varWord3_ #-}-      varWord3_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `shiftR` 7) .|. 0x80) >>= writeByte (fromIntegral (t `shiftR` 14) .&. 0x7F)+      varWord3_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `unsafeShiftR` 7) .|. 0x80) >>= writeByte (fromIntegral (t `unsafeShiftR` 14) .&. 0x7F)  -- {-# INLINE varWordN #-} varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim@@ -198,7 +201,7 @@   where     go !v !st =       let !l  = low7 v-          !v' = v `shiftR` 7+          !v' = v `unsafeShiftR` 7       in if v' == 0       then writeByte l st       else writeByte (l .|. 0x80) st >>= go v'@@ -254,6 +257,25 @@       pokeWord op' 0  +-- |Encode up to 9 bits+{-# INLINE  eBits16F #-}+eBits16F :: NumBits -> Word16 -> Prim+--eBits16F numBits code | numBits >8 = eBitsF (numBits-8) (fromIntegral $ code `unsafeShiftR` 8) >=> eBitsF 8 (fromIntegral code)+-- eBits16F _ _ = eFalseF+eBits16F       9 code = eBitsF 1 (fromIntegral $ code `unsafeShiftR` 8) >=> eBitsF_ 8 (fromIntegral code)+eBits16F numBits code = eBitsF numBits (fromIntegral code)++-- |Encode up to 8 bits.+{-# INLINE eBitsF #-}+eBitsF :: NumBits -> Word8 -> Prim+eBitsF 1 0 = eFalseF+eBitsF 1 1 = eTrueF+eBitsF 2 0 = eFalseF >=> eFalseF+eBitsF 2 1 = eFalseF >=> eTrueF+eBitsF 2 2 = eTrueF >=> eFalseF+eBitsF 2 3 = eTrueF >=> eTrueF+eBitsF n t = eBitsF_ n t+ {- eBits Example: Before:@@ -278,24 +300,17 @@ o''=3 8-o''=5 -}--- CHECK: might get rid of this altogether and in Class encode in terms of eTrue/eFalse only--- |Encode up to 8 bits.-{-# INLINE eBitsF #-}-eBitsF :: NumBits -> Word8 -> Prim-eBitsF 1 0 = eFalseF-eBitsF 1 1 = eTrueF-eBitsF 2 0 = eFalseF >=> eFalseF-eBitsF 2 1 = eFalseF >=> eTrueF-eBitsF 2 2 = eTrueF >=> eFalseF-eBitsF 2 3 = eTrueF >=> eTrueF-eBitsF n t = \(S op w o) ->+-- {-# NOINLINE eBitsF_ #-}+eBitsF_ :: NumBits -> Word8 -> Prim+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 `shiftL` f)) o'+  in if | f > 0  ->  return $ S op (w .|. (t `unsafeShiftL` f)) o'         | f == 0 ->  pokeWord op (w .|. t)         | otherwise -> let o'' = -f-                       in poke op (w .|. (t `shiftR` o'')) >> return (S (plusPtr op 1) (t `shiftL` (8-o'')) o'')+                       in poke op (w .|. (t `unsafeShiftR` o'')) >> return (S (plusPtr op 1) (t `unsafeShiftL` (8-o'')) o'') + {-# INLINE eBoolF #-} eBoolF :: Bool -> Prim eBoolF False = eFalseF@@ -304,7 +319,7 @@ {-# INLINE eTrueF #-} eTrueF :: Prim eTrueF (S op w o) | o == 7 = pokeWord op (w .|. 1)-                  | otherwise = return (S op (setBit w (7-o)) (o+1))+                  | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o+1))  {-# INLINE eFalseF #-} eFalseF :: Prim@@ -322,7 +337,7 @@  {-# INLINE pokeByteUnaligned #-} pokeByteUnaligned :: Word8 -> Prim-pokeByteUnaligned t (S op w o) = poke op (w .|. (t `shiftR` o)) >> return (S (plusPtr op 1) (t `shiftL` (8-o)) o)+pokeByteUnaligned 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@@ -340,6 +355,10 @@ pokeW :: Storable a => (t -> a) -> Ptr a1 -> t -> IO () pokeW conv op t = poke (castPtr op) (conv t) +{-# INLINE poke64 #-}+poke64 :: (t -> Word64) -> Ptr a -> t -> IO ()+poke64 conv op t = poke (castPtr op) (fix64 . conv $ t)+ {-# INLINE skipByte #-} skipByte :: Monad m => Ptr a -> m S skipByte op = return (S (plusPtr op 1) 0 0)@@ -369,3 +388,15 @@     --                           op' <- pokeWord' op (fromIntegral l)     --                           BS.memcpy op' off l     --                           go (op' `plusPtr` l) (off `plusPtr` l) (len-l)++{-# INLINE asWord64 #-}+asWord64 :: Integral a => a -> Word64+asWord64 = fromIntegral++{-# INLINE asWord32 #-}+asWord32 :: Integral a => a -> Word32+asWord32 = fromIntegral++{-# INLINE asWord8 #-}+asWord8 :: Integral a => a -> Word8+asWord8 = fromIntegral

@@ -5,24 +5,23 @@ -- |Strict encoder module Data.Flat.Encoder.Strict where -import qualified Data.ByteString      as B-import qualified Data.ByteString.Lazy as L-import           Data.Flat.Memory+import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as L import           Data.Flat.Encoder.Prim-import qualified Data.Flat.Encoder.Size       as S+import qualified Data.Flat.Encoder.Size  as S import           Data.Flat.Encoder.Types+import           Data.Flat.Memory import           Data.Flat.Types import           Data.Foldable-import           Data.Semigroup -- (Semigroup(..))+import           Data.Semigroup          (Semigroup (..))  -- |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,())+  in  fst $ unsafeCreateUptoN' bufSize $ \ptr -> do+        (S ptr' 0 0) <- op (S ptr 0 0)+        return (ptr' `minusPtr` ptr, ())  newtype Encoding = Encoding { run :: Prim } @@ -55,16 +54,16 @@ {-# NOINLINE encodersS #-} encodersS :: [Encoding] -> Encoding -- without the explicit parameter the rules won't fire-encodersS ws =  foldl' mappend mempty ws+encodersS ws = foldl' mappend mempty ws -- encodersS ws = error $ unwords ["encodersS CALLED",show ws]  {-# INLINE encodeListWith #-} -- |Encode as a List encodeListWith :: (t -> Encoding) -> [t] -> Encoding encodeListWith enc = go-  where-    go []     = eFalse-    go (x:xs) = eTrue <> enc x <> go xs+ where+  go []       = eFalse+  go (x : xs) = eTrue <> enc x <> go xs  -- {-# INLINE encodeList #-} -- encodeList :: (Foldable t, Flat a) => t a -> Encoding@@ -79,18 +78,16 @@ encodeArrayWith :: (t -> Encoding) -> [t] -> Encoding encodeArrayWith _ [] = eWord8 0 encodeArrayWith f ws = Encoding $ go ws-  where-    go l s = do-      s' <- eWord8F 0 s-      (n,s'',l) <- gol l 0 s'-      _ <- eWord8F n s-      if null l-        then eWord8F 0 s''-        else go l s''+ where+  go l s = do+    s'          <- eWord8F 0 s+    (n, s'', l) <- gol l 0 s'+    _           <- eWord8F n s+    if null l then eWord8F 0 s'' else go l s'' -    gol []       !n !s  = return (n,s,[])-    gol l@(x:xs) !n !s | n == 255 = return (255,s,l)-                       | otherwise = run (f x) s >>= gol xs (n+1)+  gol [] !n !s = return (n, s, [])+  gol l@(x : xs) !n !s | n == 255  = return (255, s, l)+                       | otherwise = run (f x) s >>= gol xs (n + 1)  -- Encoding primitives {-# INLINE eChar #-}@@ -127,35 +124,37 @@ eLazyBytes :: L.ByteString -> Encoding eLazyBytes = Encoding . eLazyBytesF eShortBytes :: ShortByteString -> Encoding-eShortBytes = Encoding. eShortBytesF+eShortBytes = Encoding . eShortBytesF eNatural :: Natural -> Encoding-eNatural = Encoding. eNaturalF+eNatural = Encoding . eNaturalF eFloat :: Float -> Encoding eFloat = Encoding . eFloatF eDouble :: Double -> Encoding eDouble = Encoding . eDoubleF eInteger :: Integer -> Encoding-eInteger = Encoding. eIntegerF+eInteger = Encoding . eIntegerF eInt64 :: Int64 -> Encoding-eInt64 = Encoding. eInt64F+eInt64 = Encoding . eInt64F eInt32 :: Int32 -> Encoding-eInt32 = Encoding. eInt32F+eInt32 = Encoding . eInt32F eInt16 :: Int16 -> Encoding-eInt16 = Encoding. eInt16F+eInt16 = Encoding . eInt16F eInt8 :: Int8 -> Encoding eInt8 = Encoding . eInt8F eInt :: Int -> Encoding eInt = Encoding . eIntF eWord64 :: Word64 -> Encoding-eWord64 = Encoding. eWord64F+eWord64 = Encoding . eWord64F eWord32 :: Word32 -> Encoding-eWord32 = Encoding. eWord32F+eWord32 = Encoding . eWord32F eWord16 :: Word16 -> Encoding-eWord16 = Encoding. eWord16F+eWord16 = Encoding . eWord16F eWord8 :: Word8 -> Encoding eWord8 = Encoding . eWord8F eWord :: Word -> Encoding eWord = Encoding . eWordF+eBits16 :: NumBits -> Word16 -> Encoding+eBits16 n f = Encoding $ eBits16F n f eBits :: NumBits -> Word8 -> Encoding eBits n f = Encoding $ eBitsF n f eFiller :: Encoding@@ -177,7 +176,7 @@ -- Constant size {-# INLINE csize #-} csize :: NumBits -> t -> NumBits -> NumBits-csize !n _ !s = n+s+csize !n _ !s = n + s  sChar :: Size Char sChar = vsize S.sChar

@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+-- | Endian utilities+-- Exported for testing purposes, but not meant to be used outside this package.+module Data.Flat.Endian+    (+    toBE32+    , toBE64+    , toBE16+    , isBigEndian+    , fix64+    ) where++#include "MachDeps.h"++import Data.Word++#ifdef ghcjs_HOST_OS+import Data.Bits+#endif++isBigEndian :: Bool+isBigEndian =+#ifdef WORDS_BIGENDIAN+    True+#else+    False+#endif++-- | Convert a 64 bit value in cpu endianess to big endian+toBE64 :: Word64 -> Word64+#ifdef WORDS_BIGENDIAN+toBE64 = id+#else+toBE64 = byteSwap64+#endif++-- | Convert a 32 bit value in cpu endianess to big endian+toBE32 :: Word32 -> Word32+#ifdef WORDS_BIGENDIAN+toBE32 = id+#else+toBE32 = byteSwap32+#endif++-- | Convert a 16 bit value in cpu endianess to big endian+toBE16 :: Word16 -> Word16+#ifdef WORDS_BIGENDIAN+toBE16 = id+#else+toBE16 = byteSwap16+#endif++-- | Fix issue with `ghcjs` (different order of 32 bit halves of 64 values with respect to `ghc`)+fix64 :: Word64 -> Word64+#ifdef ghcjs_HOST_OS+fix64 = (`rotateR` 32)+{-# NOINLINE fix64 #-}+#else+fix64 = id+{-# INLINE fix64 #-}+#endif

@@ -9,14 +9,15 @@ -- {-# LANGUAGE IncoherentInstances    #-}  -- |Flat Instances for common, primitive and abstract data types for which instances cannot be automatically derived-module Data.Flat.Instances (-    sizeMap,-    encodeMap,-    decodeMap,-    sizeSequence,-    encodeSequence,-    decodeSequence,-    ) where+module Data.Flat.Instances+  ( sizeMap+  , encodeMap+  , decodeMap+  , sizeSequence+  , encodeSequence+  , decodeSequence+  )+where  import qualified Data.ByteString       as B import qualified Data.ByteString.Lazy  as L@@ -58,11 +59,12 @@ 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) --- Do not provide this to 'force' users to declare instances of concrete list types+-- Generic list instance. instance {-# OVERLAPPABLE #-} Flat a => Flat [a]-instance {-# OVERLAPPING #-} Flat [Char] --- instance Flat [Char]+-- For better encoding/decoding performance, it is useful to declare instances of concrete list types.+-- As this one for example:+instance {-# OVERLAPPING #-} Flat [Char]  -- Flat instances for primitive/abstract types instance Flat B.ByteString where@@ -175,6 +177,11 @@    encode = encodeMap    decode = decodeMap +-- instance Flat a => Flat (IM.IntMap a) where+--     size = sizeMap+--     encode = encodeMap+--     decode = decodeMap+ instance Flat a => Flat (S.Seq a) where   size = sizeSequence   encode = encodeSequence@@ -183,12 +190,18 @@ -- |Calculate size of an instance of IsMap {-# INLINE sizeMap #-} sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r-sizeMap m acc = F.foldl' (\acc' (k,v) -> size k (size v (acc' + 1))) (acc+1) . mapToList $ m+sizeMap m acc =+  F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1)+    . mapToList+    $ m  {-# INLINE encodeMap #-} -- |Encode an instance of IsMap, as a list-encodeMap :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => map -> Encoding-encodeMap = encodeListWith (\(k,v) -> encode k <> encode v) . mapToList+encodeMap+  :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map)+  => map+  -> Encoding+encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList -- encodeMap = go . mapToList --   where --     go []     = eFalse@@ -196,12 +209,14 @@  {-# INLINE decodeMap #-} -- |Decode an instance of IsMap, as a list-decodeMap :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map+decodeMap+  :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode)  {-# INLINE sizeSequence #-} -- |Calculate size of an instance of IsSequence-sizeSequence :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits+sizeSequence+  :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s)  {-# INLINE encodeSequence #-}

@@ -41,3 +41,4 @@ -- |Encode unpadded value flatRaw :: (Flat a, AsByteString b) => a -> b flatRaw a = fromByteString $ E.strictEncoder (getSize a) (encode a)+

@@ -18,7 +18,6 @@ import           Data.Word import           Numeric.Natural --- ?FIX: Should be Int64 or Word64 -- |Number of bits type NumBits = Int 

@@ -13,12 +13,22 @@   , wordToFloat   , doubleToWord   , wordToDouble-  ) where+  )+where -import Data.Word (Word32, Word64)-import Data.Array.ST (newArray, readArray, MArray, STUArray)-import Data.Array.Unsafe (castSTUArray)-import GHC.ST (runST, ST)+import           Data.Word                      ( Word32+                                                , Word64+                                                )+import           Data.Array.ST                  ( newArray+                                                , readArray+                                                , MArray+                                                , STUArray+                                                )+import           Data.Array.Unsafe              ( castSTUArray )+import           GHC.ST                         ( runST+                                                , ST+                                                )+import           Data.Flat.Endian  -- | Reinterpret-casts a `Float` to a `Word32`. floatToWord :: Float -> Word32@@ -26,8 +36,19 @@ {-# INLINE floatToWord #-}  -- | Reinterpret-casts a `Double` to a `Word64`.+{-|+>>> doubleToWord (-0.15625)+13818169556679524352+-} doubleToWord :: Double -> Word64-doubleToWord x = runST (cast x)+doubleToWord x = fix64 $ runST (cast x)++-- #ifdef ghcjs_HOST_OS+-- doubleToWord x = (`rotateR` 32) $ runST (cast x)+-- #else+-- doubleToWord x = runST (cast x)+-- #endif+ {-# INLINE doubleToWord #-}  -- | Reinterpret-casts a `Word32` to a `Float`.@@ -36,11 +57,17 @@ {-# INLINE wordToFloat #-}  -- | Reinterpret-casts a `Word64` to a `Double`.-wordToDouble :: Word64 -> Double-wordToDouble x = runST (cast x) {-# INLINE wordToDouble #-}+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast $ fix64 x) -cast :: (MArray (STUArray s) a (ST s),-         MArray (STUArray s) b (ST s)) => a -> ST s b+-- #ifdef ghcjs_HOST_OS+-- wordToDouble x = runST (cast $ x `rotateR` 32) +-- #else+-- wordToDouble x = runST (cast x) +-- #endif++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 {-# INLINE cast #-}

@@ -1,35 +0,0 @@-{-# LANGUAGE CPP #-}-module System.Endian-    (-    toBE32-    , toBE64-    , toBE16-    ) where--#include "MachDeps.h"--import Data.Word---- | Convert a 64 bit value in cpu endianess to big endian-toBE64 :: Word64 -> Word64-#ifdef WORDS_BIGENDIAN-toBE64 = id-#else-toBE64 = byteSwap64-#endif---- | Convert a 32 bit value in cpu endianess to big endian-toBE32 :: Word32 -> Word32-#ifdef WORDS_BIGENDIAN-toBE32 = id-#else-toBE32 = byteSwap32-#endif---- | Convert a 16 bit value in cpu endianess to big endian-toBE16 :: Word16 -> Word16-#ifdef WORDS_BIGENDIAN-toBE16 = id-#else-toBE16 = byteSwap16-#endif

@@ -1,3 +1,13 @@-resolver: lts-9.21-#resolver: lts-11.13-#resolver: nightly-2018-06-16+#resolver: lts-9.21+resolver: lts-11.22+#resolver: lts-12.16+# resolver: nightly-2018-11-02++extra-deps:+#- QuickCheck-2.12.6.1@sha256:95b4e3b01033bf7d2ad21d0085266dba378477ac88e3d11ff238fc9db2575e6d+# Required to avoid problem with Natural instance in QuickCheck+- QuickCheck-2.11.3@sha256:e4c56f52532c993fc4460aeac7a2543dc03a68fba36eff420f3294d4d2622416+- tasty-1.1.0.4@sha256:1310ceed449b3227614b329a1672a2c5bb046cb49e281996523567b3b0ad9ecc+- tasty-quickcheck-0.10@sha256:9ddbacf1504bbbc4b99ab447d26651ad8454b69ceced3486e4623dccb89fb3d9+- optparse-applicative-0.14.3.0@sha256:b6b56a922d10911a2824b965750ddc7794de746e347afe67f1a84d05168368dc+- wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3

@@ -1,15 +0,0 @@-module Main where-import           Test.DocTest-import           System.FilePath.Find-import           Data.List                      ( isSuffixOf )--main :: IO ()--- main = find always ((extension ==? ".hs") &&? exceptFiles ["Data/Convertible/Base.hs","Data/Convertible/Utils.hs","Data/Convertible/Instances/Num.hs"]) "src" >>= doctest-main = find always ((extension ==? ".hs") &&? exceptFiles []) "src" >>= doctest--exceptFiles :: Foldable t => t String -> FindClause Bool-exceptFiles mdls =-      -- let excludes = liftOp (\fp mdls -> not $ any (\mdl -> isSuffixOf mdl (traceShowId fp)) mdls)-      let excludes = liftOp-                (\fp modules -> not $ any (`isSuffixOf` fp) modules)-      in  filePath `excludes` mdls

@@ -10,43 +10,65 @@ -- | Tests for the flat module module Main where +import           Control.Monad import           Data.Bits-import qualified Data.ByteString       as B-import qualified Data.ByteString.Lazy  as L-import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString          as B+import qualified Data.ByteString.Lazy     as L+import qualified Data.ByteString.Short    as SBS import           Data.Char import           Data.Either import           Data.Flat import           Data.Flat.Bits import           Data.Flat.Decoder+import qualified Data.Flat.Encoder        as E+import qualified Data.Flat.Encoder.Prim   as E+import qualified Data.Flat.Encoder.Strict as E import           Data.Int import           Data.List-import qualified Data.Map              as M+import qualified Data.Map                 as M import           Data.Ord import           Data.Proxy-import qualified Data.Sequence         as Seq-import qualified Data.Text             as T+import qualified Data.Sequence            as Seq+import qualified Data.Text                as T import           Data.Word import           Numeric.Natural--- import           System.Arch--- import           System.Endian import           System.Exit import           Test.Data import           Test.Data.Arbitrary import           Test.Data.Flat-import           Test.Data.Values+import           Test.Data.Values         hiding (lbs, ns)+import           Test.E+import           Test.E.Arbitrary+import           Test.E.Flat import           Test.Tasty import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck as QC hiding (getSize)+import           Test.Tasty.QuickCheck    as QC hiding (getSize)+-- import           System.Arch+import           Data.Flat.Endian+import           Data.FloatCast +-- instance Flat [Int16]+-- instance Flat [Word8]+-- instance Flat [Bool]+ main = do+-- #ifdef ghcjs_HOST_OS+--   print "GHCJS"+-- #endif+   -- printInfo+   mainTest--- main = mainShow+  -- print $ flatRaw 18446744073709551615::Word64+  -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64)+  -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1)+  -- mainShow+  -- eWord64E id 0b  -- printInfo = do---   print getSystemArch---   print getSystemEndianness+--   print $ "BigEndian: " ++ show isBigEndian+--    print getSystemArch+--    print getSystemEndianness  mainShow = do   mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1..10]@@ -55,14 +77,225 @@ mainTest = defaultMain tests  tests :: TestTree-tests = testGroup "Tests" [properties-                           ,unitTests-                          ]+tests = testGroup "Tests" [+  testPrimitives -properties = testGroup "Properties"+  ,testEncDec++  ,testFlat+ ]++testPrimitives = testGroup "conversion/memory primitives" [+   testEndian+  ,testFloatingConvert+  --,testShifts+  ]++testEncDec = testGroup "encode/decode primitives" [+   testEncodingPrim+  ,testDecodingPrim+#ifdef TEST_DECBITS  +  ,testDecBits+#endif  +  ]++testFlat = testGroup "flat/unflat" [+   testSize+  ,testLargeEnum+  ,testContainers+  ,flatTests+  ,flatUnflatRT+  ]+++-- Data.Flat.Endian tests (to run, need to modify imports and cabal file)+testEndian = testGroup "Endian" [+   conv toBE16 (2^10 + 3)  (2^9+2^8+4)+  ,conv toBE32 (2^18 + 3)  50332672+  ,conv toBE64 (2^34 + 3)  216172782180892672+  ,conv toBE16 0x1234 0x3412+  ,conv toBE32 0x11223344 0x44332211+  ,conv toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301+  ]++testFloatingConvert = testGroup "Floating conversions" [+   conv floatToWord -0.15625 3189768192+  ,conv wordToFloat 3189768192 -0.15625+  ,conv doubleToWord -0.15625 13818169556679524352+  ,conv wordToDouble 13818169556679524352 -0.15625+  ,rt "floatToWord" (prop_float_conv :: RT Float)+  ,rt "doubleToWord" (prop_double_conv :: RT Double)+ ]++-- ghcjs bug on shiftR 0, see: https://github.com/ghcjs/ghcjs/issues/706+testShifts = testGroup "Shifts" $ map tst [0..33]+   where+ tst n = testCase ("shiftR " ++ show n) $+  let val = 4294967295::Word32+      s = val `shift` (-n)+      r = val `shiftR` n+  in r @?= s++-- shR = shiftR+-- shR = unsafeShiftR+shR val 0 = val+shR val n = shift val (-n)++testEncodingPrim = testGroup "Encoding Primitives" [+   encRawWith 1 E.eTrueF [0b10000001]+  ,encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001]++  ,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1]+  ,encRawWith 32 (E.eWord32BEF  $ 2^18 + 3) [0,4,0,3,1]++  ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1]+  ,encRawWith 64 (E.eWord64BEF  $ 2^34 + 3) [0,0,0,4,0,0,0,3,1]+  ,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129]+  ,encRawWith 65 (E.eTrueF >=> E.eWord64BEF (2^34 + 3)) [128,0,0,2,0,0,0,1,129]+  ,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129]+  ,encRawWith 65 (E.eFalseF >=> E.eWord64BEF (2^34 + 3))  [0,0,0,2,0,0,0,1,129]+  ]+  where+    encRawWith sz enc exp = testCase (unwords ["encode raw with size",show sz]) $ flatRawWith sz enc @?= exp+++conv f v e = testCase (unwords ["conv",sshow v,showB . flat $ v,"to",sshow e]) $ f v @?= e++testDecodingPrim = testGroup "Decoding Primitives" [+   dec ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) [0b10111110,0b10011010] ((),False,True,False)+  ,dec ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) [0b11000000+                                                                 ,0b00000001+                                                                 ,0b01000000] ((),2^15+2,True,())+  ,dec ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) [0b11000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000001+                                                                 ,0b01000000] ((),2^31+2,True,())+  ,dec dBE64 [0b10000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000010+                                                                 ] (2^63+2)++  ,dec ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) [0b11000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000000+                                                                 ,0b00000001+                                                                 ,0b01000000] ((),2^63+2,True,())++  ]+    where+      dec decOp v e = testCase (unwords ["decode",sshow v]) $ unflatRawWith decOp (B.pack v) @?= Right e++testDecBits = testGroup "Decode Bits" $ concat [+   decBitsN dBEBits8+  ,decBitsN dBEBits16+  ,decBitsN dBEBits32+  ,decBitsN dBEBits64+ ]+  where+          -- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions+          decBitsN :: forall a. (Num a,FiniteBits a,Show a,Flat a) => (Int -> Get a) -> [TestTree]+          decBitsN dec = let s = finiteBitSize (undefined::a)+                         in [decBits_ dec val numBitsToTake pre | numBitsToTake <- [0 .. s], val <- [0::a ,1+2^(s - 2)+2^(s - 5) ,fromIntegral $ (2^s::Integer) - 1],pre <- [0,1,7]]++          decBits_ :: forall a. (FiniteBits a,Show a,Flat a) => (Int -> Get a) -> a -> Int -> Int -> TestTree+          decBits_ deco val numBitsToTake pre =+            -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary+            let vs = B.pack . asBytes . fromBools $ replicate pre False ++ toBools (asBits val)+                len = B.length vs+                sz = finiteBitSize (undefined::a)+                dec :: Get a+                dec = do+                  dropBits pre+                  r <- deco numBitsToTake+                  dropBits (len*8-numBitsToTake-pre)+                  return r+                -- we expect the first numBitsToTake bits of the value+                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+            in testCase (unwords ["take",show numBitsToTake,"bits from",show val,"of size",show sz,"with prefix",show pre,"sequence",showB vs,show expected,show actual,show $ val == actual,show $ expected == actual,show $ expected /= actual,show $ show expected == show actual,show $ flat expected == flat actual])+                $ actualD @?= expectedD+++testSize = testGroup "Size" $ concat [+  sz () 0+  ,sz True 1+  ,sz One 2+  ,sz Two 2+  ,sz Three 2+  ,sz Four 3+  ,sz Five 3+  ,sz 'a' 8+  ,sz 'à' 16+  ,sz '经' 24+  ,sz (0::Word8) 8+  ,sz (1::Word8) 8+  ,concatMap (uncurry sz) ns+  ,concatMap (uncurry sz) nsI+  ,concatMap (uncurry sz) nsII+  ,sz (1.1::Float) 32+  ,sz (1.1::Double) 64+  ,sz "" 1+  ,sz "abc" (4+3*8)+  ,sz ((),(),Unit) 0+  ,sz (True,False,One,Five) 7+  ,sz map1 7+  ,sz bs (4+3*8)+  ,sz stBS bsSize+  ,sz lzBS bsSize+#ifndef ghcjs_HOST_OS+  ,sz shBS bsSize+#endif+  ,sz tx utf8Size+  ,sz (UTF8Text tx) utf8Size+  ,sz (UTF16Text tx) utf16Size+ ]+   where+    tx = T.pack "txt"+    utf8Size = 8+8+3*32+8+    utf16Size = 8+8+3*16+8+    bsSize = 8+8+3*8+8++sz v e = [testCase (unwords ["size of",sshow v]) $ getSize v @?= e]++-- E258_256 = 11111110 _257 = 111111110 _258 = 111111111+testLargeEnum = testGroup "test enum with more than 256 constructors" $ concat+  [+#ifdef ENUM_LARGE+      sz E258_256 8+    , sz E258_257 9+    , sz E258_258 9++    -- As encode are inlined, this is going to take for ever if this is compiled with -O1 or -O2+    -- , encRaw (E258_256) [0b11111110]+    -- , encRaw (E258_257) [0b11111111,0b00000000]+    -- , encRaw (E258_258) [0b11111111,0b10000000]+    -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000]++    , map trip [E258_1,E258_256,E258_257,E258_258]+    , map trip [E256_1,E256_134,E256_256]+#endif+  ]++testContainers = testGroup "containers" [+    trip longSeq+    , trip dataMap+    , trip listMap+    -- , trip intMap+    ]++flatUnflatRT = testGroup "unflat (flat v) == v"   [  rt "()" (prop_Flat_roundtrip:: RT ())     ,rt "Bool" (prop_Flat_roundtrip::RT Bool)-    ,rt "(Bool,Word8,Bool)" (prop_Flat_roundtrip:: RT (Bool,Word8,Bool))     ,rt "Word8" (prop_Flat_Large_roundtrip:: RTL Word8)     ,rt "Word16" (prop_Flat_Large_roundtrip:: RTL Word16)     ,rt "Word32" (prop_Flat_Large_roundtrip:: RTL Word32)@@ -75,17 +308,20 @@     ,rt "Int" (prop_Flat_Large_roundtrip:: RTL Int)     ,rt "Integer" (prop_Flat_roundtrip:: RT Integer)     ,rt "Natural" (prop_Flat_roundtrip:: RT Natural)-    ,rt "(Bool,Integer)" (prop_Flat_roundtrip:: RT (Bool,Integer))     ,rt "Float" (prop_Flat_roundtrip:: RT Float)-    ,rt "(Bool,Float)" (prop_Flat_roundtrip:: RT (Bool,Float))     ,rt "Double" (prop_Flat_roundtrip:: RT Double)-    ,rt "(Bool,Double)" (prop_Flat_roundtrip:: RT (Bool,Double))     ,rt "Char" (prop_Flat_roundtrip:: RT Char)-    ,rt "(Bool,Char)" (prop_Flat_roundtrip:: RT (Bool,Char))     --,rt "ASCII" (prop_Flat_roundtrip:: RT ASCII)     ,rt "Unit" (prop_Flat_roundtrip:: RT Unit)     ,rt "Un" (prop_Flat_roundtrip:: RT Un )     ,rt "N" (prop_Flat_roundtrip:: RT N )+    ,rt "E2" (prop_Flat_roundtrip:: RT E2 )+    ,rt "E3" (prop_Flat_roundtrip:: RT E3 )+    ,rt "E4" (prop_Flat_roundtrip:: RT E4 )+    ,rt "E8" (prop_Flat_roundtrip:: RT E8 )+    ,rt "E16" (prop_Flat_roundtrip:: RT E16 )+    ,rt "E17" (prop_Flat_roundtrip:: RT E17 )+    ,rt "E32" (prop_Flat_roundtrip:: RT E32 )     ,rt "A" (prop_Flat_roundtrip:: RT A )     ,rt "B" (prop_Flat_roundtrip:: RT B )     ,rt "Maybe N" (prop_Flat_roundtrip:: RT (Maybe N))@@ -100,50 +336,23 @@     ,rt "Text" (prop_Flat_roundtrip:: RT T.Text)     ,rt "ByteString" (prop_Flat_roundtrip:: RT B.ByteString)     ,rt "Lazy ByteString" (prop_Flat_roundtrip:: RT L.ByteString)+#ifndef ghcjs_HOST_OS     ,rt "Short ByteString" (prop_Flat_roundtrip:: RT SBS.ShortByteString)-  ]-   where rt n = QC.testProperty (unwords ["round trip",n])+#endif+    ] -instance Flat [Int16]-instance Flat [Word8]-instance Flat [Bool]+rt n = QC.testProperty (unwords ["round trip",n]) -unitTests = testGroup "De/Serialisation Unit tests" $ concat [-  sz () 0-  ,sz True 1-  ,sz One 2-  ,sz Two 2-  ,sz Three 2-  ,sz Four 3-  ,sz Five 3-  ,sz 'a' 8-  ,sz 'à' 16-  ,sz '经' 24-  ,sz (0::Word8) 8-  ,sz (1::Word8) 8-  ,concatMap (uncurry sz) ns-  ,concatMap (uncurry sz) $ nsI-  ,concatMap (uncurry sz) $ nsII-  ,sz (1.1::Float) 32-  ,sz (1.1::Double) 64-  ,sz "" 1-  ,sz "abc" (4+3*8)-  ,sz ((),(),Unit) 0-  ,sz (True,False,One,Five) 7-  ,sz map1 7-  ,sz bs (4+3*8)-  ,sz stBS bsSize-  ,sz lzBS bsSize-  ,sz shBS bsSize-  ,sz tx utf8Size-  ,sz (UTF8Text tx) utf8Size-  ,sz (UTF16Text tx) utf16Size-  ,errDec (Proxy::Proxy Bool) [] -- no data+flatTests = testGroup "flat/unflat Unit tests" $ concat [++  -- Expected errors+   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-  ,s () []-  ,s ((),(),Unit) []-  ,s (Unit,'a',Unit,'a',Unit,'a',Unit) [97,97,97]++  ,encRaw () []+  ,encRaw ((),(),Unit) []+  ,encRaw (Unit,'a',Unit,'a',Unit,'a',Unit) [97,97,97]   ,a () [1]   ,a True [128+1]   ,a (True,True) [128+64+1]@@ -153,106 +362,111 @@   ,a (True,False,True,True,True,True) [128+32+16+8+4+1]   ,a (True,False,True,True,True,True,True) [128+32+16+8+4+2+1]   ,a (True,False,True,True,(True,True,True,True)) [128+32+16+8+4+2+1,1]-  ,s (True,False,True,True) [128+32+16]-  ,s ((True,True,False,True,False),(False,False,True,False,True,True)) [128+64+16+1,64+32]-  ,s ('\0','\1','\127') [0,1,127]-  ,s (33::Word32,44::Word32) [33,44]+  ,encRaw (True,False,True,True) [128+32+16]+  ,encRaw ((True,True,False,True,False),(False,False,True,False,True,True)) [128+64+16+1,64+32]+  ,encRaw ('\0','\1','\127') [0,1,127]+  ,encRaw (33::Word32,44::Word32) [33,44]     --,s (Elem True) [64]     --,s (NECons True (NECons False (Elem True))) [128+64+32+4]-  ,s (0::Word8) [0]-  ,s (1::Word8) [1]-  ,s (255::Word8) [255]-  ,s (0::Word16) [0]-  ,s (1::Word16) [1]-  ,s (255::Word16) [255,1]-  ,s (256::Word16) [128,2]-  ,s (65535::Word16) [255,255,3]-  ,s (127::Word32) [127]-  ,s (128::Word32) [128,1]-  ,s (129::Word32) [129,1]-  ,s (255::Word32) [255,1]-  ,s (16383::Word32) [255,127]-  ,s (16384::Word32) [128,128,1]-  ,s (16385::Word32) [129,128,1]-  ,s (32767::Word32) [255,255,1]-  ,s (32768::Word32) [128,128,2]-  ,s (32769::Word32) [129,128,2]-  ,s (65535::Word32) [255,255,3]-  ,s (2097151::Word32) [255,255,127]-  ,s (2097152::Word32) [128,128,128,1]-  ,s (2097153::Word32) [129,128,128,1]-  ,s (4294967295::Word32) [255,255,255,255,15]-  ,s (255::Word64) [255,1]-  ,s (65535::Word64) [255,255,3]-  ,s (4294967295::Word64) [255,255,255,255,15]-  ,s (18446744073709551615::Word64) [255,255,255,255,255,255,255,255,255,1]-  ,s (255::Word) [255,1]-  ,s (65535::Word) [255,255,3]-  ,s (4294967295::Word) [255,255,255,255,15]+  ,encRaw (0::Word8) [0]+  ,encRaw (1::Word8) [1]+  ,encRaw (255::Word8) [255]+  ,encRaw (0::Word16) [0]+  ,encRaw (1::Word16) [1]+  ,encRaw (255::Word16) [255,1]+  ,encRaw (256::Word16) [128,2]+  ,encRaw (65535::Word16) [255,255,3]+  ,encRaw (127::Word32) [127]+  ,encRaw (128::Word32) [128,1]+  ,encRaw (129::Word32) [129,1]+  ,encRaw (255::Word32) [255,1]+  ,encRaw (16383::Word32) [255,127]+  ,encRaw (16384::Word32) [128,128,1]+  ,encRaw (16385::Word32) [129,128,1]+  ,encRaw (32767::Word32) [255,255,1]+  ,encRaw (32768::Word32) [128,128,2]+  ,encRaw (32769::Word32) [129,128,2]+  ,encRaw (65535::Word32) [255,255,3]+  ,encRaw (2097151::Word32) [255,255,127]+  ,encRaw (2097152::Word32) [128,128,128,1]+  ,encRaw (2097153::Word32) [129,128,128,1]+  ,encRaw (4294967295::Word32) [255,255,255,255,15]+  ,encRaw (255::Word64) [255,1]+  ,encRaw (65535::Word64) [255,255,3]+  ,encRaw (4294967295::Word64) [255,255,255,255,15]+  ,encRaw (18446744073709551615::Word64)       [255,255,255,255,255,255,255,255,255,1]+  ,encRaw (False,18446744073709551615::Word64) [127,255,255,255,255,255,255,255,255,128,128]+  ,encRaw (255::Word) [255,1]+  ,encRaw (65535::Word) [255,255,3]+  ,encRaw (4294967295::Word) [255,255,255,255,15]   ,tstI [0::Int8,2,-2]-  ,s (127::Int8) [254]-  ,s (-128::Int8) [255]+  ,encRaw (127::Int8) [254]+  ,encRaw (-128::Int8) [255]   ,tstI [0::Int16,2,-2,127,-128]   ,tstI [0::Int32,2,-2,127,-128]   ,tstI [0::Int64,2,-2,127,-128]-  ,s (-1024::Int64) [255,15]-  ,s (maxBound::Word64) [255,255,255,255,255,255,255,255,255,1]-  ,s (minBound::Int64) [255,255,255,255,255,255,255,255,255,1]-  ,s (maxBound::Int64) [254,255,255,255,255,255,255,255,255,1]+  ,encRaw (-1024::Int64) [255,15]+  ,encRaw (maxBound::Word8)       [255]+  ,encRaw (True,maxBound::Word8)  [255,128]+  ,encRaw (maxBound::Word16)      [255,255,3]+  ,encRaw (True,maxBound::Word16) [255,255,129,128]+  ,encRaw (maxBound::Word32)      [255,255,255,255,15]+  ,encRaw (True,maxBound::Word32) [255,255,255,255,135,128]+  ,encRaw (maxBound::Word64)      [255,255,255,255,255,255,255,255,255,1]+  ,encRaw (True,maxBound::Word64) [255,255,255,255,255,255,255,255,255,128,128]+  ,encRaw (minBound::Int64) [255,255,255,255,255,255,255,255,255,1]+  ,encRaw (maxBound::Int64) [254,255,255,255,255,255,255,255,255,1]   ,tstI [0::Int,2,-2,127,-128]   ,tstI [0::Integer,2,-2,127,-128,-256,-512]-  ,s (-1024::Integer) [255,15]-  ,s (-0.15625::Float)  [0b10111110,0b00100000,0,0]-  ,s (-0.15625::Double) [0b10111111,0b11000100,0,0,0,0,0,0]-  ,s (-123.2325E-23::Double) [0b10111011,0b10010111,0b01000111,0b00101000,0b01110101,0b01111011,0b01000111,0b10111010]-  ,dec ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) [0b10111110,0b10011010] ((),False,True,False)-  ,dec ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) [0b11000000-                                                                 ,0b00000001-                                                                 ,0b01000000] ((),2^15+2,True,())-  ,dec ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) [0b11000000-                                                                 ,0b00000000-                                                                 ,0b00000000-                                                                 ,0b00000001-                                                                 ,0b01000000] ((),2^31+2,True,())-  ,dec ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) [0b11000000-                                                                 ,0b00000000-                                                                 ,0b00000000-                                                                 ,0b00000000-                                                                 ,0b00000000-                                                                 ,0b00000000-                                                                 ,0b00000000-                                                                 ,0b00000001-                                                                 ,0b01000000] ((),2^63+2,True,())+  ,encRaw (-1024::Integer) [255,15]+  ,encRaw (0::Float)  [0,0,0,0]+  ,encRaw (-2::Float) [0b11000000,0,0,0]+  ,encRaw (0.085::Float) [0b00111101,0b10101110,0b00010100,0b01111011]+  ,encRaw (0::Double)  [0,0,0,0,0,0,0,0]+  ,encRaw (-2::Double) [0b11000000,0,0,0,0,0,0,0]+  ,encRaw (23::Double) [0b01000000,0b00110111,0,0,0,0,0,0]+  ,encRaw (-0.15625::Float)  [0b10111110,0b00100000,0,0]+  ,encRaw (-0.15625::Double) [0b10111111,0b11000100,0,0,0,0,0,0]+  ,encRaw (-123.2325E-23::Double) [0b10111011,0b10010111,0b01000111,0b00101000,0b01110101,0b01111011,0b01000111,0b10111010]+  ,encRaw (Left True :: Either Bool (Double, Double)) [0b01000000]+  ,encRaw (-2.1234E15 :: Double) [195,30,44,226,90,221,64,0]+  ,encRaw (1.1234E-22 :: Double) [59,96,249,241,120,219,249,174]+  ,encRaw ((False,-2.1234E15) :: (Bool,Double)) [97,143,22,113,45,110,160,0,0]+  ,encRaw ((True,-2.1234E15) :: (Bool,Double)) [225,143,22,113,45,110,160,0,0]+  ,encRaw ((-2.1234E15 , 1.1234E-22) :: (Double, Double)) $ [0b11000011,30,44,226,90,221,64,0] ++ [59,96,249,241,120,219,249,174]+  ,encRaw ((True,-2.1234E15 , 1.1234E-22) :: (Bool,Double, Double)) [0b11100001,143,22,113,45,110,160,0,29,176,124,248,188,109,252,215,0]+  ,encRaw (Right (-2.1234E15 , 1.1234E-22) :: Either Bool (Double, Double)) [0b11100001,143,22,113,45,110,160,0,29,176,124,248,188,109,252,215,0]+  ,encRaw (Left True:: Either Bool Direction) [0b01000000]+  ,encRaw (Right West :: Either Bool Direction) [0b11110000] -  ,decBitsN dBEBits8-  ,decBitsN dBEBits16-  ,decBitsN dBEBits32-  ,decBitsN dBEBits64-  ,map trip [maxBound::Word16]-  ,map trip [maxBound::Word32]-  ,map trip [maxBound::Word64]+++  ,map trip [minBound,maxBound::Word8]+  ,map trip [minBound,maxBound::Word16]+  ,map trip [minBound,maxBound::Word32]+  ,map trip [minBound,maxBound::Word64]   ,map trip [minBound::Int8,maxBound::Int8]   ,map trip [minBound::Int16,maxBound::Int16]   ,map trip [minBound::Int32,maxBound::Int32]   ,map trip [minBound::Int64,maxBound::Int64]   ,map trip [0::Float,-0::Float,0/0::Float,1/0::Float]   ,map trip [0::Double,-0::Double,0/0::Double,1/0::Double]-  ,s '\0' [0]-  ,s '\1' [1]-  ,s '\127' [127]-  ,s 'a' [97]-  ,s 'à' [224,1]-  ,s '经' [207,253,1]+  ,encRaw '\0' [0]+  ,encRaw '\1' [1]+  ,encRaw '\127' [127]+  ,encRaw 'a' [97]+  ,encRaw 'à' [224,1]+  ,encRaw '经' [207,253,1]   ,[trip [chr 0x10FFFF]]-  ,s Unit []-  ,s (Un False) [0]-  ,s (One,Two,Three) [16+8]-  ,s (Five,Five,Five) [255,128]+  ,encRaw Unit []+  ,encRaw (Un False) [0]+  ,encRaw (One,Two,Three) [16+8]+  ,encRaw (Five,Five,Five) [255,128]     --,s (NECons True (Elem True)) [128+64+16]-  ,s "" [0]+  ,encRaw "" [0] #ifdef LIST_BIT-  ,s "abc" [176,216,172,96]-  ,s [False,True,False,True] [128+  ,encRaw "abc" [176,216,172,96]+  ,encRaw [False,True,False,True] [128                                +32+16                                +8                                +2+1,0]@@ -265,54 +479,25 @@     --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0]     --,s (T.pack "abc") (al s3)     --,s (T.pack $ cs 600) (al s600)-  ,s map1 [0b10111000]-  ,s (B.pack $ csb 3) (bsl c3)-  ,s (B.pack $ csb 600) (bsl s600)-  ,s (L.pack $ csb 3) (bsl c3)+  ,encRaw map1 [0b10111000]+  ,encRaw (B.pack $ csb 3) (bsl c3)+  ,encRaw (B.pack $ csb 600) (bsl s600)+  ,encRaw (L.pack $ csb 3) (bsl c3)    -- Long LazyStrings can have internal sections shorter than 255    --,s (L.pack $ csb 600) (bsl s600)   ,[trip [1..100::Int16]]-  ,[trip asciiStrT,trip "维护和平正",trip (T.pack "abc"),trip unicodeText,trip unicodeTextUTF8T,trip unicodeTextUTF16T]-  ,[trip longBS,trip longLBS,trip longSBS]-  ,[trip longSeq]-  ,[trip mapV]-  ,[trip map1]+  ,[trip asciiStrT,trip "维护和平正",trip (T.pack "abc"),trip unicodeText,trip unicodeTextUTF8T]+  ,[trip longBS,trip longLBS]+#ifndef ghcjs_HOST_OS+  ,[trip longSBS]+  ,[trip unicodeTextUTF16T]+#endif   ]     where-      map1 = M.fromList [(False,True),(True,False)] -      ns :: [(Word64, Int)]-      ns =  [( (-) (2 ^(i*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]--      nsI :: [(Int64, Int)]-      nsI = nsI_-      nsII :: [(Integer, Int)]-      nsII = nsI_-      nsI_ =  [( (-) (2 ^(((-) i 1)*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]-       --al = (1:) -- prealign       bsl = id -- noalign-      s3 = [3,97,98,99,0]-      c3a = [3,99,99,99,0] -- Array Word8-      c3 = pre c3a-      s600 = pre s600a-      pre = (1:)-      tx = T.pack "txt"-      utf8Size = 8+8+3*32+8-      utf16Size = 8+8+3*16+8-      shBS = SBS.toShort stBS-      lzBS = L.pack bs-      stBS = B.pack bs-      bs = [32,32,32::Word8]-      bsSize = 8+8+3*8+8-      s600a = concat [[255],csb 255,[255],csb 255,[90],csb 90,[0]]-      s600B = concat [[55],csb 55,[255],csb 255,[90],csb 90,[200],csb 200,[0]]-      longSeq :: Seq.Seq Word8-      longSeq = Seq.fromList lbs-      longSBS = SBS.toShort longBS-      longBS = B.pack lbs-      longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]-      lbs = concat $ replicate 100 [234,123,255,0]+       tstI = map ti        ti v | v >= 0    = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral v ::Word64)@@ -320,43 +505,63 @@        teq a b = ser a @?= ser b -      sz v e = [testCase (unwords ["size of",sshow v]) $ getSize v @?= e]--      s v e = [testCase (unwords ["flat raw",sshow v]) $ serRaw v @?= e]               --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v] -      dec decOp v e = [testCase (unwords ["decode",sshow v]) $ unflatRawWith decOp (B.pack v) @?= Right e]--      decBitsN :: forall a. (Num a,FiniteBits a,Show a,Flat a) => (Int -> Get a) -> [TestTree]-      decBitsN dec = let s = finiteBitSize (undefined::a)-                     in [decBits_ dec v n pre | n <- [0 .. s], v <- [0::a ,1+2^(s - 2)+2^(s - 5) ,fromIntegral $ (2^s::Integer) - 1],pre <- [0,1,7]]--      -- why Flat a?-      decBits_ :: forall a. (FiniteBits a,Show a,Flat a) => (Int -> Get a) -> a -> Int -> Int -> TestTree-      decBits_ deco v n pre =-        let vs = B.pack . asBytes . fromBools $ replicate pre False ++ toBools (asBits v)-            len = B.length vs-            s = finiteBitSize (undefined::a)-            dec = do-              dropBits pre-              r <- deco n-              dropBits (len*8-n-pre)-              return r-            e = v `shiftR` (s - n)-        in testCase (unwords ["take",show n,"bits from",show v,"of size",show s,"with prefix",show pre]) $ unflatRawWith dec vs @?= Right e-       -- Aligned values unflat to the original value, modulo the added filler.       a v e = [testCase (unwords ["flat",sshow v]) $ ser v @?= e               ,testCase (unwords ["unflat",sshow v]) $ let Right v' = des e in v @?= v']       -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e       --         ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']-      cs n = replicate n 'c' -- take n $ cycle ['a'..'z']-      csb = map (fromIntegral . ord) . cs-      sshow = take 80 . show -      trip :: forall a .(Show a,Flat a) => a -> TestTree-      trip v = testCase (unwords ["roundtrip",sshow v]) $ show (unflat (flat v::B.ByteString)::Decoded a) @?= show (Right v::Decoded a) -- we use show to get Right NaN == Right NaN +encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree]+encRaw v e = [testCase (unwords ["flat raw",sshow v,show . B.unpack . flat $ v]) $ serRaw v @?= e]++trip :: forall a .(Show a,Flat a) => a -> TestTree+trip v = testCase (unwords ["roundtrip",sshow v]) $+  -- we use show to get Right NaN == Right NaN+  show (unflat (flat v::B.ByteString)::Decoded a) @?= show (Right v::Decoded a)++-- Test Data+lzBS = L.pack bs+stBS = B.pack bs+bs = [32,32,32::Word8]+s3 = [3,97,98,99,0]+c3a = [3,99,99,99,0] -- Array Word8+c3 = pre c3a+s600 = pre s600a+pre = (1:)+s600a = concat [[255],csb 255,[255],csb 255,[90],csb 90,[0]]+s600B = concat [[55],csb 55,[255],csb 255,[90],csb 90,[200],csb 200,[0]]+longSeq :: Seq.Seq Word8+longSeq = Seq.fromList lbs+longBS = B.pack lbs+longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]+lbs = concat $ replicate 100 [234,123,255,0]+cs n = replicate n 'c' -- take n $ cycle ['a'..'z']+csb = map (fromIntegral . ord) . cs+map1 = M.fromList [(False,True),(True,False)]++ns :: [(Word64, Int)]+ns =  [( (-) (2 ^(i*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]++nsI :: [(Int64, Int)]+nsI = nsI_+nsII :: [(Integer, Int)]+nsII = nsI_+nsI_ =  [( (-) (2 ^(((-) i 1)*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]++++#ifndef ghcjs_HOST_OS+shBS = SBS.toShort stBS+longSBS = SBS.toShort longBS+#endif++sshow = take 80 . show++showB = show . B.unpack+ errDec :: forall a . (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree] --errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""] errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in isRight ev @?= False]@@ -367,6 +572,8 @@ des :: Flat a => [Word8] -> Decoded a des = unflat +flatRawWith sz enc = B.unpack $ E.strictEncoder (sz+8) (E.Encoding $ enc >=> E.eFillerF)+ serRaw :: Flat a => a -> [Word8] -- serRaw = B.unpack . flatRaw -- serRaw = L.unpack . flatRaw@@ -379,14 +586,20 @@ type RTL a = Large a -> Bool  prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool-prop_Flat_roundtrip = rtrip2+prop_Flat_roundtrip = roundTripExt  prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool-prop_Flat_Large_roundtrip (Large x) = rtrip2 x+prop_Flat_Large_roundtrip (Large x) = roundTripExt x -rtrip x = unflat (flat x::B.ByteString) == Right x-rtrip2 x = rtrip x && rtrip (True,x,False)+roundTrip x = unflat (flat x::B.ByteString) == Right x +-- Test roundtrip for both the value and the value embedded between bools+roundTripExt x = roundTrip x && roundTrip (True,x,False)++prop_double_conv d = wordToDouble (doubleToWord d) == d++prop_float_conv d = wordToFloat (floatToWord d) == d+ {- prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool prop_common_unsigned n _ = let n2 :: h = fromIntegral n@@ -404,4 +617,8 @@ -- b1 :: BLOB UTF8 -- b1 = BLOB UTF8 (preAligned (List255 [97,98,99])) -- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))++++ 

@@ -21,7 +21,7 @@ import           Data.Word import           GHC.Generics import qualified Test.Data2                    as D2-import           Test.Tasty.QuickCheck+-- import           Test.Tasty.QuickCheck  data Void deriving Generic @@ -44,7 +44,7 @@        | Three        | Four        | Five-  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum)+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum, Bounded)  -- toForestD :: Forest a -> ForestD (Tr2 a)  -- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt))@@ -207,69 +207,3 @@   ,fuel::String -- constant Petrol   } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta), run in the project directory: derive -a test/Test/Data.hs-{-!-deriving instance Arbitrary N-deriving instance Arbitrary Tree-deriving instance Arbitrary List-deriving instance Arbitrary Unit-deriving instance Arbitrary Un-deriving instance Arbitrary A-deriving instance Arbitrary B-!-}---- GENERATED START--instance () => Arbitrary N where-        arbitrary-          = do x <- choose (0 :: Int, 4)-               case x of-                   0 -> return One-                   1 -> return Two-                   2 -> return Three-                   3 -> return Four-                   4 -> return Five-                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance (Arbitrary a) => Arbitrary (Tree a) where-        arbitrary-          = do x <- choose (0 :: Int, 1)-               case x of-                   0 -> do x1 <- arbitrary-                           x2 <- arbitrary-                           return (Node x1 x2)-                   1 -> Leaf <$> arbitrary-                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance (Arbitrary a) => Arbitrary (List a) where-        arbitrary-          = do x <- choose (0 :: Int, 1)-               case x of-                   0 -> do x1 <- arbitrary-                           x2 <- arbitrary-                           return (C x1 x2)-                   1 -> return N-                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance () => Arbitrary Unit where-        arbitrary = return Unit--instance () => Arbitrary Un where-        arbitrary-          = Un <$> arbitrary-instance () => Arbitrary A where-        arbitrary-          = do x <- choose (0 :: Int, 1)-               case x of-                   0 -> A <$> arbitrary-                   1 -> AA <$> arbitrary-                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance () => Arbitrary B where-        arbitrary-          = do x <- choose (0 :: Int, 1)-               case x of-                   0 -> B <$> arbitrary-                   1 -> BB <$> arbitrary-                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--- GENERATED STOP

@@ -1,25 +1,46 @@ {-# LANGUAGE CPP #-}--- {-# LANGUAGE TemplateHaskell #-}+-- {-# LANGUAGE TemplateHaskell , CPP#-}  module Test.Data.Arbitrary where---- import qualified Data.ByteString           as B--- import qualified Data.ByteString.Lazy      as L-import qualified Data.ByteString.Short     as SBS--- import qualified Data.Text                 as T--- import           Test.Data+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as SBS+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Test.Tasty.QuickCheck+import           Test.Data -- import           Data.DeriveTH-import           Test.QuickCheck.Instances-import           Test.Tasty.QuickCheck--- import           Test.QuickCheck --- xxx = generate (arbitrary :: Gen (Large (Int)))+import Numeric.Natural (Natural) -#if !MIN_VERSION_quickcheck_instances(0,3,17)-instance Arbitrary SBS.ShortByteString where arbitrary   = fmap SBS.pack arbitrary-#endif+instance Arbitrary Natural where+  arbitrary = arbitrarySizedNatural+  shrink    = shrinkIntegral +-- Copied from quickcheck-instances (not used directly as it requires old-time that is incompatible with ghcjs) +instance Arbitrary BS.ByteString where+  arbitrary = BS.pack <$> arbitrary+  shrink xs = BS.pack <$> shrink (BS.unpack xs)++instance Arbitrary BL.ByteString where+  arbitrary = BL.pack <$> arbitrary+  shrink xs = BL.pack <$> shrink (BL.unpack xs)++instance Arbitrary SBS.ShortByteString where+  arbitrary = SBS.pack <$> arbitrary+  shrink xs = SBS.pack <$> shrink (SBS.unpack xs)++instance Arbitrary TS.Text where+    arbitrary = TS.pack <$> arbitrary+    shrink xs = TS.pack <$> shrink (TS.unpack xs)++instance Arbitrary TL.Text where+    arbitrary = TL.pack <$> arbitrary+    shrink xs = TL.pack <$> shrink (TL.unpack xs)++-- xxx = generate (arbitrary :: Gen (Large (Int)))+ {- -- derive makeArbitrary ''N derive makeArbitrary ''Tree@@ -34,6 +55,72 @@  derive makeArbitrary ''B -}- -- instance Arbitrary Word7 where arbitrary  = toEnum <$> choose (0, 127) -- derive makeArbitrary ''ASCII+-- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta)+-- , run in the project directory:  derive -a test/Test/Data.hs --derive=Arbitrary+{-!+deriving instance Arbitrary N+deriving instance Arbitrary Tree+deriving instance Arbitrary List+deriving instance Arbitrary Unit+deriving instance Arbitrary Un+deriving instance Arbitrary A+deriving instance Arbitrary B+!-}+-- GENERATED START+instance () => Arbitrary N where+  arbitrary = do+    x <- choose (0 :: Int, 4)+    case x of+      0 -> return One+      1 -> return Two+      2 -> return Three+      3 -> return Four+      4 -> return Five+      _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance (Arbitrary a) => Arbitrary (Tree a) where+  arbitrary = do+    x <- choose (0 :: Int, 1)+    case x of+      0 -> do+        x1 <- arbitrary+        x2 <- arbitrary+        return (Node x1 x2)+      1 -> Leaf <$> arbitrary+      _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance (Arbitrary a) => Arbitrary (List a) where+  arbitrary = do+    x <- choose (0 :: Int, 1)+    case x of+      0 -> do+        x1 <- arbitrary+        x2 <- arbitrary+        return (C x1 x2)+      1 -> return N+      _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary Unit where+  arbitrary = return Unit++instance () => Arbitrary Un where+  arbitrary = Un <$> arbitrary++instance () => Arbitrary A where+  arbitrary = do+    x <- choose (0 :: Int, 1)+    case x of+      0 -> A <$> arbitrary+      1 -> AA <$> arbitrary+      _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary B where+  arbitrary = do+    x <- choose (0 :: Int, 1)+    case x of+      0 -> B <$> arbitrary+      1 -> BB <$> arbitrary+      _ -> error "FATAL ERROR: Arbitrary instance, logic bug"+-- GENERATED STOP

@@ -1,15 +1,18 @@  {-# LANGUAGE UndecidableInstances ,DeriveGeneric, FlexibleContexts, FlexibleInstances,StandaloneDeriving #-}-module Test.Data.Flat(module Test.Data) where-import Data.Flat-import Data.Flat.Encoder-import Data.Flat.Decoder-import Test.Data-import Test.Data2.Flat()-import Data.Word-import Data.Foldable-import Data.Int-import GHC.Generics+module Test.Data.Flat+  ( module Test.Data+  )+where+import           Data.Flat+import           Data.Flat.Encoder+import           Data.Flat.Decoder+import           Test.Data+import           Test.Data2.Flat                ( )+import           Data.Word+import           Data.Foldable+import           Data.Int+import           GHC.Generics  {- Compilation times:@@ -38,6 +41,8 @@ instance Flat Unit  instance Flat a => Flat (List a)++instance Flat a => Flat (Tree a)  instance Flat Direction instance Flat Words

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoMonomorphismRestriction , ScopedTypeVariables #-} module Test.Data.Values where  import           Control.DeepSeq@@ -19,6 +19,9 @@ import           Data.Word import           Test.Data import qualified Test.Data2                     as D2+import           qualified Data.IntMap           as IM+import           qualified Data.IntSet           as IS+-- import Data.Array as A  instance NFData Various instance NFData a => NFData (List a)@@ -104,7 +107,8 @@  largeSize = 1000000 -couples :: [(Word32,N)]+-- couples :: [(Word32,N)]+couples :: [(Int,N)] couples = zip [1..] $ ns 1000  lN2 :: List N@@ -116,15 +120,18 @@  ns n = map asN [1..n] -asN = toN . (`mod` 5)+asN :: Int -> N+asN = toEnum . (`mod` 5) -toN :: Integer -> N-toN 1 = One-toN 2 = Two-toN 3 = Three-toN 4 = Four-toN _ = Five+-- asN = toN . (`mod` 5) +-- toN :: Integer -> N+-- toN 1 = One+-- toN 2 = Two+-- toN 3 = Three+-- toN 4 = Four+-- toN _ = Five+ asN3 = toN3 . (`mod` 5) toN3 :: Integer -> (N,N,N) toN3 1 = (One,Two,Three)@@ -150,6 +157,10 @@  treeVarious = mkTree (const v2) 100 +mkTreeOf :: forall a. (Enum a ,Bounded a)=> Int -> Tree a+mkTreeOf = let l = fromEnum (maxBound :: a) +1+           in mkTree ((toEnum :: (Int -> a)) . (`mod` l))+ mkTree mk = mkTree_ 1   where     mkTree_ p 1 = Leaf $ mk p@@ -197,10 +208,17 @@ lbs = ("LazyByteString",lb2) shortbs = ("ShortByteString",SBS.toShort b2) -mapT = ("map",mapV)-mapV = M.fromList couples-mapListT = ("mapList",couples)+-- array package+-- arrayT = ("Array", ++intMapT = ("IntMap",intMap)+mapT = ("map",dataMap)+mapListT = ("mapList",listMap)+intMap = IM.fromList couples+dataMap = M.fromList couples+listMap = couples+ lN2T = ("List N",lN2) lN3T = ("Large List N",lN3) nativeListT = ("Large [N]",nativeList)@@ -255,7 +273,7 @@ forceCafs :: IO () forceCafs = mapM_ (evaluate . force') cafs --- | List of all data that should be fully evaluated before the benchmark is+-- | List of all data that should be fully evaluated before a benchmark is --   run. cafs :: [NF] cafs = [

@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass ,CPP #-}+module Test.E where++import           Data.Flat+import           Data.List+import           Control.DeepSeq+-- import Data.Proxy++data S3 = S_1 | S_2 Bool | S_3 Char deriving (Show,Generic,Eq,NFData)+++g :: (Num a, Enum a, Show a) => a -> String+g n =+    let dt = "E" ++ show n+    in  unwords+            [ "data"+            , dt+            , "="+            , intercalate " | " $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n]+            , "deriving (Show,Generic,Eq,NFData,Enum,Bounded)"+            ]+            +data E1 = E1 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E2 = E2_1 | E2_2 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E3 = E3_1 | E3_2 | E3_3 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E4 = E4_1 | E4_2 | E4_3 | E4_4 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E8 = E8_1 | E8_2 | E8_3 | E8_4 | E8_5 | E8_6 | E8_7 | E8_8 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E16 = E16_1 | E16_2 | E16_3 | E16_4 | E16_5 | E16_6 | E16_7 | E16_8 | E16_9 | E16_10 | E16_11 | E16_12 | E16_13 | E16_14 | E16_15 | E16_16 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E17 = E17_1 | E17_2 | E17_3 | E17_4 | E17_5 | E17_6 | E17_7 | E17_8 | E17_9 | E17_10 | E17_11 | E17_12 | E17_13 | E17_14 | E17_15 | E17_16 | E17_17 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++data E32 = E32_1 | E32_2 | E32_3 | E32_4 | E32_5 | E32_6 | E32_7 | E32_8 | E32_9 | E32_10 | E32_11 | E32_12 | E32_13 | E32_14 | E32_15 | E32_16 | E32_17 | E32_18 | E32_19 | E32_20 | E32_21 | E32_22 | E32_23 | E32_24 | E32_25 | E32_26 | E32_27 | E32_28 | E32_29 | E32_30 | E32_31 | E32_32 deriving (Show,Generic,Eq,NFData,Enum,Bounded)++#ifdef ENUM_LARGE+data E256 = E256_1 | E256_2 | E256_3 | E256_4 | E256_5 | E256_6 | E256_7 | E256_8 | E256_9 | E256_10 | E256_11 | E256_12 | E256_13 | E256_14 | E256_15 | E256_16 | E256_17 | E256_18 | E256_19 | E256_20 | E256_21 | E256_22 | E256_23 | E256_24 | E256_25 | E256_26 | E256_27 | E256_28 | E256_29 | E256_30 | E256_31 | E256_32 | E256_33 | E256_34 | E256_35 | E256_36 | E256_37 | E256_38 | E256_39 | E256_40 | E256_41 | E256_42 | E256_43 | E256_44 | E256_45 | E256_46 | E256_47 | E256_48 | E256_49 | E256_50 | E256_51 | E256_52 | E256_53 | E256_54 | E256_55 | E256_56 | E256_57 | E256_58 | E256_59 | E256_60 | E256_61 | E256_62 | E256_63 | E256_64 | E256_65 | E256_66 | E256_67 | E256_68 | E256_69 | E256_70 | E256_71 | E256_72 | E256_73 | E256_74 | E256_75 | E256_76 | E256_77 | E256_78 | E256_79 | E256_80 | E256_81 | E256_82 | E256_83 | E256_84 | E256_85 | E256_86 | E256_87 | E256_88 | E256_89 | E256_90 | E256_91 | E256_92 | E256_93 | E256_94 | E256_95 | E256_96 | E256_97 | E256_98 | E256_99 | E256_100 | E256_101 | E256_102 | E256_103 | E256_104 | E256_105 | E256_106 | E256_107 | E256_108 | E256_109 | E256_110 | E256_111 | E256_112 | E256_113 | E256_114 | E256_115 | E256_116 | E256_117 | E256_118 | E256_119 | E256_120 | E256_121 | E256_122 | E256_123 | E256_124 | E256_125 | E256_126 | E256_127 | E256_128 | E256_129 | E256_130 | E256_131 | E256_132 | E256_133 | E256_134 | E256_135 | E256_136 | E256_137 | E256_138 | E256_139 | E256_140 | E256_141 | E256_142 | E256_143 | E256_144 | E256_145 | E256_146 | E256_147 | E256_148 | E256_149 | E256_150 | E256_151 | E256_152 | E256_153 | E256_154 | E256_155 | E256_156 | E256_157 | E256_158 | E256_159 | E256_160 | E256_161 | E256_162 | E256_163 | E256_164 | E256_165 | E256_166 | E256_167 | E256_168 | E256_169 | E256_170 | E256_171 | E256_172 | E256_173 | E256_174 | E256_175 | E256_176 | E256_177 | E256_178 | E256_179 | E256_180 | E256_181 | E256_182 | E256_183 | E256_184 | E256_185 | E256_186 | E256_187 | E256_188 | E256_189 | E256_190 | E256_191 | E256_192 | E256_193 | E256_194 | E256_195 | E256_196 | E256_197 | E256_198 | E256_199 | E256_200 | E256_201 | E256_202 | E256_203 | E256_204 | E256_205 | E256_206 | E256_207 | E256_208 | E256_209 | E256_210 | E256_211 | E256_212 | E256_213 | E256_214 | E256_215| E256_216 | E256_217 | E256_218 | E256_219 | E256_220 | E256_221 | E256_222 | E256_223 | E256_224 | E256_225 | E256_226 | E256_227 | E256_228 | E256_229 | E256_230 | E256_231 | E256_232 |E256_233 | E256_234 | E256_235 | E256_236 | E256_237 | E256_238 | E256_239 | E256_240 | E256_241 | E256_242 | E256_243 | E256_244 | E256_245 | E256_246 | E256_247 | E256_248 | E256_249 | E256_250 | E256_251 | E256_252 | E256_253 | E256_254 | E256_255 | E256_256 deriving (Show,Generic,Eq,NFData,Enum,Bounded)+data E258 = E258_1 | E258_2 | E258_3 | E258_4 | E258_5 | E258_6 | E258_7 | E258_8 | E258_9 | E258_10 | E258_11 | E258_12 | E258_13 | E258_14 | E258_15 | E258_16 | E258_17 | E258_18 | E258_19 | E258_20 | E258_21 | E258_22 | E258_23 | E258_24 | E258_25 | E258_26 | E258_27 | E258_28 | E258_29 | E258_30 | E258_31 | E258_32 | E258_33 | E258_34 | E258_35 | E258_36 | E258_37 | E258_38 | E258_39 | E258_40 | E258_41 | E258_42 | E258_43 | E258_44 | E258_45 | E258_46 | E258_47 | E258_48 | E258_49 | E258_50 | E258_51 | E258_52 | E258_53 | E258_54 | E258_55 | E258_56 | E258_57 | E258_58 | E258_59 | E258_60 | E258_61 | E258_62 | E258_63 | E258_64 | E258_65 | E258_66 | E258_67 | E258_68 | E258_69 | E258_70 | E258_71 | E258_72 | E258_73 | E258_74 | E258_75 | E258_76 | E258_77 | E258_78 | E258_79 | E258_80 | E258_81 | E258_82 | E258_83 | E258_84 | E258_85 | E258_86 | E258_87 | E258_88 | E258_89 | E258_90 | E258_91 | E258_92 | E258_93 | E258_94 | E258_95 | E258_96 | E258_97 | E258_98 | E258_99 | E258_100 | E258_101 | E258_102 | E258_103 | E258_104 | E258_105 | E258_106 | E258_107 | E258_108 | E258_109 | E258_110 | E258_111 | E258_112 | E258_113 | E258_114 | E258_115 | E258_116 | E258_117 | E258_118 | E258_119 | E258_120 |E258_121 | E258_122 | E258_123 | E258_124 | E258_125 | E258_126 | E258_127 | E258_128 | E258_129 | E258_130 | E258_131 | E258_132 | E258_133 | E258_134 | E258_135 | E258_136 | E258_137 | E258_138 | E258_139 | E258_140 | E258_141 | E258_142 | E258_143 | E258_144 | E258_145 | E258_146 | E258_147 | E258_148 | E258_149 | E258_150 | E258_151 | E258_152| E258_153 | E258_154 | E258_155 | E258_156 | E258_157 | E258_158 | E258_159 | E258_160 | E258_161 | E258_162 | E258_163 | E258_164 | E258_165 | E258_166 | E258_167 | E258_168 | E258_169 | E258_170 | E258_171 | E258_172 | E258_173 | E258_174 | E258_175 | E258_176 | E258_177 | E258_178 | E258_179 | E258_180 | E258_181 | E258_182 | E258_183 | E258_184 | E258_185 | E258_186 | E258_187 | E258_188 | E258_189 | E258_190 | E258_191 | E258_192 | E258_193 | E258_194 | E258_195 | E258_196 | E258_197 | E258_198 | E258_199 | E258_200 | E258_201 | E258_202 | E258_203 | E258_204 | E258_205 | E258_206 | E258_207 | E258_208 | E258_209 | E258_210 | E258_211 | E258_212 | E258_213 | E258_214 | E258_215 | E258_216 | E258_217 | E258_218 | E258_219 | E258_220 | E258_221 | E258_222 | E258_223 | E258_224 | E258_225 | E258_226 | E258_227 | E258_228 | E258_229 | E258_230 | E258_231 | E258_232 | E258_233 | E258_234 | E258_235 | E258_236 | E258_237 | E258_238 | E258_239 | E258_240 | E258_241 | E258_242 | E258_243 | E258_244 | E258_245 | E258_246 | E258_247 | E258_248 | E258_249 | E258_250 | E258_251 | E258_252 | E258_253 | E258_254 | E258_255 | E258_256 | E258_257 | E258_258 deriving (Show,Generic,Eq,NFData,Enum,Bounded)+#endif

@@ -0,0 +1,659 @@+{-# LANGUAGE CPP #-}+module Test.E.Arbitrary where+import Test.Tasty.QuickCheck+import           Test.E++-- GENERATED START++instance () => Arbitrary E2 where+    arbitrary+      = do x <- choose (0 :: Int, 1)+           case x of+               0 -> return E2_1+               1 -> return E2_2+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E3 where+    arbitrary+      = do x <- choose (0 :: Int, 2)+           case x of+               0 -> return E3_1+               1 -> return E3_2+               2 -> return E3_3+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E4 where+    arbitrary+      = do x <- choose (0 :: Int, 3)+           case x of+               0 -> return E4_1+               1 -> return E4_2+               2 -> return E4_3+               3 -> return E4_4+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E8 where+    arbitrary+      = do x <- choose (0 :: Int, 7)+           case x of+               0 -> return E8_1+               1 -> return E8_2+               2 -> return E8_3+               3 -> return E8_4+               4 -> return E8_5+               5 -> return E8_6+               6 -> return E8_7+               7 -> return E8_8+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E16 where+    arbitrary+      = do x <- choose (0 :: Int, 15)+           case x of+               0 -> return E16_1+               1 -> return E16_2+               2 -> return E16_3+               3 -> return E16_4+               4 -> return E16_5+               5 -> return E16_6+               6 -> return E16_7+               7 -> return E16_8+               8 -> return E16_9+               9 -> return E16_10+               10 -> return E16_11+               11 -> return E16_12+               12 -> return E16_13+               13 -> return E16_14+               14 -> return E16_15+               15 -> return E16_16+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E17 where+    arbitrary+      = do x <- choose (0 :: Int, 16)+           case x of+               0 -> return E17_1+               1 -> return E17_2+               2 -> return E17_3+               3 -> return E17_4+               4 -> return E17_5+               5 -> return E17_6+               6 -> return E17_7+               7 -> return E17_8+               8 -> return E17_9+               9 -> return E17_10+               10 -> return E17_11+               11 -> return E17_12+               12 -> return E17_13+               13 -> return E17_14+               14 -> return E17_15+               15 -> return E17_16+               16 -> return E17_17+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E32 where+    arbitrary+      = do x <- choose (0 :: Int, 31)+           case x of+               0 -> return E32_1+               1 -> return E32_2+               2 -> return E32_3+               3 -> return E32_4+               4 -> return E32_5+               5 -> return E32_6+               6 -> return E32_7+               7 -> return E32_8+               8 -> return E32_9+               9 -> return E32_10+               10 -> return E32_11+               11 -> return E32_12+               12 -> return E32_13+               13 -> return E32_14+               14 -> return E32_15+               15 -> return E32_16+               16 -> return E32_17+               17 -> return E32_18+               18 -> return E32_19+               19 -> return E32_20+               20 -> return E32_21+               21 -> return E32_22+               22 -> return E32_23+               23 -> return E32_24+               24 -> return E32_25+               25 -> return E32_26+               26 -> return E32_27+               27 -> return E32_28+               28 -> return E32_29+               29 -> return E32_30+               30 -> return E32_31+               31 -> return E32_32+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++#ifdef ENUM_LARGE+instance () => Arbitrary E256 where+    arbitrary+      = do x <- choose (0 :: Int, 255)+           case x of+               0 -> return E256_1+               1 -> return E256_2+               2 -> return E256_3+               3 -> return E256_4+               4 -> return E256_5+               5 -> return E256_6+               6 -> return E256_7+               7 -> return E256_8+               8 -> return E256_9+               9 -> return E256_10+               10 -> return E256_11+               11 -> return E256_12+               12 -> return E256_13+               13 -> return E256_14+               14 -> return E256_15+               15 -> return E256_16+               16 -> return E256_17+               17 -> return E256_18+               18 -> return E256_19+               19 -> return E256_20+               20 -> return E256_21+               21 -> return E256_22+               22 -> return E256_23+               23 -> return E256_24+               24 -> return E256_25+               25 -> return E256_26+               26 -> return E256_27+               27 -> return E256_28+               28 -> return E256_29+               29 -> return E256_30+               30 -> return E256_31+               31 -> return E256_32+               32 -> return E256_33+               33 -> return E256_34+               34 -> return E256_35+               35 -> return E256_36+               36 -> return E256_37+               37 -> return E256_38+               38 -> return E256_39+               39 -> return E256_40+               40 -> return E256_41+               41 -> return E256_42+               42 -> return E256_43+               43 -> return E256_44+               44 -> return E256_45+               45 -> return E256_46+               46 -> return E256_47+               47 -> return E256_48+               48 -> return E256_49+               49 -> return E256_50+               50 -> return E256_51+               51 -> return E256_52+               52 -> return E256_53+               53 -> return E256_54+               54 -> return E256_55+               55 -> return E256_56+               56 -> return E256_57+               57 -> return E256_58+               58 -> return E256_59+               59 -> return E256_60+               60 -> return E256_61+               61 -> return E256_62+               62 -> return E256_63+               63 -> return E256_64+               64 -> return E256_65+               65 -> return E256_66+               66 -> return E256_67+               67 -> return E256_68+               68 -> return E256_69+               69 -> return E256_70+               70 -> return E256_71+               71 -> return E256_72+               72 -> return E256_73+               73 -> return E256_74+               74 -> return E256_75+               75 -> return E256_76+               76 -> return E256_77+               77 -> return E256_78+               78 -> return E256_79+               79 -> return E256_80+               80 -> return E256_81+               81 -> return E256_82+               82 -> return E256_83+               83 -> return E256_84+               84 -> return E256_85+               85 -> return E256_86+               86 -> return E256_87+               87 -> return E256_88+               88 -> return E256_89+               89 -> return E256_90+               90 -> return E256_91+               91 -> return E256_92+               92 -> return E256_93+               93 -> return E256_94+               94 -> return E256_95+               95 -> return E256_96+               96 -> return E256_97+               97 -> return E256_98+               98 -> return E256_99+               99 -> return E256_100+               100 -> return E256_101+               101 -> return E256_102+               102 -> return E256_103+               103 -> return E256_104+               104 -> return E256_105+               105 -> return E256_106+               106 -> return E256_107+               107 -> return E256_108+               108 -> return E256_109+               109 -> return E256_110+               110 -> return E256_111+               111 -> return E256_112+               112 -> return E256_113+               113 -> return E256_114+               114 -> return E256_115+               115 -> return E256_116+               116 -> return E256_117+               117 -> return E256_118+               118 -> return E256_119+               119 -> return E256_120+               120 -> return E256_121+               121 -> return E256_122+               122 -> return E256_123+               123 -> return E256_124+               124 -> return E256_125+               125 -> return E256_126+               126 -> return E256_127+               127 -> return E256_128+               128 -> return E256_129+               129 -> return E256_130+               130 -> return E256_131+               131 -> return E256_132+               132 -> return E256_133+               133 -> return E256_134+               134 -> return E256_135+               135 -> return E256_136+               136 -> return E256_137+               137 -> return E256_138+               138 -> return E256_139+               139 -> return E256_140+               140 -> return E256_141+               141 -> return E256_142+               142 -> return E256_143+               143 -> return E256_144+               144 -> return E256_145+               145 -> return E256_146+               146 -> return E256_147+               147 -> return E256_148+               148 -> return E256_149+               149 -> return E256_150+               150 -> return E256_151+               151 -> return E256_152+               152 -> return E256_153+               153 -> return E256_154+               154 -> return E256_155+               155 -> return E256_156+               156 -> return E256_157+               157 -> return E256_158+               158 -> return E256_159+               159 -> return E256_160+               160 -> return E256_161+               161 -> return E256_162+               162 -> return E256_163+               163 -> return E256_164+               164 -> return E256_165+               165 -> return E256_166+               166 -> return E256_167+               167 -> return E256_168+               168 -> return E256_169+               169 -> return E256_170+               170 -> return E256_171+               171 -> return E256_172+               172 -> return E256_173+               173 -> return E256_174+               174 -> return E256_175+               175 -> return E256_176+               176 -> return E256_177+               177 -> return E256_178+               178 -> return E256_179+               179 -> return E256_180+               180 -> return E256_181+               181 -> return E256_182+               182 -> return E256_183+               183 -> return E256_184+               184 -> return E256_185+               185 -> return E256_186+               186 -> return E256_187+               187 -> return E256_188+               188 -> return E256_189+               189 -> return E256_190+               190 -> return E256_191+               191 -> return E256_192+               192 -> return E256_193+               193 -> return E256_194+               194 -> return E256_195+               195 -> return E256_196+               196 -> return E256_197+               197 -> return E256_198+               198 -> return E256_199+               199 -> return E256_200+               200 -> return E256_201+               201 -> return E256_202+               202 -> return E256_203+               203 -> return E256_204+               204 -> return E256_205+               205 -> return E256_206+               206 -> return E256_207+               207 -> return E256_208+               208 -> return E256_209+               209 -> return E256_210+               210 -> return E256_211+               211 -> return E256_212+               212 -> return E256_213+               213 -> return E256_214+               214 -> return E256_215+               215 -> return E256_216+               216 -> return E256_217+               217 -> return E256_218+               218 -> return E256_219+               219 -> return E256_220+               220 -> return E256_221+               221 -> return E256_222+               222 -> return E256_223+               223 -> return E256_224+               224 -> return E256_225+               225 -> return E256_226+               226 -> return E256_227+               227 -> return E256_228+               228 -> return E256_229+               229 -> return E256_230+               230 -> return E256_231+               231 -> return E256_232+               232 -> return E256_233+               233 -> return E256_234+               234 -> return E256_235+               235 -> return E256_236+               236 -> return E256_237+               237 -> return E256_238+               238 -> return E256_239+               239 -> return E256_240+               240 -> return E256_241+               241 -> return E256_242+               242 -> return E256_243+               243 -> return E256_244+               244 -> return E256_245+               245 -> return E256_246+               246 -> return E256_247+               247 -> return E256_248+               248 -> return E256_249+               249 -> return E256_250+               250 -> return E256_251+               251 -> return E256_252+               252 -> return E256_253+               253 -> return E256_254+               254 -> return E256_255+               255 -> return E256_256+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance () => Arbitrary E258 where+    arbitrary+      = do x <- choose (0 :: Int, 257)+           case x of+               0 -> return E258_1+               1 -> return E258_2+               2 -> return E258_3+               3 -> return E258_4+               4 -> return E258_5+               5 -> return E258_6+               6 -> return E258_7+               7 -> return E258_8+               8 -> return E258_9+               9 -> return E258_10+               10 -> return E258_11+               11 -> return E258_12+               12 -> return E258_13+               13 -> return E258_14+               14 -> return E258_15+               15 -> return E258_16+               16 -> return E258_17+               17 -> return E258_18+               18 -> return E258_19+               19 -> return E258_20+               20 -> return E258_21+               21 -> return E258_22+               22 -> return E258_23+               23 -> return E258_24+               24 -> return E258_25+               25 -> return E258_26+               26 -> return E258_27+               27 -> return E258_28+               28 -> return E258_29+               29 -> return E258_30+               30 -> return E258_31+               31 -> return E258_32+               32 -> return E258_33+               33 -> return E258_34+               34 -> return E258_35+               35 -> return E258_36+               36 -> return E258_37+               37 -> return E258_38+               38 -> return E258_39+               39 -> return E258_40+               40 -> return E258_41+               41 -> return E258_42+               42 -> return E258_43+               43 -> return E258_44+               44 -> return E258_45+               45 -> return E258_46+               46 -> return E258_47+               47 -> return E258_48+               48 -> return E258_49+               49 -> return E258_50+               50 -> return E258_51+               51 -> return E258_52+               52 -> return E258_53+               53 -> return E258_54+               54 -> return E258_55+               55 -> return E258_56+               56 -> return E258_57+               57 -> return E258_58+               58 -> return E258_59+               59 -> return E258_60+               60 -> return E258_61+               61 -> return E258_62+               62 -> return E258_63+               63 -> return E258_64+               64 -> return E258_65+               65 -> return E258_66+               66 -> return E258_67+               67 -> return E258_68+               68 -> return E258_69+               69 -> return E258_70+               70 -> return E258_71+               71 -> return E258_72+               72 -> return E258_73+               73 -> return E258_74+               74 -> return E258_75+               75 -> return E258_76+               76 -> return E258_77+               77 -> return E258_78+               78 -> return E258_79+               79 -> return E258_80+               80 -> return E258_81+               81 -> return E258_82+               82 -> return E258_83+               83 -> return E258_84+               84 -> return E258_85+               85 -> return E258_86+               86 -> return E258_87+               87 -> return E258_88+               88 -> return E258_89+               89 -> return E258_90+               90 -> return E258_91+               91 -> return E258_92+               92 -> return E258_93+               93 -> return E258_94+               94 -> return E258_95+               95 -> return E258_96+               96 -> return E258_97+               97 -> return E258_98+               98 -> return E258_99+               99 -> return E258_100+               100 -> return E258_101+               101 -> return E258_102+               102 -> return E258_103+               103 -> return E258_104+               104 -> return E258_105+               105 -> return E258_106+               106 -> return E258_107+               107 -> return E258_108+               108 -> return E258_109+               109 -> return E258_110+               110 -> return E258_111+               111 -> return E258_112+               112 -> return E258_113+               113 -> return E258_114+               114 -> return E258_115+               115 -> return E258_116+               116 -> return E258_117+               117 -> return E258_118+               118 -> return E258_119+               119 -> return E258_120+               120 -> return E258_121+               121 -> return E258_122+               122 -> return E258_123+               123 -> return E258_124+               124 -> return E258_125+               125 -> return E258_126+               126 -> return E258_127+               127 -> return E258_128+               128 -> return E258_129+               129 -> return E258_130+               130 -> return E258_131+               131 -> return E258_132+               132 -> return E258_133+               133 -> return E258_134+               134 -> return E258_135+               135 -> return E258_136+               136 -> return E258_137+               137 -> return E258_138+               138 -> return E258_139+               139 -> return E258_140+               140 -> return E258_141+               141 -> return E258_142+               142 -> return E258_143+               143 -> return E258_144+               144 -> return E258_145+               145 -> return E258_146+               146 -> return E258_147+               147 -> return E258_148+               148 -> return E258_149+               149 -> return E258_150+               150 -> return E258_151+               151 -> return E258_152+               152 -> return E258_153+               153 -> return E258_154+               154 -> return E258_155+               155 -> return E258_156+               156 -> return E258_157+               157 -> return E258_158+               158 -> return E258_159+               159 -> return E258_160+               160 -> return E258_161+               161 -> return E258_162+               162 -> return E258_163+               163 -> return E258_164+               164 -> return E258_165+               165 -> return E258_166+               166 -> return E258_167+               167 -> return E258_168+               168 -> return E258_169+               169 -> return E258_170+               170 -> return E258_171+               171 -> return E258_172+               172 -> return E258_173+               173 -> return E258_174+               174 -> return E258_175+               175 -> return E258_176+               176 -> return E258_177+               177 -> return E258_178+               178 -> return E258_179+               179 -> return E258_180+               180 -> return E258_181+               181 -> return E258_182+               182 -> return E258_183+               183 -> return E258_184+               184 -> return E258_185+               185 -> return E258_186+               186 -> return E258_187+               187 -> return E258_188+               188 -> return E258_189+               189 -> return E258_190+               190 -> return E258_191+               191 -> return E258_192+               192 -> return E258_193+               193 -> return E258_194+               194 -> return E258_195+               195 -> return E258_196+               196 -> return E258_197+               197 -> return E258_198+               198 -> return E258_199+               199 -> return E258_200+               200 -> return E258_201+               201 -> return E258_202+               202 -> return E258_203+               203 -> return E258_204+               204 -> return E258_205+               205 -> return E258_206+               206 -> return E258_207+               207 -> return E258_208+               208 -> return E258_209+               209 -> return E258_210+               210 -> return E258_211+               211 -> return E258_212+               212 -> return E258_213+               213 -> return E258_214+               214 -> return E258_215+               215 -> return E258_216+               216 -> return E258_217+               217 -> return E258_218+               218 -> return E258_219+               219 -> return E258_220+               220 -> return E258_221+               221 -> return E258_222+               222 -> return E258_223+               223 -> return E258_224+               224 -> return E258_225+               225 -> return E258_226+               226 -> return E258_227+               227 -> return E258_228+               228 -> return E258_229+               229 -> return E258_230+               230 -> return E258_231+               231 -> return E258_232+               232 -> return E258_233+               233 -> return E258_234+               234 -> return E258_235+               235 -> return E258_236+               236 -> return E258_237+               237 -> return E258_238+               238 -> return E258_239+               239 -> return E258_240+               240 -> return E258_241+               241 -> return E258_242+               242 -> return E258_243+               243 -> return E258_244+               244 -> return E258_245+               245 -> return E258_246+               246 -> return E258_247+               247 -> return E258_248+               248 -> return E258_249+               249 -> return E258_250+               250 -> return E258_251+               251 -> return E258_252+               252 -> return E258_253+               253 -> return E258_254+               254 -> return E258_255+               255 -> return E258_256+               256 -> return E258_257+               257 -> return E258_258+               _ -> error "FATAL ERROR: Arbitrary instance, logic bug"+-- GENERATED STOP+#endif

@@ -0,0 +1,60 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE StandaloneDeriving #-}+module Test.E.Flat() where++import           Data.Flat+import           Data.Flat.Decoder+import           Data.Flat.Encoder+import           Test.E++t = putStrLn $ gen 4++-- Test only, incorrect instances+-- Not faster than generated ones (at least up to E16)+gen :: Int -> String+gen numBits =+    let dt = "E"++show n+        n = 2 ^ numBits+        cs = zip [1..] $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n]+        dec n c = unwords ["      ",n,"-> return",c]+    in unlines [+        unwords ["instance Flat",dt,"where"]+        ,"  size _ n = n+"++ show numBits+        ,"  encode a = case a of"+        ,unlines $ map (\(n,c) -> unwords ["    ",c,"-> eBits16",show numBits,show n]) cs+        ,"  decode = do"+        ,"     tag <- dBEBits8 " ++ show numBits+        ,"     case tag of"+        ,unlines $ map (\(n,c) -> dec (show n) c) cs+        ,dec "_" (snd $ last cs)+        ]+++deriving instance Flat S3+deriving instance Flat E2+deriving instance Flat E3+deriving instance Flat E4+deriving instance Flat E8+deriving instance Flat E16+deriving instance Flat E17+deriving instance Flat E32++#ifdef ENUM_LARGE+deriving instance Flat E256+deriving instance Flat E258+#endif++-- fs =+--     [ flat E2_1,flat E3_1+--     , flat E4_1+--     , flat E8_1+--     , flat E16_1+--     , flat E32_1+--     , flat E256_255+--     , flat E256_254+--     , flat E256_253+--     , flat E256_256+--     ]++