flat 0.3.4 → 0.4

raw patch · 80 files changed

+6388/−4008 lines, 80 filesdep +HUnitdep +filepathdep +hashabledep ~QuickCheckdep ~arraydep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, filepath, hashable, memory, quickcheck-instances, quickcheck-text, unordered-containers

Dependency ranges changed: QuickCheck, array, base, bytestring, containers, deepseq, dlist, ghc-prim, mono-traversable, pretty, primitive, tasty, text, vector

API changes (from Hackage documentation)

Files

• CHANGELOG +11/−4
• README.md +16/−148
• flat.cabal +349/−123
• src/Data/ByteString/Convert.hs +10/−7
• src/Data/Flat.hs +0/−19
• src/Data/Flat/Bits.hs +0/−72
• src/Data/Flat/Class.hs +0/−453
• src/Data/Flat/Decoder.hs +0/−47
• src/Data/Flat/Decoder/Prim.hs +0/−391
• src/Data/Flat/Decoder/Strict.hs +0/−245
• src/Data/Flat/Decoder/Types.hs +0/−137
• src/Data/Flat/Encoder.hs +0/−68
• src/Data/Flat/Encoder/Prim.hs +0/−402
• src/Data/Flat/Encoder/Size.hs +0/−178
• src/Data/Flat/Encoder/Strict.hs +0/−246
• src/Data/Flat/Encoder/Types.hs +0/−25
• src/Data/Flat/Endian.hs +0/−61
• src/Data/Flat/Filler.hs +0/−60
• src/Data/Flat/Instances.hs +0/−230
• src/Data/Flat/Memory.hs +0/−113
• src/Data/Flat/Run.hs +0/−44
• src/Data/Flat/Types.hs +0/−28
• src/Data/FloatCast.hs +68/−30
• src/Data/ZigZag.hs +88/−50
• src/Flat.hs +19/−0
• src/Flat/Bits.hs +105/−0
• src/Flat/Class.hs +456/−0
• src/Flat/Decoder.hs +50/−0
• src/Flat/Decoder/Prim.hs +412/−0
• src/Flat/Decoder/Strict.hs +267/−0
• src/Flat/Decoder/Types.hs +159/−0
• src/Flat/Encoder.hs +80/−0
• src/Flat/Encoder/Prim.hs +434/−0
• src/Flat/Encoder/Size.hs +189/−0
• src/Flat/Encoder/Strict.hs +292/−0
• src/Flat/Encoder/Types.hs +25/−0
• src/Flat/Endian.hs +83/−0
• src/Flat/Filler.hs +75/−0
• src/Flat/Instances.hs +15/−0
• src/Flat/Instances/Array.hs +72/−0
• src/Flat/Instances/Base.hs +540/−0
• src/Flat/Instances/ByteString.hs +87/−0
• src/Flat/Instances/Containers.hs +109/−0
• src/Flat/Instances/DList.hs +27/−0
• src/Flat/Instances/Mono.hs +199/−0
• src/Flat/Instances/Test.hs +44/−0
• src/Flat/Instances/Text.hs +91/−0
• src/Flat/Instances/Unordered.hs +47/−0
• src/Flat/Instances/Util.hs +46/−0
• src/Flat/Instances/Vector.hs +45/−0
• src/Flat/Memory.hs +118/−0
• src/Flat/Run.hs +64/−0
• src/Flat/Tutorial.hs +161/−0
• src/Flat/Types.hs +23/−0
• stack.yaml +17/−11
• test/DocTest.hs +169/−0
• test/DocTest/Data/FloatCast.hs +11/−0
• test/DocTest/Data/ZigZag.hs +14/−0
• test/DocTest/Flat/Bits.hs +12/−0
• test/DocTest/Flat/Decoder/Prim.hs +13/−0
• test/DocTest/Flat/Endian.hs +10/−0
• test/DocTest/Flat/Instances/Array.hs +16/−0
• test/DocTest/Flat/Instances/Base.hs +19/−0
• test/DocTest/Flat/Instances/ByteString.hs +14/−0
• test/DocTest/Flat/Instances/Containers.hs +15/−0
• test/DocTest/Flat/Instances/DList.hs +14/−0
• test/DocTest/Flat/Instances/Mono.hs +14/−0
• test/DocTest/Flat/Instances/Text.hs +14/−0
• test/DocTest/Flat/Instances/Unordered.hs +16/−0
• test/DocTest/Flat/Instances/Vector.hs +14/−0
• test/DocTest/Flat/Tutorial.hs +15/−0
• test/DocTests.hs +20/−0
• test/Spec.hs +801/−624
• test/Test/Data.hs +159/−93
• test/Test/Data/Arbitrary.hs +18/−8
• test/Test/Data/Flat.hs +77/−73
• test/Test/Data/Values.hs +34/−12
• test/Test/Data2/Flat.hs +1/−1
• test/Test/E.hs +1/−1
• test/Test/E/Flat.hs +4/−4

@@ -1,15 +1,22 @@ Significant and compatibility-breaking changes. +Version 0.4:+    - Compatibility with ghc 8.8.3+	- Changed namespace from Data.Flat to Flat+	- Addtional Flat Instances for some common packages: array, base, bytestring, containers, dlist, text, unordered-containers, vector+	- Additional doctests, with a static version that can run without ghci and therefore also under ghcjs/eta (run it with stack test :doc-static)+	- Many minor 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.2:+	- Tested with ghc 8.2.1+	- Dropped dependencies on the 'cpu', 'derive' and 'tasty' packages to make it compatible with the Eta compiler (https://github.com/typelead/eta)+ 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 	- Added some decoding primitives 	- Added Data.ByteString.Convert--Version 0.3.1:-	- Tested with ghc 8.2.1-	- Dropped dependencies on the 'cpu', 'derive' and 'tasty' packages to make it compatible with the Eta compiler (https://github.com/typelead/eta)

@@ -2,174 +2,42 @@ [![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) -Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, portable and efficient binary data format ([specs](http://quid2.org)).--### How To Use It For Fun and Profit--To (de)serialise a data type, make it an instance of the `Flat` class.--There is `Generics` based support to automatically derive instances of additional types.--Let's see some code, we need a couple of extensions:--```haskell-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}-```--Import the Flat library:--```haskell-import Data.Flat-```--Define a couple of custom data types, deriving Generic and Flat:--```haskell-data Direction = North | South | Center | East | West deriving (Show,Generic,Flat)-```--```haskell-data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat)-```--For encoding, use `flat`, for decoding, use `unflat`:--```haskell-unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction)--> Right (Cons North (Cons South Nil))-```---For the decoding to work correctly, you will naturally need to know the type of the serialised data. This is ok for applications that do not require long-term storage and that do not need to communicate across independently evolving agents. For those who do, you will need to supplement `flat` with something like [zm](https://github.com/Quid2/zm).--#### Define Instances for Abstract/Primitive types-- A set of primitives are available to define `Flat` instances for abstract or primitive types.-- Instances for some common, primitive or abstract data types (Bool,Words,Int,String,Text,ByteStrings,Tuples, Lists, Sequences, Maps ..) are already defined in [Data.Flat.Instances](https://github.com/Quid2/flat/blob/master/src/Data/Flat/Instances.hs).--#### Optimal Bit-Encoding--A pecularity of Flat is that it uses an optimal bit-encoding rather than the usual byte-oriented one.-- To see this, let's define a pretty printing function: `bits` encodes a value as a sequence of bits, `prettyShow` displays it nicely:--```haskell-p :: Flat a => a -> String-p = prettyShow . bits-```--Now some encodings:--```haskell-p West--> "111"-```---```haskell-p (Nil::List Direction)--> "0"-```---```haskell-aList = Cons North (Cons South (Cons Center (Cons East (Cons West Nil))))-p aList--> "10010111 01110111 10"-```---As you can see, `aList` fits in less than 3 bytes rather than 11 as would be the case with other Haskell byte oriented serialisation packages like `binary` or `store`.--For the serialisation to work with byte-oriented devices or storage, we need to add some padding:--```haskell-f :: Flat a => a -> String-f = prettyShow . paddedBits-```--```haskell-f West--> "11100001"-```---```haskell-f (Nil::List Direction)--> "00000001"-```---```haskell-f $ Cons North (Cons South (Cons Center (Cons East (Cons West Nil))))--> "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`.+Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, language-independent and efficient binary data format.  ### Performance  For some hard data, see this [comparison of the major haskell serialisation libraries](https://github.com/haskell-perf/serialization).  Briefly:- * Size: `flat` produces significantly smaller binaries than all other libraries (3/4 times usually)- * Encoding: `store` 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--### Compatibility--#### [GHC](https://www.haskell.org/ghc/) --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)--####  [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`.--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.--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`+ * Size: `flat` produces significantly smaller binaries than all other libraries (3/4 times usually)+ * Serialization: `store`, `persist` and `flat` are faster+ * Deserialization: `store`, `flat`, `persist` and `cereal` are faster -NOTE: Versions prior to 0.33 encode `Double` values incorrectly when they are not aligned with a byte boundary.+### Documentation -NOTE: A native [TypeScript/JavaScript version](https://github.com/Quid2/ts) of `flat` is under development.+* [Tutorial](docs/src/Flat-Tutorial.html) -#### [ETA](https://eta-lang.org/)+* [Full Package Docs](docs/src) -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.+* [Flat Format Specification](http://quid2.org)  ### Installation  Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat). -### Known Bugs and Infelicities--#### Longish compilation times--'flat` relies more than other serialisation libraries on extensive inlining for its good performance, this unfortunately leads to longer compilation times. --If you have many data types or very large ones this might become an issue.+### Other Stuff You Might Like -A couple of good practices that will eliminate or mitigate this problem are:+#### [ZM - Language independent, reproducible, absolute types](https://github.com/Quid2/zm) -* During development, turn optimisations off (`stack --fast` or `-O0` in the cabal file).+To decode `flat` encoded data you need to know the type of the serialised data. -* Keep your serialisation code in a separate module(s).+This is ok for applications that do not require long-term storage and that do not operate in open distributed systems. -#### Data types with more than 512 constructors are currently unsupported+For those who do, you might want to supplement `flat` with something like [ZM](https://github.com/Quid2/zm). -See also the [full list of open issues](https://github.com/Quid2/flat/issues).+#### Ports for other languages -### Acknowledgements+[TypeScript-JavaScript](https://github.com/Quid2/ts) and [Purescript](https://www.purescript.org/) ports are under development. - `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes contributions from Justus Sagemüller.+Get in touch if you would like to help porting `flat` to other languages.

@@ -1,140 +1,366 @@-name: flat-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://quid2.org-category: Data,Parsing,Serialization-license:             BSD3-license-file:        LICENSE-author:              Pasqualino `Titto` Assini-maintainer:          tittoassini@gmail.com-copyright:           Copyright: (c) 2016-2018 Pasqualino `Titto` Assini-cabal-version: >=1.10-build-type: Simple-Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.1+cabal-version:      >=1.10+name:               flat+version:            0.4+license:            BSD3+license-file:       LICENSE+copyright:          Copyright: (c) 2016-2020 Pasqualino `Titto` Assini+maintainer:         tittoassini@gmail.com+author:             Pasqualino `Titto` Assini+tested-with:+  GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 +homepage:           http://quid2.org+synopsis:           Principled and efficient bit-oriented binary serialization.+description:        Reference implementation of `flat`, a principled and efficient binary serialization format.+category:           Data,Parsing,Serialization+build-type:         Simple extra-source-files:-    stack.yaml-    README.md-    CHANGELOG+  stack.yaml+  README.md+  CHANGELOG  source-repository head-    type: git-    location: https://github.com/Quid2/flat+  type:     git+  location: https://github.com/Quid2/flat  library-    exposed-modules:-        Data.ByteString.Convert-        Data.Flat.Bits-        Data.Flat.Class-        Data.Flat.Decoder-        Data.Flat.Decoder.Prim-        Data.Flat.Decoder.Strict-        Data.Flat.Decoder.Types-        Data.Flat.Encoder-        Data.Flat.Encoder.Prim-        Data.Flat.Encoder.Size-        Data.Flat.Encoder.Strict-        Data.Flat.Encoder.Types-        Data.Flat.Filler-        Data.Flat.Memory-        Data.Flat.Run-        Data.Flat.Types-        Data.Flat-        Data.FloatCast-        Data.ZigZag-        Data.Flat.Instances-        Data.Flat.Endian                  +  exposed-modules:+    Data.ByteString.Convert+    Data.FloatCast+    Data.ZigZag+    Flat+    Flat.Bits+    Flat.Class+    Flat.Decoder+    Flat.Decoder.Prim+    Flat.Decoder.Strict+    Flat.Decoder.Types+    Flat.Encoder+    Flat.Encoder.Prim+    Flat.Encoder.Size+    Flat.Encoder.Strict+    Flat.Encoder.Types+    Flat.Endian+    Flat.Filler+    Flat.Instances+    Flat.Instances.Array+    Flat.Instances.Base+    Flat.Instances.ByteString+    Flat.Instances.Containers+    Flat.Instances.DList+    Flat.Instances.Mono+    Flat.Instances.Test+    Flat.Instances.Text+    Flat.Instances.Unordered+    Flat.Instances.Util+    Flat.Instances.Vector+    Flat.Memory+    Flat.Run+    Flat.Types+    Flat.Tutorial +  hs-source-dirs:   src+  default-language: Haskell2010+  other-extensions:+    NoMonomorphismRestriction+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    FlexibleContexts+    FlexibleInstances+    OverloadedStrings+    PolyKinds+    ScopedTypeVariables+    TupleSections+    TypeFamilies+    TypeOperators+    UndecidableInstances++  ghc-options:+    -Wall -O2 -funbox-strict-fields -fno-warn-orphans+    -fno-warn-name-shadowing+  --  -Werror++  if impl(eta -any)     build-depends:-        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+        array                 ==0.5.2.0+      , base+      , bytestring            ==0.10.8.2+      , containers            ==0.5.9.1+      , deepseq               ==1.4.3.0+      , dlist+      , filepath              ==1.4.1.1+      , ghc-prim              ==0.4.0.0+      , hashable              >=1.2.4.0  && <=1.2.7.0+      , HUnit                 ==1.6.0.0+      , memory                >=0.14.10  && <=0.14.14+      , mono-traversable      ==1.0.1+      , pretty                >=1.1.3.4  && <=1.1.3.6+      , primitive             >=0.6.1.0  && <=0.6.4.0+      , QuickCheck            ==2.10+      , tasty                 ==1.1.0.3+      , text                  ==1.2.3.0+      , unordered-containers  >=0.2.7.1  && <=0.2.9.0+      , vector                >=0.11.0.0 && <=0.12.0.1 -    if impl(ghc < 8.0)-      build-depends: semigroups+  else+    build-depends:+        array                 >=0.5.1.0+      , base                  >=4.8     && <5+      , bytestring            >=0.10.6+      , containers+      , deepseq               >=1.4+      , dlist                 >=0.6+      , ghc-prim+      , hashable+      , mono-traversable+      , pretty                >=1.1.2+      , primitive+      , semigroups+      , text+      , unordered-containers+      , vector -    default-language: Haskell2010-    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: -Wall -O2 -funbox-strict-fields -fno-warn-orphans -fno-warn-name-shadowing+-- , base                  >=4.8.2.0 && <5+-- if impl(ghc <8.2)+--   build-depends: semigroups >=0.8.4 && <0.17 --- Full test suite test-suite spec-    type: exitcode-stdio-1.0-    main-is: Spec.hs+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  cpp-options:      -DLIST_BIT -DTEST_DECBITS++  if impl(ghc <8.6)+    cpp-options: -DENUM_LARGE++  -- -DETA_VERSION -Dghcjs_HOST_OS++  -- ghc-options: -O1 +  if impl(ghc >8)+    ghc-options: -Wno-unused-top-binds -Wno-type-defaults -Wno-missing-signatures+  hs-source-dirs:   test+  other-modules:+    Test.Data+    Test.Data.Arbitrary+    Test.Data.Flat+    Test.Data.Values+    Test.Data2+    Test.Data2.Flat+    Test.E+    Test.E.Arbitrary+    Test.E.Flat++  default-language: Haskell2010+  build-depends:+      base+    , flat+    , ghc-prim+    , quickcheck-text+    , tasty-hunit+    , tasty-quickcheck+    , text++  if impl(ghc <8)+    build-depends: semigroups++  if impl(eta -any)     build-depends:-                  base-                , ghc-prim-                , tasty -                -- >= 1-                , tasty-hunit -                -- >= 0.8-                , tasty-quickcheck -                -- >=0.9-                , containers-                , deepseq == 1.4.*-                , QuickCheck >= 2.10-                , text-                , bytestring-                , array-                , flat+        array             ==0.5.2.0+      , bytestring        ==0.10.8.2+      , containers        ==0.5.9.1+      , deepseq           ==1.4.3.0+      , filepath          ==1.4.1.1+      , HUnit             ==1.6.0.0+      , mono-traversable  ==1.0.1+      , QuickCheck        ==2.10+      , tasty             ==1.1.0.3+      , text              ==1.2.3.0 -    default-language: Haskell2010-    hs-source-dirs: test-    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+  else+    build-depends:+        array+      , bytestring+      , containers+      , deepseq+      , filepath+      , mono-traversable+      , QuickCheck+      , tasty+      , text --- Tests embedded in code documentation (won't compile with ghcjs)--- test-suite docs---   default-language:   Haskell2010---   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+-- dynamic doctests and generation of static doctests+-- Usable only with recent versions of ghc (no ghcjs or eta)+-- test-suite doc+--   type:             exitcode-stdio-1.0+--   main-is:          DocSpec.hs+--   hs-source-dirs:   test+--   default-language: Haskell2010+--   build-depends:+--       base+--     , directory+--     , doctest    ==0.16.3.1+--     , filemanip  >=0.3.6.3+--     , text++-- static doctests (faster, useful for test coverage and to test ghcjs and eta)+test-suite doc-static+  type:             exitcode-stdio-1.0+  main-is:          DocTests.hs+  hs-source-dirs:   test+  other-modules:+    DocTest+    DocTest.Data.FloatCast+    DocTest.Data.ZigZag+    DocTest.Flat.Decoder.Prim+    DocTest.Flat.Endian+    DocTest.Flat.Instances.Array+    DocTest.Flat.Instances.Base+    DocTest.Flat.Instances.ByteString+    DocTest.Flat.Instances.Containers+    DocTest.Flat.Instances.DList+    DocTest.Flat.Instances.Mono+    DocTest.Flat.Instances.Text+    DocTest.Flat.Instances.Unordered+    DocTest.Flat.Instances.Vector+    DocTest.Flat.Bits+    DocTest.Flat.Tutorial++  default-language: Haskell2010+  build-depends:+      array+    , base+    , bytestring+    , containers+    , dlist+    , flat+    , pretty+    , quickcheck-instances>=0.3.22+    , QuickCheck >= 2.13.2 && < 3+    -- , splitmix >= 0.0.2+    -- , time-compat >= 1.9.3+    , hashable >= 1.2.6.1 && < 1.4+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , text+    , unordered-containers+    , vector++  if impl(ghc <8)+    build-depends: semigroups+++  --ghc-options: -Wno-unused-top-binds -Wno-type-defaults++-- Additional development time tests and benchmarks+-- test-suite core+--   type:             exitcode-stdio-1.0+--   main-is:          Core.hs+--   hs-source-dirs:   test+--   default-language: Haskell2010+--   ghc-options:      -O2+--   other-modules:+--   other-modules:+--     Test.Data+--     Test.Data.Values+--     Test.Data2+--     Test.Data2.Flat+--     Test.E+--     Test.E.Flat+--     Test.Data.Flat+--   build-depends:+--       base+--     , benchpress+--     , bytestring+--     , containers+--     , deepseq+--     , flat+--     , text+--     ,inspection-testing++-- executable listTest+--   main-is:          ListTest.hs+--   hs-source-dirs:   test+--   default-language: Haskell2010+--   build-depends:+--       base+--     , flat+--     , text+--     , time++-- benchmark microBench+--   type:             exitcode-stdio-1.0+--   main-is:          Micro.hs+--   hs-source-dirs:   benchmarks test+--   other-modules:+--     Common+--     Test.Data+--     Test.Data.Values+--     Test.Data2+--     Test.Data2.Flat+--     Test.E+--     Test.E.Flat+--     Test.Data.Flat++--   default-language: Haskell2010+--   build-depends:+--       base+--     , benchpress+--     , bytestring+--     , containers+--     , deepseq+--     , flat+--     , text++-- benchmark miniBench+--   type:             exitcode-stdio-1.0+--   main-is:          Mini.hs+--   hs-source-dirs:   benchmarks test+--   other-modules:+--     Report+--     Test.Data+--     Test.Data.Values+--     Test.Data2+--     Test.Data2.Flat+--     Test.E+--     Test.E.Flat+--     Test.Data.Flat++--   default-language: Haskell2010+--   ghc-options:      -O2+--   build-depends:+--       base+--     , flat+--     , text++--   if impl(eta -any) --     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+--         bytestring         ==0.10.8.2+--       , containers         ==0.5.9.1+--       , criterion          ==1.5.1.0+--       , deepseq            ==1.4.3.0+--       , directory          ==1.3.1.0+--       , filepath           ==1.4.1.1+--       , mono-traversable   ==1.0.1+--       , process            ==1.6.2.0+--       , statistics         ==0.14.0.2+--       , text               ==1.2.3.0+--       , vector-algorithms  ==0.7.0.1++--   else+--     build-depends:+--         bytestring+--       , containers+--       , criterion+--       , deepseq+--       , directory+--       , filepath+--       , mono-traversable+--       , process+--       , statistics+--       , text

@@ -1,24 +1,27 @@ {-# LANGUAGE FlexibleInstances #-}--- |Convert to/from strict ByteStrings-module Data.ByteString.Convert (AsByteString(..)) where+module Data.ByteString.Convert+  ( AsByteString(..)+  )+where -import qualified Data.ByteString      as B-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString               as B+import qualified Data.ByteString.Lazy          as L import           Data.Word +-- |Convert to/from strict ByteStrings class AsByteString a where   toByteString :: a -> B.ByteString   fromByteString :: B.ByteString -> a  instance AsByteString B.ByteString where-  toByteString = id+  toByteString   = id   fromByteString = id  instance AsByteString L.ByteString where-  toByteString = L.toStrict+  toByteString   = L.toStrict   fromByteString = L.fromStrict  instance AsByteString [Word8] where-  toByteString = B.pack+  toByteString   = B.pack   fromByteString = B.unpack 

@@ -1,19 +0,0 @@-module Data.Flat (-    -- |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,-    Decoded,-    DecodeException,-    ) where--import           Data.Flat.Class-import           Data.Flat.Decoder-import           Data.Flat.Filler-import           Data.Flat.Instances-import           Data.Flat.Run-import           Data.Flat.Types

@@ -1,72 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeSynonymInstances #-}---- |Utilities to represent and display bit sequences-module Data.Flat.Bits (-    Bits,-    toBools,-    fromBools,-    bits,-    paddedBits,-    asBytes,-    asBits,-    ) where--import           Data.Bits                      hiding (Bits)-import qualified Data.ByteString                as B-import           Data.Flat.Class-import           Data.Flat.Decoder-import           Data.Flat.Filler-import           Data.Flat.Run-import qualified Data.Vector.Unboxed            as V-import           Data.Word-import           Text.PrettyPrint.HughesPJClass---- |A sequence of bits-type Bits = V.Vector Bool--toBools :: Bits -> [Bool]-toBools = V.toList--fromBools :: [Bool] -> Bits-fromBools = V.fromList---- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding)-bits :: forall a. Flat a => a -> Bits-bits v = let lbs = flat v-             Right (PostAligned _ f) = unflatRaw lbs :: Decoded (PostAligned a)-         in takeBits (8 * B.length lbs - fillerLength f) lbs---- |The sequence of bits corresponding to the byte-padded serialization of the passed value-paddedBits :: forall a. Flat a => a -> Bits-paddedBits v = let lbs = flat v-               in takeBits (8 * B.length lbs) lbs--takeBits :: Int -> B.ByteString -> Bits-takeBits numBits lbs  = V.generate (fromIntegral numBits) (\n -> let (bb,b) = n `divMod` 8 in testBit (B.index lbs (fromIntegral bb)) (7-b))---- | asBits (5::Word8)--- | > [False,False,False,False,False,True,False,True]-asBits :: FiniteBits a => a -> Bits-asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s-1-))---- |Convert a sequence of bits to the corresponding list of bytes-asBytes :: Bits -> [Word8]-asBytes = map byteVal . bytes .  V.toList---- |Convert to the corresponding value (most significant bit first)-byteVal :: [Bool] -> Word8-byteVal = sum . map (\(e,b) -> if b then e else 0). zip [2 ^ n | n <- [7::Int,6..0]]---- |Split a list in groups of 8 elements or less-bytes :: [t] -> [[t]]-bytes [] = []-bytes l  = let (w,r) = splitAt 8 l in w : bytes r--instance Pretty Bits where pPrint = hsep . map prettyBits . bytes .  V.toList--prettyBits :: Foldable t => t Bool -> Doc-prettyBits l = text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l-

@@ -1,453 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes       #-}-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE DefaultSignatures         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE KindSignatures            #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE Trustworthy               #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeOperators             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE UndecidableInstances      #-}---- |Generics-based generation of Flat instances-module Data.Flat.Class-  (-  -- * The Flat class-    Flat(..)-  , getSize-  , module GHC.Generics-  )-where--import           Data.Bits-import           Data.Flat.Decoder-import           Data.Flat.Encoder-import           Data.Word-import           GHC.Generics-import           GHC.TypeLits-import           Prelude           hiding (mempty)---- 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-    encode :: a -> Encoding-    default encode :: (Generic a, GEncode (Rep a)) => a -> Encoding-    encode = gencode . from--    decode :: Get a-    default decode :: (Generic a, GDecode (Rep a)) => Get a-    decode = to `fmap` gget--    size :: a -> NumBits -> NumBits-    default size :: (Generic a, GSize (Rep a)) => a -> NumBits -> NumBits-    size !x !n = gsize n $ from x--#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 a -> Encoding--instance {-# OVERLAPPABLE #-} GEncode f => GEncode (M1 i c f) where-      gencode = gencode . unM1-      {-# INLINE gencode #-}--  -- Special case, single constructor datatype-instance {-# OVERLAPPING #-} GEncode a => GEncode (D1 i (C1 c a)) where-      gencode = gencode . unM1 . unM1-      {-# INLINE gencode #-}--  -- Type without constructors-instance GEncode V1 where-      gencode = unused-      {-# INLINE gencode #-}--  -- Constructor without arguments-instance GEncode U1 where-      gencode U1 = mempty-      {-# INLINE gencode #-}--instance Flat a => GEncode (K1 i a) where-      {-# INLINE gencode #-}-#if INL == 1-      gencode x = inline encode (unK1 x)-#else-      gencode = encode . unK1-#endif--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 #-}--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 #-}---- Constructor Encoding-class GEncodeSum f where-  gencodeSum :: Word16 -> NumBits -> f a -> Encoding--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 #-}--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-  gget :: Get (f t)---- Metadata (constructor name, etc)-instance GDecode a => GDecode (M1 i c a) where-    gget = M1 <$> gget-    {-# INLINE  gget #-}---- Type without constructors-instance GDecode V1 where-    gget = unused-    {-# INLINE  gget #-}---- Constructor without arguments-instance GDecode U1 where-    gget = pure U1-    {-# INLINE  gget #-}---- Product: constructor with parameters-instance (GDecode a, GDecode b) => GDecode (a :*: b) where-  gget = (:*:) <$> gget <*> gget-  {-# INLINE gget #-}---- 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 #-}----- 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-    cs <- consOpen-    getSum cs-  {-# INLINE gget #-}---- 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 #-}---- Type without constructors-instance GSize V1 where-    gsize !n _ = n-    {-# INLINE gsize #-}---- Constructor without arguments-instance GSize U1 where-    gsize !n _ = n-    {-# INLINE gsize #-}---- Skip metadata-instance Flat a => GSize (K1 i a) where-#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 #-}---- Different size implementations-#define SIZ_ADD--- #define SIZ_NUM---- #define SIZ_MAX--- #define SIZ_MAX_VAL--- #define SIZ_MAX_PROX--#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) => GSizeSum (C1 c a) where-    {-# INLINE gsizeSum #-}-    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.."

@@ -1,47 +0,0 @@--- |Strict Decoder-module Data.Flat.Decoder (-    strictDecoder,-    strictDecoderPart,-    Decoded,-    DecodeException,-    Get,-    dByteString,-    dLazyByteString,-    dShortByteString,-    dShortByteString_,-    dUTF16,-    dUTF8,-    decodeArrayWith,-    decodeListWith,-    dFloat,-    dDouble,-    dInteger,-    dNatural,-    dChar,-    dBool,-    dWord8,-    dWord16,-    dWord32,-    dWord64,-    dWord,-    dInt8,-    dInt16,-    dInt32,-    dInt64,-    dInt,-    dBE8,-    dBE16,-    dBE32,-    dBE64,-    dBEBits8,-    dBEBits16,-    dBEBits32,-    dBEBits64,-    dropBits,--    ConsState(..),consOpen,consClose,consBool,consBits-    ) where--import           Data.Flat.Decoder.Prim-import           Data.Flat.Decoder.Strict-import           Data.Flat.Decoder.Types

@@ -1,391 +0,0 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}--- |Strict Decoder Primitives-module Data.Flat.Decoder.Prim (-    dBool,-    dWord8,-    dBE8,-    dBE16,-    dBE32,-    dBE64,-    dBEBits8,-    dBEBits16,-    dBEBits32,-    dBEBits64,-    dropBits,-    dFloat,-    dDouble,-    getChunksInfo,-    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---- $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 ()-ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s--{-# INLINE dropBits #-}--- |Drop the specified number of bits-dropBits :: Int -> Get ()-dropBits n-  | n > 0 = Get $ \endPtr s -> do-      ensureBits endPtr s n-      return $ GetResult (dropBits_ s n) ()-  | 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-  -- 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 ->-  if currPtr s >= endPtr-    then notEnoughSpace endPtr s-    else do-      !w <- peek (currPtr 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) [0b11100001::Word8] == Right 0b00000111--- True-dBEBits8 :: Int -> Get Word8-dBEBits8 n = Get $ \endPtr s -> do-      ensureBits endPtr s n-      take8 s n--{-# INLINE dBEBits16  #-}--- |Return the n most significant bits (up to maximum of 16)--- The bits are returned right shifted.-dBEBits16 :: Int -> Get Word16-dBEBits16 n = Get $ \endPtr s -> do-      ensureBits endPtr s n-      takeN n s--{-# INLINE dBEBits32  #-}--- |Return the n most significant bits (up to maximum of 8)--- The bits are returned right shifted.-dBEBits32 :: Int -> Get Word32-dBEBits32 n = Get $ \endPtr s -> do-      ensureBits endPtr s n-      takeN n s--{-# INLINE dBEBits64  #-}--- |Return the n most significant bits (up to maximum of 8)--- The bits are returned right shifted.-dBEBits64 :: Int -> Get Word64-dBEBits64 n = Get $ \endPtr s -> do-      ensureBits endPtr s n-      takeN n s---- {-# INLINE take8 #-}--- take8 :: Int -> S -> IO (GetResult Word8)--- take8 n s---   | n == 0 = return $ GetResult s 0----   -- all bits in the same byte---   | 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) `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) `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-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) `shR` (8 - n)-            else do -- two different bytes-              w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)-              return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)-          | otherwise = error $ unwords ["read8: cannot read",show n,"bits"]-    -- {-# 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-   where-     read s r sh n | n <=0 = return $ GetResult s r-                   | otherwise = do-                     let m = n `min` 8-                     GetResult s' b <- take8 s m-                     read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh-8) `max` 0) (n-8)---- takeN n = Get $ \endPtr s -> do---   ensureBits endPtr s n---   let (bytes,bits) = (n+usedBits s) `divMod` 8---   r <- case bytes of---     0 -> do---       w <- peek (currPtr s)---       return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `shR` (8 - n))---     1 -> do---       w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)---       return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)---     2 -> do---       let r = 0---       w1 <- fromIntegral <$> r8 s---       w2 <- fromIntegral <$> r16 s---       w1---   return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) r---- r8 s = peek (currPtr s)--- r16 s = toBE16 <$> peek (castPtr $ currPtr s)---- |Return the 8 most significant bits (same as dBE8)-dWord8 :: Get Word8-dWord8 = dBE8--{-# INLINE dBE8  #-}--- |Return the 8 most significant bits-dBE8 :: Get Word8-dBE8 = Get $ \endPtr s -> do-      ensureBits endPtr s 8-      !w1 <- peek (currPtr s)-      !w <- if usedBits s == 0-            then return w1-            else do-                   !w2 <- peek (currPtr s `plusPtr` 1)-                   return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `shR` (8-usedBits s))-      return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w--{-# INLINE dBE16 #-}--- |Return the 16 most significant bits-dBE16 :: Get Word16-dBE16 = Get $ \endPtr s -> do-  ensureBits endPtr s 16-  !w1 <- toBE16 <$> peek (castPtr $ currPtr s)-  !w <- if usedBits s == 0-        then return w1-        else do-           !(w2::Word8) <- peek (currPtr s `plusPtr` 2)-           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))-  return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w--{-# INLINE dBE32 #-}--- |Return the 32 most significant bits-dBE32 :: Get Word32-dBE32 = Get $ \endPtr s -> do-  ensureBits endPtr s 32-  !w1 <- toBE32 <$> peek (castPtr $ currPtr s)-  !w <- if usedBits s == 0-        then return w1-        else do-           !(w2::Word8) <- peek (currPtr s `plusPtr` 4)-           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))-  return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w--{-# INLINE dBE64 #-}--- |Return the 64 most significant bits-dBE64 :: Get Word64-dBE64 = Get $ \endPtr s -> do-  ensureBits endPtr s 64-  -- !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 `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-dFloat :: Get Float-dFloat = wordToFloat <$> dBE32--{-# INLINE dDouble #-}--- |Decode a Double-dDouble :: Get Double-dDouble = wordToDouble <$> dBE64---- |Decode a Lazy ByteString-dLazyByteString_ :: Get L.ByteString-dLazyByteString_ = L.fromStrict <$> dByteString_---- |Decode a ByteString-dByteString_ :: Get B.ByteString-dByteString_ = chunksToByteString <$> getChunksInfo---- |Decode a ByteArray and its length-dByteArray_ :: Get (ByteArray,Int)-dByteArray_ = chunksToByteArray <$> getChunksInfo---- |Decode an Array (a list of chunks up to 255 bytes long)--- returning the pointer to the first data byte and a list of chunk sizes-getChunksInfo :: Get (Ptr Word8, [Int])-getChunksInfo = Get $ \endPtr s -> do--   let getChunks srcPtr l = do-          ensureBits endPtr s 8-          n <- fromIntegral <$> peek srcPtr-          if n==0-            then return (srcPtr `plusPtr` 1,l [])-            else do-              ensureBits endPtr s ((n+1)*8)-              getChunks (srcPtr `plusPtr` (n+1)) (l . (n:))--   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

@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}--- |Strict Decoder-module Data.Flat.Decoder.Strict (-    decodeArrayWith,-    decodeListWith,-    dByteString,-    dLazyByteString,-    dShortByteString,-    dShortByteString_,-    dUTF16,-    dUTF8,-    dInteger,-    dNatural,-    dChar,-    dWord8,-    dWord16,-    dWord32,-    dWord64,-    dWord,-    dInt8,-    dInt16,-    dInt32,-    dInt64,-    dInt,-    ) where--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.Short.Internal as SBS-import qualified Data.DList                     as DL-import           Data.Flat.Decoder.Prim-import           Data.Flat.Decoder.Types-import           Data.Int-import           Data.Primitive.ByteArray-import qualified Data.Text                      as T-import qualified Data.Text.Array                as TA-import qualified Data.Text.Encoding             as T-import qualified Data.Text.Internal             as T-import           Data.Word-import           Data.ZigZag-import           GHC.Base                       (unsafeChr)-import           Numeric.Natural--#include "MachDeps.h"---{-# INLINE decodeListWith #-}-decodeListWith :: Get a -> Get [a]-decodeListWith dec = go-  where-    go = do-      b <- dBool-      if b-        then (:) <$> dec <*> go-        else return []--decodeArrayWith :: Get a -> Get [a]-decodeArrayWith dec = DL.toList <$> getAsL_ dec---- TODO: test if it would it be faster with DList.unfoldr :: (b -> Maybe (a, b)) -> b -> Data.DList.DList a---  getAsL_ :: Flat a => Get (DL.DList a)-getAsL_ :: Get a -> Get (DL.DList a)-getAsL_ dec = do-    tag <- dWord8-    case tag of-         0 -> return DL.empty-         _ -> do-           h <- gets tag-           t <- getAsL_ dec-           return (DL.append h t)--  where-    gets 0 = return DL.empty-    gets n = DL.cons <$> dec <*> gets (n-1)--{-# INLINE dNatural #-}-dNatural :: Get Natural-dNatural = fromInteger <$> dUnsigned--{-# INLINE dInteger #-}-dInteger :: Get Integer-dInteger = zzDecodeInteger <$> (dUnsigned::Get Integer)--{-# INLINE dWord  #-}-{-# INLINE dInt  #-}-dWord :: Get Word-dInt :: Get Int--#if WORD_SIZE_IN_BITS == 64-dWord = (fromIntegral :: Word64 -> Word) <$> dWord64-dInt = (fromIntegral :: Int64 -> Int) <$> dInt64--#elif WORD_SIZE_IN_BITS == 32-dWord = (fromIntegral :: Word32 -> Word) <$> dWord32-dInt = (fromIntegral :: Int32 -> Int) <$> dInt32--#else-#error expected WORD_SIZE_IN_BITS to be 32 or 64-#endif--{-# INLINE dInt8  #-}-dInt8 :: Get Int8-dInt8 = zzDecode8 <$> dWord8--{-# INLINE dInt16  #-}-dInt16 :: Get Int16-dInt16 = zzDecode16 <$> dWord16--{-# INLINE dInt32  #-}-dInt32 :: Get Int32-dInt32 = zzDecode32 <$> dWord32--{-# INLINE dInt64  #-}-dInt64 :: Get Int64-dInt64 = zzDecode64 <$> dWord64---- {-# INLINE dWord16  #-}-dWord16 :: Get Word16-dWord16 = wordStep 0 (wordStep 7 (lastStep 14)) 0---- {-# INLINE dWord32  #-}-dWord32 :: Get Word32-dWord32 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (lastStep 28)))) 0---- {-# INLINE dWord64  #-}-dWord64 :: Get Word64-dWord64 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (wordStep 28 (wordStep 35 (wordStep 42 (wordStep 49 (wordStep 56 (wordStep 63 (wordStep 70 (lastStep 77))))))))))) 0---{-# INLINE dChar #-}-dChar :: Get Char--- dChar = chr . fromIntegral <$> dWord32---- Not really faster than the simpler version above-dChar = charStep 0 (charStep 7 (lastCharStep 14)) 0--{-# INLINE charStep #-}-charStep :: Int -> (Int -> Get Char) -> Int -> Get Char-charStep !shl !cont !n = do-  !tw <- fromIntegral <$> dWord8-  let !w = tw .&. 127-  let !v = n .|. (w `shift` shl)-  if tw == w-    then return $ unsafeChr v-    else cont v--{-# INLINE lastCharStep #-}-lastCharStep :: Int -> Int -> Get Char-lastCharStep !shl !n = do-  !tw <- fromIntegral <$> dWord8-  let !w = tw .&. 127-  let !v = n .|. (w `shift` shl)-  if tw == w-    then if v > 0x10FFFF-         then charErr v-         else return $ unsafeChr v-    else charErr v--charErr :: (Show a1, Monad m) => a1 -> m a-charErr v = fail $ concat ["Unexpected extra byte or non unicode char",show v]--{-# INLINE wordStep #-}-wordStep-  :: (Bits a, Num a) => Int -> (a -> Get a) -> a -> Get a-wordStep shl k n = do-  tw <- fromIntegral <$> dWord8-  let w = tw .&. 127-  let v = n .|. (w `shift` shl)-  if tw == w-    then return v-    --else oneShot k v-    else k v--{-# INLINE lastStep #-}-lastStep :: (FiniteBits b, Show b, Num b) => Int -> b -> Get b-lastStep shl n = do-  tw <- fromIntegral <$> dWord8-  let w = tw .&. 127-  let v = n .|. (w `shift` shl)-  if tw == w-    then if countLeadingZeros w < shl-         then wordErr v-         else return v-    else wordErr v--wordErr :: (Show a1, Monad m) => a1 -> m a-wordErr v = fail $ concat ["Unexpected extra byte in unsigned integer",show v]---- {-# INLINE dUnsigned #-}-dUnsigned :: (Num b, Bits b) => Get b-dUnsigned = do-  (v,shl) <- dUnsigned_ 0 0-  maybe (return v) (\s -> if shl>= s then fail "Unexpected extra data in unsigned integer" else return v) $ bitSizeMaybe v---- {-# INLINE dUnsigned_ #-}-dUnsigned_ :: (Bits t, Num t) => Int -> t -> Get (t, Int)-dUnsigned_ shl n = do-  tw <- dWord8-  let w = tw .&. 127-  let v = n .|. (fromIntegral w `shift` shl)-  if tw == w-    then return (v,shl)-    else dUnsigned_ (shl+7) v----encode = encode . blob UTF8Encoding . L.fromStrict . T.encodeUtf8---decode = T.decodeUtf8 . L.toStrict . (unblob :: BLOB UTF8Encoding -> L.ByteString) <$> decode---- BLOB UTF16Encoding-dUTF16 :: Get T.Text-dUTF16 = do-  _ <- dFiller-  -- Checked decoding-  -- T.decodeUtf16LE <$> dByteString_-  -- Unchecked decoding-  (ByteArray array,lengthInBytes) <- dByteArray_-  return (T.Text (TA.Array array) 0 (lengthInBytes `div` 2))--dUTF8 :: Get T.Text-dUTF8 = do-  _ <- dFiller-  T.decodeUtf8 <$> dByteString_--dFiller :: Get ()-dFiller = do-  tag <- dBool-  case tag of-    False -> dFiller-    True  -> return ()--dLazyByteString :: Get L.ByteString-dLazyByteString = dFiller >> dLazyByteString_--dShortByteString :: Get SBS.ShortByteString-dShortByteString = dFiller >> dShortByteString_--dShortByteString_ :: Get SBS.ShortByteString-dShortByteString_ = do-  (ByteArray array,_) <- dByteArray_-  return $ SBS.SBS array--dByteString :: Get B.ByteString-dByteString = dFiller >> dByteString_

@@ -1,137 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE DeriveFunctor #-}---- |Strict Decoder Types-module Data.Flat.Decoder.Types (-    strictDecoder,-    strictDecoderPart,-    Get(..),-    S(..),-    GetResult(..),-    Decoded,-    DecodeException,-    notEnoughSpace,-    tooMuchSpace,-    badEncoding,-    ) where--import           Control.DeepSeq-import           Control.Exception-import qualified Data.ByteString          as B-import qualified Data.ByteString.Internal as BS-import           Data.Word-import           System.IO.Unsafe-import           Foreign--strictDecoder :: Get a -> B.ByteString -> Either DecodeException a-strictDecoder get bs = strictDecoder_ get bs $ \(GetResult s'@(S ptr' o') a) endPtr ->-  if ptr' /= endPtr || o' /= 0-    then tooMuchSpace endPtr s'-    else return a--strictDecoderPart :: Get a -> B.ByteString -> Either DecodeException a-strictDecoderPart get bs = strictDecoder_ get bs $ \(GetResult _ a) _ -> return a--strictDecoder_-  :: Exception e =>-     Get a1-     -> BS.ByteString -> (GetResult a1 -> Ptr b -> IO a) -> Either e a-strictDecoder_ get (BS.PS base off len) check = unsafePerformIO . try $-    withForeignPtr base $ \base0 ->-        let ptr = base0 `plusPtr` off-            endPtr = ptr `plusPtr` len-        in do-          res <- runGet get endPtr (S ptr 0)-          check res endPtr---- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits)--- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $---   withForeignPtr base $ \base0 ->---     let ptr = base0 `plusPtr` off---         endPtr = ptr `plusPtr` len---     in do---       GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0)---       return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o')---- |Decoder monad-newtype Get a = Get {runGet ::-                        Ptr Word8 -- End Ptr-                        -> S-                        -> IO (GetResult a)-                    } -- 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 !_ = ()--instance Show (Get a) where show _ = "Get"--instance Applicative Get where-    pure x = Get (\_ ptr -> return $ GetResult ptr x)-    {-# INLINE pure #-}--    Get f <*> Get g = Get $ \end ptr1 -> do-        GetResult ptr2 f' <- f end ptr1-        GetResult ptr3 g' <- g end ptr2-        return $ GetResult ptr3 (f' g')-    {-# INLINE (<*>) #-}--    Get f *> Get g = Get $ \end ptr1 -> do-        GetResult ptr2 _ <- f end ptr1-        g end ptr2-    {-# INLINE (*>) #-}--instance Monad Get where-    return = pure-    {-# INLINE return #-}--    (>>) = (*>)-    {-# INLINE (>>) #-}--    Get x >>= f = Get $ \end s -> do-        GetResult s' x' <- x end s-        runGet (f x') end s'-    {-# INLINE (>>=) #-}--    fail msg = Get $ \end s -> badEncoding end s msg-    {-# INLINE fail #-}---- |Decoder state-data S =-       S-         { currPtr  :: {-# UNPACK #-} !(Ptr Word8)-         , usedBits :: {-# UNPACK #-} !Int-         } deriving (Show,Eq,Ord)--data GetResult a = GetResult {-# UNPACK #-} !S !a deriving Functor---- |A decoded value-type Decoded a = Either DecodeException a---- |An exception during decoding-data DecodeException = NotEnoughSpace Env-                     | TooMuchSpace Env-                     | BadEncoding Env String-  deriving (Show,Eq,Ord)--type Env = (Ptr Word8,S)--notEnoughSpace :: Ptr Word8 -> S -> IO a-notEnoughSpace endPtr s = throwIO $ NotEnoughSpace (endPtr,s)--tooMuchSpace :: Ptr Word8 -> S -> IO a-tooMuchSpace endPtr s = throwIO $ TooMuchSpace (endPtr,s)--badEncoding :: Ptr Word8 -> S -> String -> IO a-badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg--instance Exception DecodeException--

@@ -1,68 +0,0 @@-module Data.Flat.Encoder (-    Encoding,-    (<>),-    NumBits,-    encodersS,-    mempty,-    strictEncoder,-    eTrueF,-    eFalseF,-    eFloat,-    eDouble,-    eInteger,-    eNatural,-    eWord16,-    eWord32,-    eWord64,-    eWord8,-    eBits,-    eBits16,-    eFiller,-    eBool,-    eTrue,-    eFalse,-    eBytes,-    eUTF16,-    eLazyBytes,-    eShortBytes,-    eInt,-    eInt8,-    eInt16,-    eInt32,-    eInt64,-    eWord,-    eChar,-    encodeArrayWith,-    encodeListWith,-    Size,-    arrayBits,-    sWord,-    sWord8,-    sWord16,-    sWord32,-    sWord64,-    sInt,-    sInt8,-    sInt16,-    sInt32,-    sInt64,-    sNatural,-    sInteger,-    sFloat,-    sDouble,-    sChar,-    sBytes,-    sLazyBytes,-    sShortBytes,-    sUTF16,-    sFillerMax,-    sBool,-    sUTF8Max,-    eUTF8,-    ) where--import           Data.Flat.Encoder.Prim-import           Data.Flat.Encoder.Size(arrayBits)-import           Data.Flat.Encoder.Strict-import           Data.Flat.Encoder.Types-import           Data.Monoid((<>))

@@ -1,402 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE MultiWayIf          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE UnboxedTuples       #-}--- |Encoding Primitives-module Data.Flat.Encoder.Prim (-    eBits16F,-    eBitsF,-    eFloatF,-    eDoubleF,-    eUTF16F,-    eUTF8F,-    eCharF,-    eNaturalF,-    eIntegerF,-    eInt64F,-    eInt32F,-    eIntF,-    eInt16F,-    eInt8F,-    eWordF,-    eWord64F,-    eWord32F,-    eWord16F,-    eBytesF,-    eLazyBytesF,-    eShortBytesF,-    eWord8F,-    eFillerF,-    eBoolF,-    eTrueF,-    eFalseF,-    varWordF,-    w7l,-    -- * Exported for testing only-    eWord32BEF,eWord64BEF,eWord32E,eWord64E-    ) where--import           Control.Monad-import qualified Data.ByteString                as B-import qualified Data.ByteString.Lazy           as L-import qualified Data.ByteString.Lazy.Internal  as L-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-import           Data.Primitive.ByteArray-import qualified Data.Text                      as T-import qualified Data.Text.Array                as TA-import qualified Data.Text.Encoding             as T-import qualified Data.Text.Internal             as T-import           Data.ZigZag-import           Foreign---- import Debug.Trace-#include "MachDeps.h"---- traceShowId :: a -> a--- traceShowId = id--{-# INLINE eFloatF #-}-eFloatF :: Float -> Prim-eFloatF = eWord32BEF . floatToWord--{-# INLINE eDoubleF #-}-eDoubleF :: Double -> Prim-eDoubleF = eWord64BEF . doubleToWord--{-# INLINE eWord64BEF #-}-eWord64BEF :: Word64 -> Prim-eWord64BEF = eWord64E toBE64--{-# INLINE eWord32BEF #-}-eWord32BEF :: Word32 -> Prim-eWord32BEF = eWord32E toBE32--{-# INLINE eCharF #-}-eCharF :: Char -> Prim-eCharF = eWord32F . fromIntegral . ord--{-# INLINE eWordF #-}-eWordF :: Word -> Prim--{-# INLINE eIntF #-}-eIntF :: Int -> Prim--#if WORD_SIZE_IN_BITS == 64-eWordF = eWord64F . (fromIntegral :: Word -> Word64)-eIntF = eInt64F . (fromIntegral :: Int -> Int64)-#elif WORD_SIZE_IN_BITS == 32-eWordF = eWord32F . (fromIntegral :: Word -> Word32)-eIntF = eInt32F . (fromIntegral :: Int -> Int32)-#else-#error expected WORD_SIZE_IN_BITS to be 32 or 64-#endif--{-# INLINE eInt8F #-}-eInt8F :: Int8 -> Prim-eInt8F = eWord8F . zzEncode--{-# INLINE eInt16F #-}-eInt16F :: Int16 -> Prim-eInt16F = eWord16F . zzEncode--{-# INLINE eInt32F #-}-eInt32F :: Int32 -> Prim-eInt32F = eWord32F . zzEncode--{-# INLINE eInt64F #-}-eInt64F :: Int64 -> Prim-eInt64F = eWord64F . zzEncode--{-# INLINE eIntegerF #-}-eIntegerF :: Integer -> Prim-eIntegerF = eIntegralF . zzEncodeInteger--{-# INLINE eNaturalF #-}-eNaturalF :: Natural -> Prim-eNaturalF = eIntegralF . toInteger--{-# INLINE eIntegralF #-}-eIntegralF :: (Bits t, Integral t) => t -> Prim-eIntegralF t = let vs = w7l t-               in eIntegralW vs--w7l :: (Bits t, Integral t) => t -> [Word8]-w7l t = let l  = low7 t-            t' = t `unsafeShiftR` 7-        in if t' == 0-           then [l]-           else w7 l : w7l t'-  where-    {-# INLINE w7 #-}-    --lowByte :: (Bits t, Num t) => t -> Word8-    w7 :: Word8 -> Word8-    w7 l = l .|. 0x80---- Encode as data NEList = Elem Word7 | Cons Word7 List-{-# INLINE eIntegralW #-}-eIntegralW :: [Word8] -> Prim-eIntegralW vs s@(S op _ o) | o == 0 = foldM pokeWord' op vs >>= \op' -> return (S op' 0 0)-                           | otherwise = foldM (flip eWord8F) s vs---{-# INLINE eWord8F #-}-eWord8F :: Word8 -> Prim-eWord8F t s@(S op _ o) | o==0 = pokeWord op t-                       | otherwise = pokeByteUnaligned t s--{-# 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 (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 = 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-eWord16F = varWordF--{-# INLINE eWord32F #-}-eWord32F :: Word32 -> Prim-eWord32F = varWordF--{-# INLINE eWord64F #-}-eWord64F :: Word64 -> Prim-eWord64F = varWordF--{-# INLINE varWordF #-}-varWordF :: (Bits t, Integral t) => t -> Prim-varWordF t s@(S _ _ o) | o == 0 = varWord pokeByteAligned t s-                       | otherwise = varWord pokeByteUnaligned t s--{-# INLINE varWord #-}-varWord :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim-varWord writeByte t s-  | t < 128 = writeByte (fromIntegral t) s-  | t < 16384 = varWord2_ writeByte t s-  | t < 2097152 = varWord3_ writeByte t s-  | otherwise = varWordN_ writeByte t s-    where-      {-# INLINE varWord2_ #-}-      -- TODO: optimise, using a single Write16?-      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 `unsafeShiftR` 7) .|. 0x80) >>= writeByte (fromIntegral (t `unsafeShiftR` 14) .&. 0x7F)---- {-# INLINE varWordN #-}-varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim-varWordN_ writeByte = go-  where-    go !v !st =-      let !l  = low7 v-          !v' = v `unsafeShiftR` 7-      in if v' == 0-      then writeByte l st-      else writeByte (l .|. 0x80) st >>= go v'--{-# INLINE low7 #-}-low7 :: (Integral a) => a -> Word8-low7 t = fromIntegral t .&. 0x7F---- PROB: encodeUtf8 calls a C primitive, not compatible with GHCJS-eUTF8F :: T.Text -> Prim-eUTF8F = eBytesF . T.encodeUtf8--eUTF16F :: T.Text -> Prim-eUTF16F t = eFillerF >=> eUTF16F_ t-  where-    eUTF16F_ !(T.Text (TA.Array array) w16Off w16Len) s = writeArray array (2 * w16Off) (2 * w16Len) (nextPtr s)--eLazyBytesF :: L.ByteString -> Prim-eLazyBytesF bs = eFillerF >=> \s -> write bs (nextPtr s)-  where-    -- Single copy-    write lbs op = do-     case lbs of-       L.Chunk h t -> writeBS h op >>= write t-       L.Empty     -> pokeWord op 0--{-# INLINE eShortBytesF #-}-eShortBytesF :: SBS.ShortByteString -> Prim-eShortBytesF bs = eFillerF >=> eShortBytesF_ bs--eShortBytesF_ :: SBS.ShortByteString -> Prim-eShortBytesF_ bs@(SBS.SBS arr) = \(S op _ 0) -> writeArray arr 0 (SBS.length bs) op---- data Array a = Array0 | Array1 a ... | Array255 ...-writeArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO S-writeArray arr soff slen sop = do-  op' <- go soff slen sop-  pokeWord op' 0-  where-    go !off !len !op-      | len == 0 = return op-      | otherwise =-          let l = min 255 len-          in pokeWord' op (fromIntegral l) >>=-             pokeByteArray arr off l >>=-             go (off+l) (len - l)--eBytesF :: B.ByteString -> Prim-eBytesF bs = eFillerF >=> eBytesF_-  where-    eBytesF_ s = do-      op' <- writeBS bs (nextPtr s)-      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:-n = 6-t = 00.101011-o = 3-w = 111.00000--After:-[ptr] = w(111)t(10101)-w' = t(1)0000000-o'= 1--o'=3+6=9-f = 8-9 = -1-o'' = 1-8-o''=7--if n=8,o=3:-o'=11-f=8-11=-3-o''=3-8-o''=5--}--- {-# 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 `unsafeShiftL` f)) o'-        | f == 0 ->  pokeWord op (w .|. t)-        | otherwise -> let o'' = -f-                       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-eBoolF True  = eTrueF--{-# INLINE eTrueF #-}-eTrueF :: Prim-eTrueF (S op w o) | o == 7 = pokeWord op (w .|. 1)-                  | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o+1))--{-# INLINE eFalseF #-}-eFalseF :: Prim-eFalseF (S op w o) | o == 7 = pokeWord op w-                   | otherwise = return (S op w (o+1))--{-# INLINE eFillerF #-}-eFillerF :: Prim-eFillerF (S op w _) = pokeWord op (w .|. 1)---- {-# INLINE poke16 #-}--- TODO TEST--- poke16 :: Word16 -> Prim--- poke16 t (S op w o) | o == 0 = poke op w >> skipBytes op 2--{-# INLINE pokeByteUnaligned #-}-pokeByteUnaligned :: Word8 -> Prim-pokeByteUnaligned t (S op w o) = poke op (w .|. (t `unsafeShiftR` o)) >> return (S (plusPtr op 1) (t `unsafeShiftL` (8-o)) o)--{-# INLINE pokeByteAligned #-}-pokeByteAligned :: Word8 -> Prim-pokeByteAligned t (S op _ _) = pokeWord op t--{-# INLINE pokeWord #-}-pokeWord :: Storable a => Ptr a -> a -> IO S-pokeWord op w = poke op w >> skipByte op--{-# INLINE pokeWord' #-}-pokeWord' :: Storable a => Ptr a -> a -> IO (Ptr b)-pokeWord' op w = poke op w >> return (plusPtr op 1)--{-# INLINE pokeW #-}-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)--{-# INLINE skipBytes #-}-skipBytes :: Monad m => Ptr a -> Int -> m S-skipBytes op n = return (S (plusPtr op n) 0 0)----{-# INLINE nextByteW #-}---nextByteW op w = return (S (plusPtr op 1) 0 0)--writeBS :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)-writeBS bs op -- @(BS.PS foreignPointer sourceOffset sourceLength) op-  | B.length bs == 0 = return op-  | otherwise =-    let (h, t) = B.splitAt 255 bs-    in pokeWord' op (fromIntegral $ B.length h :: Word8) >>= pokeByteString h >>= writeBS t--    -- 2X slower (why?)-    -- withForeignPtr foreignPointer goS-    --   where-    --     goS sourcePointer = go op (sourcePointer `plusPtr` sourceOffset) sourceLength-    --       where-    --         go !op !off !len | len == 0 = return op-    --                          | otherwise = do-    --                           let l = min 255 len-    --                           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

@@ -1,178 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}--- |Primitives to calculate the encoding size of a value-module Data.Flat.Encoder.Size where--import           Data.Bits-import qualified Data.ByteString                as B-import qualified Data.ByteString.Lazy           as L-import qualified Data.ByteString.Short.Internal as SBS-import           Data.Char-import           Data.Flat.Encoder.Prim         (w7l)-import           Data.Flat.Encoder.Types-import           Data.Flat.Types-import qualified Data.Text                      as T-import qualified Data.Text.Internal             as T-import           Data.ZigZag--#include "MachDeps.h"---- A filler can take anything from 1 to 8 bits-sFillerMax :: NumBits-sFillerMax = 8--sBool :: NumBits-sBool = 1--sWord8 :: NumBits-sWord8 = 8--sInt8 :: NumBits-sInt8 = 8--sFloat :: NumBits-sFloat = 32--sDouble :: NumBits-sDouble = 64--{-# INLINE sChar #-}-sChar :: Char -> NumBits-sChar  = sWord32  . fromIntegral . ord--sCharMax :: NumBits-sCharMax = 24--{-# INLINE sWord #-}-sWord :: Word -> NumBits--{-# INLINE sInt #-}-sInt :: Int -> NumBits--#if WORD_SIZE_IN_BITS == 64-sWord = sWord64 . fromIntegral-sInt = sInt64 . fromIntegral-#elif WORD_SIZE_IN_BITS == 32-sWord = sWord32 . fromIntegral-sInt = sInt32 . fromIntegral-#else-#error expected WORD_SIZE_IN_BITS to be 32 or 64-#endif---- TODO: optimize ints sizes-{-# INLINE sInt16 #-}-sInt16 :: Int16 -> NumBits-sInt16 = sWord16 . zzEncode--{-# INLINE sInt32 #-}-sInt32 :: Int32 -> NumBits-sInt32 = sWord32 . zzEncode--{-# INLINE sInt64 #-}-sInt64 :: Int64 -> NumBits-sInt64 = sWord64 . zzEncode--{-# INLINE sWord16 #-}-sWord16 :: Word16 -> NumBits-sWord16 w | w < 128 = 8-          | w < 16384 = 16-          | otherwise = 24--{-# INLINE sWord32 #-}-sWord32 :: Word32 -> NumBits-sWord32 w | w < 128 = 8-          | w < 16384 = 16-          | w < 2097152 = 24-          | w < 268435456 = 32-          | otherwise = 40--{-# INLINE sWord64 #-}-sWord64 :: Word64 -> NumBits-sWord64 w | w < 128 = 8-          | w < 16384 = 16-          | w < 2097152 = 24-          | w < 268435456 = 32-          | w < 34359738368 = 40-          | w < 4398046511104 = 48-          | w < 562949953421312 = 56-          | w < 72057594037927936 = 64-          | w < 9223372036854775808 = 72-          | otherwise = 80--{-# INLINE sInteger #-}-sInteger :: Integer -> NumBits-sInteger = sIntegral . zzEncodeInteger--{-# INLINE sNatural #-}-sNatural :: Natural -> NumBits-sNatural = sIntegral . toInteger---- BAD: duplication of work with encoding-{-# INLINE sIntegral #-}-sIntegral :: (Bits t, Integral t) => t -> Int-sIntegral t = let vs = w7l t-              in length vs*8----sUTF8 :: T.Text -> NumBits---sUTF8 t = fold---- Wildly pessimistic but fast-{-# INLINE sUTF8Max #-}-sUTF8Max :: Text -> NumBits-sUTF8Max = blobBits . (4*) . T.length--{-# INLINE sUTF16 #-}-sUTF16 :: T.Text -> NumBits-sUTF16 = blobBits . textBytes--{-# INLINE sBytes #-}-sBytes :: B.ByteString -> NumBits-sBytes = blobBits . B.length--{-# INLINE sLazyBytes #-}-sLazyBytes :: L.ByteString -> NumBits-sLazyBytes bs = 16 + L.foldrChunks (\b l -> blkBitsBS b + l) 0 bs--{-# INLINE sShortBytes #-}-sShortBytes :: SBS.ShortByteString -> NumBits-sShortBytes = blobBits . SBS.length---- We are not interested in the number of unicode chars (returned by T.length, an O(n) operation)--- just the number of bytes--- > T.length (T.pack "\x1F600")--- 1--- > textBytes (T.pack "\x1F600")--- 4-{-# INLINE textBytes #-}-textBytes :: T.Text -> Int-textBytes !(T.Text _ _ w16Len) = w16Len * 2--{-# INLINE bitsToBytes #-}-bitsToBytes :: Int -> Int-bitsToBytes = numBlks 8--{-# INLINE numBlks #-}-numBlks :: Integral t => t -> t -> t-numBlks blkSize bits = let (d,m) = bits `divMod` blkSize-                       in d + (if m==0 then 0 else 1)--{-# INLINE arrayBits #-}-arrayBits :: Int -> NumBits-arrayBits = (8*) . arrayChunks--{-# INLINE arrayChunks #-}-arrayChunks :: Int -> NumBits-arrayChunks = (1+) . numBlks 255--{-# INLINE blobBits #-}-blobBits :: Int -> NumBits-blobBits numBytes = 16 -- initial filler + final 0-                    + blksBits numBytes--{-# INLINE blkBitsBS #-}-blkBitsBS :: B.ByteString -> NumBits-blkBitsBS = blksBits . B.length--{-# INLINE blksBits #-}-blksBits :: Int -> NumBits-blksBits numBytes = 8*(numBytes + numBlks 255 numBytes)

@@ -1,246 +0,0 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}---- |Strict encoder-module Data.Flat.Encoder.Strict where--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           Data.Flat.Encoder.Types-import           Data.Flat.Memory-import           Data.Flat.Types-import           Data.Foldable-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, ())--newtype Encoding = Encoding { run :: Prim }--instance Show Encoding where show _ = "Encoding"--instance Semigroup Encoding where-  {-# INLINE (<>) #-}-  (<>) = mappend--instance Monoid Encoding where-  {-# INLINE mempty #-}-  mempty = Encoding return--  {-# INLINE mappend #-}-  -- mappend (Encoding f) (Encoding g) = Encoding (f >=> g)-  mappend (Encoding f) (Encoding g) = Encoding m-    where m s@(S !_ !_ !_) = do-            !s1 <- f s-            g s1--  {-# INLINE mconcat #-}-  mconcat = foldl' mappend mempty---- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists)-{-# RULES-"encodersSN" forall h t. encodersS (h:t) = h `mappend` encodersS t-"encodersS0" encodersS [] = mempty- #-}--{-# NOINLINE encodersS #-}-encodersS :: [Encoding] -> Encoding--- without the explicit parameter the rules won't fire-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---- {-# INLINE encodeList #-}--- encodeList :: (Foldable t, Flat a) => t a -> Encoding--- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse---- {-# INLINE encodeList2 #-}--- encodeList2 :: (Foldable t, Flat a) => t a -> Encoding--- encodeList2 l = foldr (\a acc -> eTrue <> encode a <> acc) mempty l <> eFalse--{-# INLINE encodeArrayWith #-}--- |Encode as Array-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''--  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 #-}-{-# INLINE eUTF8 #-}-{-# INLINE eUTF16 #-}-{-# INLINE eNatural #-}-{-# INLINE eFloat #-}-{-# INLINE eDouble #-}-{-# INLINE eInteger #-}-{-# INLINE eInt64 #-}-{-# INLINE eInt32 #-}-{-# INLINE eInt16 #-}-{-# INLINE eInt8 #-}-{-# INLINE eInt #-}-{-# INLINE eWord64 #-}-{-# INLINE eWord32 #-}-{-# INLINE eWord16 #-}-{-# INLINE eWord8 #-}-{-# INLINE eWord #-}-{-# INLINE eBits #-}-{-# INLINE eFiller #-}-{-# INLINE eBool #-}-{-# INLINE eTrue #-}-{-# INLINE eFalse #-}--eChar :: Char -> Encoding-eChar = Encoding . eCharF-eUTF16 :: Text -> Encoding-eUTF16 = Encoding . eUTF16F-eUTF8 :: Text -> Encoding-eUTF8 = Encoding . eUTF8F-eBytes :: B.ByteString -> Encoding-eBytes = Encoding . eBytesF-eLazyBytes :: L.ByteString -> Encoding-eLazyBytes = Encoding . eLazyBytesF-eShortBytes :: ShortByteString -> Encoding-eShortBytes = Encoding . eShortBytesF-eNatural :: Natural -> Encoding-eNatural = Encoding . eNaturalF-eFloat :: Float -> Encoding-eFloat = Encoding . eFloatF-eDouble :: Double -> Encoding-eDouble = Encoding . eDoubleF-eInteger :: Integer -> Encoding-eInteger = Encoding . eIntegerF-eInt64 :: Int64 -> Encoding-eInt64 = Encoding . eInt64F-eInt32 :: Int32 -> Encoding-eInt32 = Encoding . eInt32F-eInt16 :: Int16 -> Encoding-eInt16 = Encoding . eInt16F-eInt8 :: Int8 -> Encoding-eInt8 = Encoding . eInt8F-eInt :: Int -> Encoding-eInt = Encoding . eIntF-eWord64 :: Word64 -> Encoding-eWord64 = Encoding . eWord64F-eWord32 :: Word32 -> Encoding-eWord32 = Encoding . eWord32F-eWord16 :: Word16 -> Encoding-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-eFiller = Encoding eFillerF-eBool :: Bool -> Encoding-eBool = Encoding . eBoolF-eTrue :: Encoding-eTrue = Encoding eTrueF-eFalse :: Encoding-eFalse = Encoding eFalseF---- Size Primitives---- Variable size-{-# INLINE vsize #-}-vsize :: (t -> NumBits) -> t -> NumBits -> NumBits-vsize !f !t !n = f t + n---- Constant size-{-# INLINE csize #-}-csize :: NumBits -> t -> NumBits -> NumBits-csize !n _ !s = n + s--sChar :: Size Char-sChar = vsize S.sChar--sInt64 :: Size Int64-sInt64 = vsize S.sInt64--sInt32 :: Size Int32-sInt32 = vsize S.sInt32--sInt16 :: Size Int16-sInt16 = vsize S.sInt16--sInt8 :: Size Int8-sInt8 = csize S.sInt8--sInt :: Size Int-sInt = vsize S.sInt--sWord64 :: Size Word64-sWord64 = vsize S.sWord64--sWord32 :: Size Word32-sWord32 = vsize S.sWord32--sWord16 :: Size Word16-sWord16 = vsize S.sWord16--sWord8 :: Size Word8-sWord8 = csize S.sWord8--sWord :: Size Word-sWord = vsize S.sWord--sFloat :: Size Float-sFloat = csize S.sFloat--sDouble :: Size Double-sDouble = csize S.sDouble--sBytes :: Size B.ByteString-sBytes = vsize S.sBytes--sLazyBytes :: Size L.ByteString-sLazyBytes = vsize S.sLazyBytes--sShortBytes :: Size ShortByteString-sShortBytes = vsize S.sShortBytes--sNatural :: Size Natural-sNatural = vsize S.sNatural--sInteger :: Size Integer-sInteger = vsize S.sInteger--- sUTF8 = vsize S.sUTF8--sUTF8Max :: Size Text-sUTF8Max = vsize S.sUTF8Max--sUTF16 :: Size Text-sUTF16 = vsize S.sUTF16--sFillerMax :: Size a-sFillerMax = csize S.sFillerMax--sBool :: Size Bool-sBool = csize S.sBool

@@ -1,25 +0,0 @@--- |Encoder Types-module Data.Flat.Encoder.Types(-  Size,-  NumBits,-  Prim,-  S(..)-) where--import           Data.Flat.Types-import           GHC.Ptr         (Ptr (..))---- |Calculate the size (in bits) of the encoding of a value-type Size a = a -> NumBits -> NumBits---- |Strict encoder state-data S =-       S-         { nextPtr  :: {-# UNPACK #-} !(Ptr Word8)-         , currByte :: {-# UNPACK #-} !Word8-         , usedBits :: {-# UNPACK #-} !NumBits-         } deriving Show---- |A basic encoder-type Prim = S -> IO S-

@@ -1,61 +0,0 @@-{-# 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

@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |Pre-value and post-value byte alignments-module Data.Flat.Filler (-    Filler(..),-    fillerLength,-    PreAligned(..),-    preAligned,-    PostAligned(..),-    postAligned,-    postAlignedDecoder-    ) where--import           Data.Flat.Class-import           Data.Flat.Encoder-import           Data.Flat.Decoder-import           Control.DeepSeq-import           Data.Typeable---- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse)--- Useful to align an encoded value at byte/word boundaries.-data Filler = FillerBit Filler-            | FillerEnd-  deriving (Show, Eq, Ord, Typeable, Generic, NFData)---- |Use a special encoding for the filler-instance Flat Filler where-  encode _ = eFiller-  size = sFillerMax-  -- use generated decode---- |A Post aligned value, a value followed by a filler-data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler }-  deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)---- |A Pre aligned value, a value preceded by a filler-data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a }-  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Flat)---- |Length of a filler in bits-fillerLength :: Num a => Filler -> a-fillerLength FillerEnd     = 1-fillerLength (FillerBit f) = 1 + fillerLength f---- |Post align a value-postAligned :: a -> PostAligned a-postAligned a = PostAligned a FillerEnd---- |Pre align a value-preAligned :: a -> PreAligned a-preAligned = PreAligned FillerEnd---- postAlignedDecoder :: Get a -> Get (PostAligned a)-postAlignedDecoder :: Get b -> Get b-postAlignedDecoder dec = do-  v <- dec-  _::Filler <- decode-  -- return (postAligned v)-  return v

@@ -1,230 +0,0 @@--- {-# LANGUAGE BangPatterns #-}--{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE ScopedTypeVariables       #-}--- {-# LANGUAGE UndecidableInstances    #-}--- {-# 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--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.Containers       (ContainerKey, IsMap, MapValue,-                                        mapFromList, mapToList)-import           Data.Flat.Class-import           Data.Flat.Decoder-import           Data.Flat.Encoder---import           Data.Flat.Size        (arrayBits)-import           Data.Flat.Types-import qualified Data.Foldable         as F-import qualified Data.Map              as M-import           Data.MonoTraversable-import qualified Data.Sequence         as S-import           Data.Sequences-import qualified Data.Text             as T-import           Prelude               hiding (mempty)---- Flat instances for common types-instance Flat () where-  encode _ = mempty-  decode = pure ()--instance Flat Bool where-  encode = eBool-  size = sBool-  decode = dBool--instance Flat a => Flat (Maybe a)--instance (Flat a,Flat b) => Flat (Either a b)--instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a,b)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a,b,c)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d) => Flat (a,b,c,d)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e) => Flat (a,b,c,d,e)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) => Flat (a,b,c,d,e,f)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g) => Flat (a,b,c,d,e,f,g)---- Generic list instance.-instance {-# OVERLAPPABLE #-} Flat a => Flat [a]---- 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-   encode = eBytes-   size = sBytes-   decode = dByteString--instance Flat L.ByteString where-  encode = eLazyBytes-  size = sLazyBytes-  decode = dLazyByteString--instance Flat SBS.ShortByteString where-  encode = eShortBytes-  size = sShortBytes-  decode = dShortByteString--instance Flat T.Text where-   size = sUTF8Max-   encode = eUTF8-   decode = dUTF8--instance Flat UTF8Text where-  size (UTF8Text t)= sUTF8Max t-  encode (UTF8Text t) = eUTF8 t-  decode = UTF8Text <$> dUTF8--instance Flat UTF16Text where-  size (UTF16Text t)= sUTF16 t-  encode (UTF16Text t) = eUTF16 t-  decode = UTF16Text <$> dUTF16--instance Flat Word8 where-  encode = eWord8-  decode = dWord8-  size = sWord8--instance Flat Word16 where-  encode = eWord16-  decode = dWord16-  size = sWord16--instance Flat Word32 where-  encode = eWord32-  decode = dWord32-  size = sWord32--instance Flat Word64 where-  encode = eWord64-  decode = dWord64-  size = sWord64--instance Flat Word where-  size = sWord-  encode = eWord-  decode = dWord--instance Flat Int8 where-  encode = eInt8-  decode = dInt8-  size = sInt8--instance Flat Int16 where-  size = sInt16-  encode = eInt16-  decode = dInt16--instance Flat Int32 where-  size = sInt32-  encode = eInt32-  decode = dInt32--instance Flat Int64 where-  size = sInt64-  encode = eInt64-  decode = dInt64--instance Flat Int where-  size = sInt-  encode = eInt-  decode = dInt--instance Flat Integer where-  size = sInteger-  encode = eInteger-  decode = dInteger--instance Flat Natural where-  size = sNatural-  encode = eNatural-  decode = dNatural--instance Flat Float where-  size = sFloat-  encode = eFloat-  decode = dFloat--instance Flat Double where-  size = sDouble-  encode = eDouble-  decode = dDouble--instance Flat Char where-  size = sChar-  encode = eChar-  decode = dChar--instance (Flat a, Flat b,Ord a) => Flat (M.Map a b) where-   size = sizeMap-   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-  decode = decodeSequence---- |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--{-# 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 = go . mapToList---   where---     go []     = eFalse---     go ((!x,!y):xs) = eTrue <> encode x <> encode y <> go xs--{-# INLINE decodeMap #-}--- |Decode an instance of IsMap, as a list-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 s acc = ofoldl' (flip size) acc s + arrayBits (olength s)--{-# INLINE encodeSequence #-}--- |Encode an instance of IsSequence, as an array-encodeSequence :: (Flat (Element mono), IsSequence mono) => mono -> Encoding-encodeSequence = encodeArrayWith encode . otoList--{-# INLINE decodeSequence #-}--- |Decode an instance of IsSequence, as an array-decodeSequence :: (Flat (Element b), IsSequence b) => Get b-decodeSequence = fromList <$> decodeArrayWith decode

@@ -1,113 +0,0 @@-{-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE TypeFamilies  #-}-{-# LANGUAGE UnboxedTuples #-}--- |Memory access primitives-module Data.Flat.Memory-  ( chunksToByteString-  , chunksToByteArray-  , ByteArray-  , pokeByteArray-  , pokeByteString-  , unsafeCreateUptoN'-  , minusPtr-  )-where--import           Control.Monad-import           Control.Monad.Primitive        ( PrimMonad(..) )-import qualified Data.ByteString.Internal      as BS-import           Data.Primitive.ByteArray       ( MutableByteArray(..)-                                                , ByteArray#-                                                , ByteArray-                                                , newByteArray-                                                , unsafeFreezeByteArray-                                                )-import           Foreign                 hiding ( void )-import           GHC.Prim                       ( copyAddrToByteArray#-                                                , copyByteArrayToAddr#-                                                )-import           GHC.Ptr                        ( Ptr(..) )-import           GHC.Types                      ( IO(..)-                                                , Int(..)-                                                )-import           System.IO.Unsafe-import qualified Data.ByteString               as B--unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a)-unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f)-{-# INLINE unsafeCreateUptoN' #-}--createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (BS.ByteString, a)-createUptoN' l f = do-  fp        <- BS.mallocByteString l-  (l', res) <- withForeignPtr fp $ \p -> f p-  --print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"])-  when (l' > l) $ error-    (unwords-      ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"]-    )-  return (BS.PS fp 0 l', res) -- , minusPtr l')-{-# INLINE createUptoN' #-}---- |Copy bytestring to given pointer, returns new pointer-pokeByteString :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)-pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer =-  do-    withForeignPtr foreignPointer $ \sourcePointer -> BS.memcpy-      destPointer-      (sourcePointer `plusPtr` sourceOffset)-      sourceLength-    return (destPointer `plusPtr` sourceLength)--pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8)-pokeByteArray sourceArr sourceOffset len dest = do-  copyByteArrayToAddr sourceArr sourceOffset dest len-  let !dest' = dest `plusPtr` len-  return dest'-{-# INLINE pokeByteArray #-}---- | Wrapper around @copyByteArrayToAddr#@ primop.--- Copied from the store-core package-copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()-copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) =-  IO (\s -> (#copyByteArrayToAddr# arr offset addr len s, ()#))-{-# INLINE copyByteArrayToAddr #-}---- toByteString :: Ptr Word8 -> Int -> BS.ByteString--- toByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength--chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString-chunksToByteString (sourcePtr0, lens) =-  BS.unsafeCreate (sum lens) $ \destPtr0 -> void $ foldM-    (\(destPtr, sourcePtr) sourceLength ->-      BS.memcpy destPtr sourcePtr sourceLength-        >> return-             ( destPtr `plusPtr` sourceLength-             , sourcePtr `plusPtr` (sourceLength + 1)-             )-    )-    (destPtr0, sourcePtr0)-    lens--chunksToByteArray :: (Ptr Word8, [Int]) -> (ByteArray, Int)-chunksToByteArray (sourcePtr0, lens) = unsafePerformIO $ do-  let len = sum lens-  arr <- newByteArray len-  foldM_-    (\(destOff, sourcePtr) sourceLength ->-      copyAddrToByteArray sourcePtr arr destOff sourceLength >> return-        (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1))-    )-    (0, sourcePtr0)-    lens-  farr <- unsafeFreezeByteArray arr-  return (farr, len)---- from store-core--- | Wrapper around @copyAddrToByteArray#@ primop.-copyAddrToByteArray-  :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO ()-copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) =-  IO (\s -> (#copyAddrToByteArray# addr arr offset len s, ()#))-{-# INLINE copyAddrToByteArray #-}

@@ -1,44 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--- |Encoding and decoding functions-module Data.Flat.Run (-    flat,-    flatRaw,-    unflat,-    unflatWith,-    unflatRaw,-    unflatRawWith,-    ) where--import qualified Data.ByteString         as B-import           Data.ByteString.Convert-import           Data.Flat.Class-import           Data.Flat.Decoder-import qualified Data.Flat.Encoder       as E-import           Data.Flat.Filler---- |Encode padded value.-flat :: Flat a => a -> B.ByteString-flat = flatRaw . postAligned---- |Decode padded value.-unflat :: (Flat a,AsByteString b) => b -> Decoded a-unflat = unflatWith decode---- |Decode padded value, using the provided unpadded decoder.-unflatWith :: AsByteString b => Get a -> b -> Decoded a-unflatWith dec = unflatRawWith (postAlignedDecoder dec)---- |Decode unpadded value.-unflatRaw :: (Flat a,AsByteString b) => b -> Decoded a-unflatRaw = unflatRawWith decode---- |Unflat unpadded value, using provided decoder-unflatRawWith :: AsByteString b => Get a -> b -> Decoded a-unflatRawWith dec = strictDecoder dec . toByteString---- |Encode unpadded value-flatRaw :: (Flat a, AsByteString b) => a -> b-flatRaw a = fromByteString $ E.strictEncoder (getSize a) (encode a)-

@@ -1,28 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeSynonymInstances #-}--- |Common Types-module Data.Flat.Types (-    NumBits,-    module Data.Word,-    module Data.Int,-    Natural,-    SBS.ShortByteString,-    T.Text,-    UTF8Text(..),-    UTF16Text(..),-    ) where--import qualified Data.ByteString.Short.Internal as SBS-import           Data.Int-import qualified Data.Text                      as T-import           Data.Word-import           Numeric.Natural---- |Number of bits-type NumBits = Int---- |A wrapper to encode/decode Text as UTF8 (slower but more compact)-newtype UTF8Text = UTF8Text T.Text deriving (Eq,Ord,Show)---- |A wrapper to encode/decode Text as UTF16 (faster but bigger)-newtype UTF16Text = UTF16Text T.Text deriving (Eq,Ord,Show)

@@ -1,18 +1,22 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}--- | Primitives to convert between Float/Double and Word32/Word64--- | This code was copied from `binary`--- | This module was written based on---   <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.------   Implements casting via a 1-element STUArray, as described in---   <http://stackoverflow.com/a/7002812/263061>.+{-# LANGUAGE Trustworthy ,NoMonomorphismRestriction#-}++{- | Primitives to convert between Float\/Double and Word32\/Word64.++Code copied from <https://hackage.haskell.org/package/binary binary>.++Based on: <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>..++Implements casting via a 1-element STUArray, as described in <http://stackoverflow.com/a/7002812/263061>.+-} module Data.FloatCast   ( floatToWord   , wordToFloat   , doubleToWord   , wordToDouble+  , runST+  , cast   ) where @@ -28,46 +32,80 @@ import           GHC.ST                         ( runST                                                 , ST                                                 )-import           Data.Flat.Endian+-- import           Flat.Endian +++-- | Reinterpret-casts a `Word32` to a `Float`.+{-|+prop> \f -> wordToFloat (floatToWord f ) == f++>>> floatToWord (-0.15625)+3189768192++>>> wordToFloat 3189768192+-0.15625++>>> floatToWord (-5.828125) == 0xC0BA8000+True+-}+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}+ -- | Reinterpret-casts a `Float` to a `Word32`. floatToWord :: Float -> Word32 floatToWord x = runST (cast x) {-# INLINE floatToWord #-} +-- $setup+-- >>> import Numeric (showHex)+-- >>> import Data.Word+ -- | Reinterpret-casts a `Double` to a `Word64`. {-|->>> doubleToWord (-0.15625)-13818169556679524352--}-doubleToWord :: Double -> Word64-doubleToWord x = fix64 $ runST (cast x)+prop> \f -> wordToDouble (doubleToWord f ) == f --- #ifdef ghcjs_HOST_OS--- doubleToWord x = (`rotateR` 32) $ runST (cast x)--- #else--- doubleToWord x = runST (cast x)--- #endif+>>> showHex (doubleToWord 1.0000000000000004) ""+"3ff0000000000002" -{-# INLINE doubleToWord #-}+>>> doubleToWord 1.0000000000000004 == 0x3FF0000000000002+True --- | Reinterpret-casts a `Word32` to a `Float`.-wordToFloat :: Word32 -> Float-wordToFloat x = runST (cast x)-{-# INLINE wordToFloat #-}+>>> showHex (doubleToWord (-0.15625)) ""+"bfc4000000000000" +>>> wordToDouble 0xbfc4000000000000+-0.15625+-}+{-# INLINE doubleToWord #-}+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+-- doubleToWord x = fix64 $ runST (cast x)+ -- | Reinterpret-casts a `Word64` to a `Double`. {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double-wordToDouble x = runST (cast $ fix64 x)+wordToDouble x = runST (cast x)+-- wordToDouble x = runST (cast $ fix64 x) +{- | +>>> runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64)+True+-}+cast+  :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b+cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0+{-# INLINE cast #-}++-- Required for older versions of ghcjs -- #ifdef ghcjs_HOST_OS+-- doubleToWord x = (`rotateR` 32) $ runST (cast x)+-- #else+-- doubleToWord x = runST (cast x)+-- #endif+-- #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,66 +1,104 @@-module Data.ZigZag(zzEncode,zzEncodeInteger,zzDecode8,zzDecode16,zzDecode32,zzDecode64,zzDecodeInteger,zzDecode) where+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+-- |<https://gist.github.com/mfuerstenau/ba870a29e16536fdbaba ZigZag encoding> of signed integrals.+module Data.ZigZag+  ( ZigZag(..)+  )+where -import Data.Word-import Data.Int-import Data.Bits+import           Data.Word+import           Data.Int+import           Data.Bits+import           Numeric.Natural -{-# SPECIALIZE INLINE zzEncode :: Int8 -> Word8 #-}-{-# SPECIALIZE INLINE zzEncode :: Int16 -> Word16 #-}-{-# SPECIALIZE INLINE zzEncode :: Int32 -> Word32 #-}-{-# SPECIALIZE INLINE zzEncode :: Int64 -> Word64 #-}-zzEncode :: (Num b, Integral a, FiniteBits a) => a -> b-zzEncode w = fromIntegral ((w `shiftL` 1) `xor` (w `shiftR` (finiteBitSize w -1)))+-- $setup+-- >>> :set -XNegativeLiterals -XScopedTypeVariables -XFlexibleContexts+-- >>> import Data.Word+-- >>> import Data.Int+-- >>> import Numeric.Natural+-- >>> import Test.QuickCheck.Instances.Natural ---{-# INLINE zzEncode8 #-}---zzEncode8 :: Int8 -> Word8--- zzEncode8 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 7))+{-|+Convert between a signed integral and the corresponding ZigZag encoded unsigned integral (e.g. between Int8 and Word8 or Integral and Natural). --- {-# INLINE zzEncode16 #-}--- zzEncode16 :: Int16 -> Word16--- zzEncode16 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 15))+Invalid conversions produce a type error: --- {-# INLINE zzEncode32 #-}--- zzEncode32 :: Int32 -> Word32--- zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 31))+zigZag (-1::Int64) :: Word32 +...+... Couldn't match type ...+... --- {-# INLINE zzEncode64 #-}--- zzEncode64 :: Int64 -> Word64--- zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63))+>>> zigZag (0::Int8)+0 -{-# INLINE zzEncodeInteger #-}-zzEncodeInteger :: Integer -> Integer-zzEncodeInteger x | x>=0      = x `shiftL` 1-                  | otherwise = negate (x `shiftL` 1) - 1+>>> zigZag (-1::Int16)+1 --- {-# SPECIALIZE INLINE zzDecode :: Word8 -> Int8 #-}--- {-# SPECIALIZE INLINE zzDecode :: Word16 -> Int16 #-}--- {-# SPECIALIZE INLINE zzDecode :: Word32 -> Int32 #-}--- {-# SPECIALIZE INLINE zzDecode :: Word64 -> Int64 #-}--- {-# SPECIALIZE INLINE zzDecode :: Integer -> Integer #-}+>>> zigZag (1::Int32)+2 -{-# INLINE zzDecode #-}-zzDecode :: (Num a, Integral a1, Bits a1) => a1 -> a-zzDecode w = fromIntegral ((w `shiftR` 1) `xor` (negate (w .&. 1)))--- zzDecode w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1)))+>>> zigZag (-2::Int16)+3 -{-# INLINE zzDecode8 #-}-zzDecode8 :: Word8 -> Int8-zzDecode8 = zzDecode+>>> zigZag (-50::Integer)+99 -{-# INLINE zzDecode16 #-}-zzDecode16 :: Word16 -> Int16-zzDecode16 = zzDecode+>>> zigZag (50::Integer)+100 -{-# INLINE zzDecode32 #-}-zzDecode32 :: Word32 -> Int32-zzDecode32 = zzDecode+>>> zigZag (64::Integer)+128 -{-# INLINE zzDecode64 #-}-zzDecode64 :: Word64 -> Int64-zzDecode64 = zzDecode+>>> zigZag (-256::Integer)+511 -{-# INLINE zzDecodeInteger #-}-zzDecodeInteger :: Integer -> Integer-zzDecodeInteger = zzDecode+>>> zigZag (256::Integer)+512 +>>> map zigZag [-3..3::Integer]+[5,3,1,0,2,4,6] +>>> map zagZig [0..6::Word8]+[0,-1,1,-2,2,-3,3]++prop> \(f::Integer) -> zagZig (zigZag f) == f++prop> \(f::Natural) -> zigZag (zagZig f) == f++prop> \(f::Int8) -> zagZig (zigZag f) == f+prop> \(f::Word8) -> zigZag (zagZig f) == f+prop> \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer))+prop> \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural))++prop> \(f::Int64) -> zagZig (zigZag f) == f+prop> \(f::Word64) -> zigZag (zagZig f) == f+prop> \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer))+prop> \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural))+-}++-- Allow conversion only between compatible types+class (Integral signed,Integral unsigned) => ZigZag signed unsigned | unsigned -> signed,signed -> unsigned where+  zigZag :: signed -> unsigned+  default zigZag :: FiniteBits signed => signed -> unsigned+  zigZag s = fromIntegral ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1)))+  {-# INLINE zigZag #-}++  zagZig :: unsigned -> signed+  default zagZig :: (Bits unsigned) => unsigned -> signed+  zagZig u = fromIntegral ((u `shiftR` 1) `xor` (negate (u .&. 1)))++  -- default zagZig :: (Bits signed) => unsigned -> signed+  -- zagZig u = let (s::signed) = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1)))+  {-# INLINE zagZig #-}++instance ZigZag Int8 Word8+instance ZigZag Int16 Word16+instance ZigZag Int32 Word32+instance ZigZag Int64 Word64+instance ZigZag Integer Natural where+  zigZag x | x >= 0    = fromIntegral $ x `shiftL` 1+           | otherwise = fromIntegral $ negate (x `shiftL` 1) - 1+  zagZig u =+    let s = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1)))

@@ -0,0 +1,19 @@+{-|+Haskell implementation of <http://quid2.org/docs/Flat.pdf Flat>, a principled, portable and efficient binary data format.++-}+module Flat+  ( module Flat.Class+  , module Flat.Filler+  , module X+  , Decoded+  , DecodeException(..)+  )+where++import           Flat.Class+import           Flat.Decoder+import           Flat.Filler+import           Flat.Instances                as X+import           Flat.Run                      as X+import           Flat.Types                     ( )

@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- |Utilities to represent and display bit sequences+module Flat.Bits+  ( Bits+  , toBools+  , fromBools+  , bits+  , paddedBits+  , asBytes+  , asBits+  )+where++import           Data.Bits               hiding ( Bits )+import qualified Data.ByteString               as B+import           Flat.Class+import           Flat.Decoder+import           Flat.Filler+import           Flat.Run+import qualified Data.Vector.Unboxed           as V+import           Data.Word+import           Text.PrettyPrint.HughesPJClass++-- |A sequence of bits+type Bits = V.Vector Bool++toBools :: Bits -> [Bool]+toBools = V.toList++fromBools :: [Bool] -> Bits+fromBools = V.fromList++-- $setup+-- >>> import Data.Word+-- >>> import Flat.Instances.Base+-- >>> import Flat.Instances.Test++{- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding)++>>> bits True+[True]+-}+bits :: forall a . Flat a => a -> Bits+bits v =+  let lbs                     = flat v+      Right (PostAligned _ f) = unflatRaw lbs :: Decoded (PostAligned a)+  in  takeBits (8 * B.length lbs - fillerLength f) lbs++{- |The sequence of bits corresponding to the byte-padded serialization of the passed value++>>> paddedBits True+[True,False,False,False,False,False,False,True]+-}+paddedBits :: forall a . Flat a => a -> Bits+paddedBits v = let lbs = flat v in takeBits (8 * B.length lbs) lbs++takeBits :: Int -> B.ByteString -> Bits+takeBits numBits lbs = V.generate+  (fromIntegral numBits)+  (\n ->+    let (bb, b) = n `divMod` 8+    in  testBit (B.index lbs (fromIntegral bb)) (7 - b)+  )++{- |Convert an integral value to its equivalent bit representation++>>> asBits (5::Word8)+[False,False,False,False,False,True,False,True]+-}+asBits :: FiniteBits a => a -> Bits+asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s - 1 -))++{- |Convert a sequence of bits to the corresponding list of bytes+ +>>> asBytes $ asBits (256+3::Word16)+[1,3]+-}+asBytes :: Bits -> [Word8]+asBytes = map byteVal . bytes . V.toList++-- |Convert to the corresponding value (most significant bit first)+byteVal :: [Bool] -> Word8+byteVal = sum . map (\(e, b) -> if b then e else 0) . zip+  [ 2 ^ n | n <- [7 :: Int, 6 .. 0] ]++-- |Split a list in groups of 8 elements or less+bytes :: [t] -> [[t]]+bytes [] = []+bytes l  = let (w, r) = splitAt 8 l in w : bytes r++{- |+>>> prettyShow $ asBits (256+3::Word16)+"00000001 00000011"+-}+instance Pretty Bits where+  pPrint = hsep . map prettyBits . bytes . V.toList++prettyBits :: Foldable t => t Bool -> Doc+prettyBits l =+  text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l+

@@ -0,0 +1,456 @@+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DefaultSignatures         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE Trustworthy               #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE UndecidableInstances      #-}++-- |Generics-based generation of Flat instances+module Flat.Class+  (+  -- * The Flat class+    Flat(..)+  , getSize+  , module GHC.Generics+  )+where++import           Data.Bits+import           Flat.Decoder+import           Flat.Encoder+import           Data.Word+import           GHC.Generics+import           GHC.TypeLits+import           Prelude           hiding (mempty)+-- import Data.Proxy+-- 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++-- |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+    -- |Return the encoding corrresponding to the value+    encode :: a -> Encoding+    default encode :: (Generic a, GEncode (Rep a)) => a -> Encoding+    encode = gencode . from++    -- |Decode a value+    decode :: Get a+    default decode :: (Generic a, GDecode (Rep a)) => Get a+    decode = to `fmap` gget++    -- |Add maximum size in bits of the value to the total count+    -- +    --  Used to calculated maximum buffer size before encoding +    size :: a -> NumBits -> NumBits+    default size :: (Generic a, GSize (Rep a)) => a -> NumBits -> NumBits+    size !x !n = gsize n $ from x++#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 a -> Encoding++instance {-# OVERLAPPABLE #-} GEncode f => GEncode (M1 i c f) where+      gencode = gencode . unM1+      {-# INLINE gencode #-}++  -- Special case, single constructor datatype+instance {-# OVERLAPPING #-} GEncode a => GEncode (D1 i (C1 c a)) where+      gencode = gencode . unM1 . unM1+      {-# INLINE gencode #-}++  -- Type without constructors+instance GEncode V1 where+      gencode = unused+      {-# INLINE gencode #-}++  -- Constructor without arguments+instance GEncode U1 where+      gencode U1 = mempty+      {-# INLINE gencode #-}++instance Flat a => GEncode (K1 i a) where+      {-# INLINE gencode #-}+#if INL == 1+      gencode x = inline encode (unK1 x)+#else+      gencode = encode . unK1+#endif++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 #-}++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 #-}++-- Constructor Encoding+class GEncodeSum f where+  gencodeSum :: Word16 -> NumBits -> f a -> Encoding++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 #-}++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+  gget :: Get (f t)++-- |Metadata (constructor name, etc)+instance GDecode a => GDecode (M1 i c a) where+    gget = M1 <$> gget+    {-# INLINE  gget #-}++-- |Type without constructors+instance GDecode V1 where+    gget = unused+    {-# INLINE  gget #-}++-- |Constructor without arguments+instance GDecode U1 where+    gget = pure U1+    {-# INLINE  gget #-}++-- |Product: constructor with parameters+instance (GDecode a, GDecode b) => GDecode (a :*: b) where+  gget = (:*:) <$> gget <*> gget+  {-# INLINE gget #-}++-- |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 #-}+++-- 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+    cs <- consOpen+    getSum cs+  {-# INLINE gget #-}++-- |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 #-}++-- |Type without constructors+instance GSize V1 where+    gsize !n _ = n+    {-# INLINE gsize #-}++-- |Constructor without arguments+instance GSize U1 where+    gsize !n _ = n+    {-# INLINE gsize #-}++-- |Skip metadata+instance Flat a => GSize (K1 i a) where+#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) = +      let !n' = gsize n x+      in gsize n' y+      -- gsize (gsize n x) y+    {-# INLINE gsize #-}++-- Alternative 'gsize' implementations+#define SIZ_ADD+-- #define SIZ_NUM++-- #define SIZ_MAX+-- #define SIZ_MAX_VAL+-- #define SIZ_MAX_PROX++#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) => GSizeSum (C1 c a) where+    {-# INLINE gsizeSum #-}+    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.."

@@ -0,0 +1,50 @@+{-# LANGUAGE CPP          #-}+-- |Strict Decoder+module Flat.Decoder (+    strictDecoder,+    -- strictDecoderPart,+    Decoded,+    DecodeException(..),+    Get,+    dByteString,+    dLazyByteString,+    dShortByteString,+    dShortByteString_,+#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+    dUTF16,+#endif+    dUTF8,+    decodeArrayWith,+    decodeListWith,+    dFloat,+    dDouble,+    dInteger,+    dNatural,+    dChar,+    dBool,+    dWord8,+    dWord16,+    dWord32,+    dWord64,+    dWord,+    dInt8,+    dInt16,+    dInt32,+    dInt64,+    dInt,+    dBE8,+    dBE16,+    dBE32,+    dBE64,+    dBEBits8,+    dBEBits16,+    dBEBits32,+    dBEBits64,+    dropBits,++    ConsState(..),consOpen,consClose,consBool,consBits+    ) where++import           Flat.Decoder.Prim+import           Flat.Decoder.Strict+import           Flat.Decoder.Types

@@ -0,0 +1,412 @@+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+-- |Strict Decoder Primitives+module Flat.Decoder.Prim (+    dBool,+    dWord8,+    dBE8,+    dBE16,+    dBE32,+    dBE64,+    dBEBits8,+    dBEBits16,+    dBEBits32,+    dBEBits64,+    dropBits,+    dFloat,+    dDouble,+    getChunksInfo,+    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           Flat.Decoder.Types+import           Flat.Endian+import           Flat.Memory+import           Data.FloatCast+import           Data.Word+import           Foreign++-- $setup+-- >>> :set -XBinaryLiterals+-- >>> import Data.Word+-- >>> import Data.Int+-- >>> import Flat.Run++{- |A special state, optimised for constructor decoding.++It consists of:++* The bits to parse, the 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+-- +-- It could read more bits that are available, but it doesn't matter, errors will be checked in consClose.+consBits :: ConsState -> Int -> (ConsState, Word)+consBits cs 3 = consBits_ cs 3 7+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 ()+ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s++{-# INLINE dropBits #-}+-- |Drop the specified number of bits+dropBits :: Int -> Get ()+dropBits n+  | n > 0 = Get $ \endPtr s -> do+      ensureBits endPtr s n+      return $ GetResult (dropBits_ s n) ()+  | 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+  -- let+  --   n' = n+usedBits s+  --   bytes = n' `shR` 3+  --   bits = n' .|. 7+  in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}++{-# INLINE dBool #-} +-- Inlining dBool Massively increases compilation time and decreases run time by a third+-- TODO: test dBool inlining for 8.8.3+-- |Decode a boolean+dBool :: Get Bool+dBool = Get $ \endPtr s ->+  if currPtr s >= endPtr+    then notEnoughSpace endPtr s+    else do+      !w <- peek (currPtr 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) [0b11100001::Word8] == Right 0b00000111+True+-}+dBEBits8 :: Int -> Get Word8+dBEBits8 n = Get $ \endPtr s -> do+      ensureBits endPtr s n+      take8 s n++{-# INLINE dBEBits16  #-}+-- |Return the n most significant bits (up to maximum of 16)+-- The bits are returned right shifted.+dBEBits16 :: Int -> Get Word16+dBEBits16 n = Get $ \endPtr s -> do+      ensureBits endPtr s n+      takeN n s++{-# INLINE dBEBits32  #-}+-- |Return the n most significant bits (up to maximum of 8)+-- The bits are returned right shifted.+dBEBits32 :: Int -> Get Word32+dBEBits32 n = Get $ \endPtr s -> do+      ensureBits endPtr s n+      takeN n s++{-# INLINE dBEBits64  #-}+-- |Return the n most significant bits (up to maximum of 8)+-- The bits are returned right shifted.+dBEBits64 :: Int -> Get Word64+dBEBits64 n = Get $ \endPtr s -> do+      ensureBits endPtr s n+      takeN n s++-- {-# INLINE take8 #-}+-- take8 :: Int -> S -> IO (GetResult Word8)+-- take8 n s+--   | n == 0 = return $ GetResult s 0++--   -- all bits in the same byte+--   | 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) `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) `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+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) `shR` (8 - n)+            else do -- two different bytes+              w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)+              return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)+          | otherwise = error $ unwords ["read8: cannot read",show n,"bits"]+    -- {-# 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+   where+     read s r sh n | n <=0 = return $ GetResult s r+                   | otherwise = do+                     let m = n `min` 8+                     GetResult s' b <- take8 s m+                     read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh-8) `max` 0) (n-8)++-- takeN n = Get $ \endPtr s -> do+--   ensureBits endPtr s n+--   let (bytes,bits) = (n+usedBits s) `divMod` 8+--   r <- case bytes of+--     0 -> do+--       w <- peek (currPtr s)+--       return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `shR` (8 - n))+--     1 -> do+--       w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)+--       return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)+--     2 -> do+--       let r = 0+--       w1 <- fromIntegral <$> r8 s+--       w2 <- fromIntegral <$> r16 s+--       w1+--   return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) r++-- r8 s = peek (currPtr s)+-- r16 s = toBE16 <$> peek (castPtr $ currPtr s)++-- |Return the 8 most significant bits (same as dBE8)+dWord8 :: Get Word8+dWord8 = dBE8++{-# INLINE dBE8  #-}+-- |Return the 8 most significant bits+dBE8 :: Get Word8+dBE8 = Get $ \endPtr s -> do+      ensureBits endPtr s 8+      !w1 <- peek (currPtr s)+      !w <- if usedBits s == 0+            then return w1+            else do+                   !w2 <- peek (currPtr s `plusPtr` 1)+                   return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `shR` (8-usedBits s))+      return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w++{-# INLINE dBE16 #-}+-- |Return the 16 most significant bits+dBE16 :: Get Word16+dBE16 = Get $ \endPtr s -> do+  ensureBits endPtr s 16+  !w1 <- toBE16 <$> peek (castPtr $ currPtr s)+  !w <- if usedBits s == 0+        then return w1+        else do+           !(w2::Word8) <- peek (currPtr s `plusPtr` 2)+           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))+  return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w++{-# INLINE dBE32 #-}+-- |Return the 32 most significant bits+dBE32 :: Get Word32+dBE32 = Get $ \endPtr s -> do+  ensureBits endPtr s 32+  !w1 <- toBE32 <$> peek (castPtr $ currPtr s)+  !w <- if usedBits s == 0+        then return w1+        else do+           !(w2::Word8) <- peek (currPtr s `plusPtr` 4)+           return $ w1 `unsafeShiftL` usedBits s  .|. fromIntegral (w2 `shR` (8-usedBits s))+  return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w++{-# INLINE dBE64 #-}+-- |Return the 64 most significant bits+dBE64 :: Get Word64+dBE64 = Get $ \endPtr s -> do+  ensureBits endPtr s 64+  -- !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 `shR` (8-usedBits s))+  return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) w+    where+      -- {-# INLINE peek64 #-}+      peek64 :: Ptr Word64 -> IO Word64+      peek64 = peek+      -- peek64 ptr = fix64 <$> peek ptr++{-# INLINE dFloat #-}+-- |Decode a Float+dFloat :: Get Float+dFloat = wordToFloat <$> dBE32++{-# INLINE dDouble #-}+-- |Decode a Double+dDouble :: Get Double+dDouble = wordToDouble <$> dBE64++-- |Decode a Lazy ByteString+dLazyByteString_ :: Get L.ByteString+dLazyByteString_ = L.fromStrict <$> dByteString_++-- |Decode a ByteString+dByteString_ :: Get B.ByteString+dByteString_ = chunksToByteString <$> getChunksInfo++-- |Decode a ByteArray and its length+dByteArray_ :: Get (ByteArray,Int)+dByteArray_ = chunksToByteArray <$> getChunksInfo++-- |Decode an Array (a list of chunks up to 255 bytes long) returning the pointer to the first data byte and a list of chunk sizes+getChunksInfo :: Get (Ptr Word8, [Int])+getChunksInfo = Get $ \endPtr s -> do++   let getChunks srcPtr l = do+          ensureBits endPtr s 8+          !n <- fromIntegral <$> peek srcPtr+          if n==0+            then return (srcPtr `plusPtr` 1,l [])+            else do+              ensureBits endPtr s ((n+1)*8)+              getChunks (srcPtr `plusPtr` (n+1)) (l . (n:)) -- ETA: stack overflow (missing tail call optimisation)++   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+-- {- |+-- Shift right with sign extension.++-- >>> shR (0b1111111111111111::Word16) 3 == 0b0001111111111111+-- True++-- >>> shR (-1::Int16) 3 +-- -1+-- -}  +{-# 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

@@ -0,0 +1,267 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP          #-}++-- |Strict Decoder+module Flat.Decoder.Strict+  ( decodeArrayWith+  , decodeListWith+  , dByteString+  , dLazyByteString+  , dShortByteString+  , dShortByteString_+#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+  , dUTF16+#endif+  , dUTF8+  , dInteger+  , dNatural+  , dChar+  , dWord8+  , dWord16+  , dWord32+  , dWord64+  , dWord+  , dInt8+  , dInt16+  , dInt32+  , dInt64+  , dInt+  ) where++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.Short.Internal as SBS+import qualified Data.DList                     as DL+import           Flat.Decoder.Prim+import           Flat.Decoder.Types+import           Data.Int+import           Data.Primitive.ByteArray+import qualified Data.Text                      as T+import qualified Data.Text.Encoding             as T++#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+import qualified Data.Text.Array                as TA+import qualified Data.Text.Internal             as T+#endif++import           Data.Word+import           Data.ZigZag+import           GHC.Base                       (unsafeChr)+import           Numeric.Natural++#include "MachDeps.h"++{-# INLINE decodeListWith #-}+decodeListWith :: Get a -> Get [a]+decodeListWith dec = go+  where+    go = do+      b <- dBool+      if b+        then (:) <$> dec <*> go+        else return []++decodeArrayWith :: Get a -> Get [a]+decodeArrayWith dec = DL.toList <$> getAsL_ dec++-- TODO: test if it would it be faster with DList.unfoldr :: (b -> Maybe (a, b)) -> b -> Data.DList.DList a+--  getAsL_ :: Flat a => Get (DL.DList a)+getAsL_ :: Get a -> Get (DL.DList a)+getAsL_ dec = do+  tag <- dWord8+  case tag of+    0 -> return DL.empty+    _ -> do+      h <- gets tag+      t <- getAsL_ dec+      return (DL.append h t)+  where+    gets 0 = return DL.empty+    gets n = DL.cons <$> dec <*> gets (n - 1)++{-# INLINE dNatural #-}+dNatural :: Get Natural+dNatural = dUnsigned++{-# INLINE dInteger #-}+dInteger :: Get Integer+dInteger = zagZig <$> dUnsigned++{-# INLINE dWord #-}+{-# INLINE dInt #-}+dWord :: Get Word+dInt :: Get Int+#if WORD_SIZE_IN_BITS == 64+dWord = (fromIntegral :: Word64 -> Word) <$> dWord64++dInt = (fromIntegral :: Int64 -> Int) <$> dInt64+#elif WORD_SIZE_IN_BITS == 32+dWord = (fromIntegral :: Word32 -> Word) <$> dWord32++dInt = (fromIntegral :: Int32 -> Int) <$> dInt32+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif++{-# INLINE dInt8 #-}+dInt8 :: Get Int8+dInt8 = zagZig <$> dWord8++{-# INLINE dInt16 #-}+dInt16 :: Get Int16+dInt16 = zagZig <$> dWord16++{-# INLINE dInt32 #-}+dInt32 :: Get Int32+dInt32 = zagZig <$> dWord32++{-# INLINE dInt64 #-}+dInt64 :: Get Int64+dInt64 = zagZig <$> dWord64++-- {-# INLINE dWord16  #-}+dWord16 :: Get Word16+dWord16 = wordStep 0 (wordStep 7 (lastStep 14)) 0++-- {-# INLINE dWord32  #-}+dWord32 :: Get Word32+dWord32 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (lastStep 28)))) 0++-- {-# INLINE dWord64  #-}+dWord64 :: Get Word64+dWord64 =+  wordStep+    0+    (wordStep+       7+       (wordStep+          14+          (wordStep+             21+             (wordStep+                28+                (wordStep+                   35+                   (wordStep+                      42+                      (wordStep+                         49+                         (wordStep 56 (wordStep 63 (wordStep 70 (lastStep 77)))))))))))+    0++{-# INLINE dChar #-}+dChar :: Get Char+-- dChar = chr . fromIntegral <$> dWord32+-- Not really faster than the simpler version above+dChar = charStep 0 (charStep 7 (lastCharStep 14)) 0++{-# INLINE charStep #-}+charStep :: Int -> (Int -> Get Char) -> Int -> Get Char+charStep !shl !cont !n = do+  !tw <- fromIntegral <$> dWord8+  let !w = tw .&. 127+  let !v = n .|. (w `shift` shl)+  if tw == w+    then return $ unsafeChr v+    else cont v++{-# INLINE lastCharStep #-}+lastCharStep :: Int -> Int -> Get Char+lastCharStep !shl !n = do+  !tw <- fromIntegral <$> dWord8+  let !w = tw .&. 127+  let !v = n .|. (w `shift` shl)+  if tw == w+    then if v > 0x10FFFF+           then charErr v+           else return $ unsafeChr v+    else charErr v+ where +  charErr v = fail $ concat ["Unexpected extra byte or non unicode char", show v]++{-# INLINE wordStep #-}+wordStep :: (Bits a, Num a) => Int -> (a -> Get a) -> a -> Get a+wordStep shl k n = do+  tw <- fromIntegral <$> dWord8+  let w = tw .&. 127+  let v = n .|. (w `shift` shl)+  if tw == w+    then return v+    --else oneShot k v+    else k v++{-# INLINE lastStep #-}+lastStep :: (FiniteBits b, Show b, Num b) => Int -> b -> Get b+lastStep shl n = do+  tw <- fromIntegral <$> dWord8+  let w = tw .&. 127+  let v = n .|. (w `shift` shl)+  if tw == w+    then if countLeadingZeros w < shl+           then wordErr v+           else return v+    else wordErr v+ where +   wordErr v = fail $ concat ["Unexpected extra byte in unsigned integer", show v]++-- {-# INLINE dUnsigned #-}+dUnsigned :: (Num b, Bits b) => Get b+dUnsigned = do+  (v, shl) <- dUnsigned_ 0 0+  maybe+    (return v)+    (\s ->+       if shl >= s+         then fail "Unexpected extra data in unsigned integer"+         else return v) $+    bitSizeMaybe v++-- {-# INLINE dUnsigned_ #-}+dUnsigned_ :: (Bits t, Num t) => Int -> t -> Get (t, Int)+dUnsigned_ shl n = do+  tw <- dWord8+  let w = tw .&. 127+  let v = n .|. (fromIntegral w `shift` shl)+  if tw == w+    then return (v, shl)+    else dUnsigned_ (shl + 7) v+--encode = encode . blob UTF8Encoding . L.fromStrict . T.encodeUtf8+--decode = T.decodeUtf8 . L.toStrict . (unblob :: BLOB UTF8Encoding -> L.ByteString) <$> decode+#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+-- BLOB UTF16Encoding+dUTF16 :: Get T.Text+dUTF16 = do+  _ <- dFiller+  -- Checked decoding+  -- T.decodeUtf16LE <$> dByteString_+  -- Unchecked decoding+  (ByteArray array, lengthInBytes) <- dByteArray_+  return (T.Text (TA.Array array) 0 (lengthInBytes `div` 2))+#endif+dUTF8 :: Get T.Text+dUTF8 = do+  _ <- dFiller+  T.decodeUtf8 <$> dByteString_++dFiller :: Get ()+dFiller = do+  tag <- dBool+  case tag of+    False -> dFiller+    True  -> return ()++dLazyByteString :: Get L.ByteString+dLazyByteString = dFiller >> dLazyByteString_++dShortByteString :: Get SBS.ShortByteString+dShortByteString = dFiller >> dShortByteString_++dShortByteString_ :: Get SBS.ShortByteString+dShortByteString_ = do+  (ByteArray array, _) <- dByteArray_+  return $ SBS.SBS array++dByteString :: Get B.ByteString+dByteString = dFiller >> dByteString_

@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns  #-}+{-# LANGUAGE CPP           #-}+{-# LANGUAGE DeriveFunctor #-}++-- |Strict Decoder Types+module Flat.Decoder.Types+  ( strictDecoder+  -- , strictDecoderPart+  , Get(..)+  , S(..)+  , GetResult(..)+  , Decoded+  , DecodeException(..)+  , notEnoughSpace+  , tooMuchSpace+  , badEncoding+  ) where++import           Control.DeepSeq+import           Control.Exception+import qualified Data.ByteString          as B+import qualified Data.ByteString.Internal as BS+import           Data.Word+import           Foreign+import           System.IO.Unsafe+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail       as Fail+#endif+++strictDecoder :: Get a -> B.ByteString -> Either DecodeException a+strictDecoder get bs =+  strictDecoder_ get bs $ \(GetResult s'@(S ptr' o') a) endPtr ->+    if ptr' /= endPtr || o' /= 0+      then tooMuchSpace endPtr s'+      else return a++-- strictDecoderPart :: Get a -> B.ByteString -> Either DecodeException a+-- strictDecoderPart get bs =+--   strictDecoder_ get bs $ \(GetResult _ a) _ -> return a++strictDecoder_ ::+     Exception e+  => Get a1+  -> BS.ByteString+  -> (GetResult a1 -> Ptr b -> IO a)+  -> Either e a+strictDecoder_ get (BS.PS base off len) check =+  unsafePerformIO . try $+  withForeignPtr base $ \base0 ->+    let ptr = base0 `plusPtr` off+        endPtr = ptr `plusPtr` len+     in do res <- runGet get endPtr (S ptr 0)+           check res endPtr++-- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits)+-- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $+--   withForeignPtr base $ \base0 ->+--     let ptr = base0 `plusPtr` off+--         endPtr = ptr `plusPtr` len+--     in do+--       GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0)+--       return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o')+++-- |Decoder monad+newtype Get a =+  Get+    { runGet :: +      Ptr Word8 -> S -> IO (GetResult a)+    } -- 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 !_ = ()++instance Show (Get a) where+  show _ = "Get"++instance Applicative Get where+  pure x = Get (\_ ptr -> return $ GetResult ptr x)+  {-# INLINE pure #-}+  Get f <*> Get g =+    Get $ \end ptr1 -> do+      GetResult ptr2 f' <- f end ptr1+      GetResult ptr3 g' <- g end ptr2+      return $ GetResult ptr3 (f' g')+  {-# INLINE (<*>) #-}+  Get f *> Get g =+    Get $ \end ptr1 -> do+      GetResult ptr2 _ <- f end ptr1+      g end ptr2+  {-# INLINE (*>) #-}++instance Monad Get where+  return = pure+  {-# INLINE return #-}+  (>>) = (*>)+  {-# INLINE (>>) #-}+  Get x >>= f =+    Get $ \end s -> do+      GetResult s' x' <- x end s+      runGet (f x') end s'+  {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+  fail = failGet+                 -- base < 4.13+#endif++#if MIN_VERSION_base(4,9,0)+instance Fail.MonadFail Get where+  fail = failGet+#endif+{-# INLINE failGet #-}+failGet :: String -> Get a+failGet msg = Get $ \end s -> badEncoding end s msg++-- |Decoder state+data S =+  S+    { currPtr  :: {-# UNPACK #-}!(Ptr Word8)+    , usedBits :: {-# UNPACK #-}!Int+    }+  deriving (Show, Eq, Ord)++data GetResult a =+  GetResult {-# UNPACK #-}!S !a+  deriving (Functor)++-- |A decoded value+type Decoded a = Either DecodeException a++-- |An exception during decoding+data DecodeException+  = NotEnoughSpace Env+  | TooMuchSpace Env+  | BadEncoding Env String+  deriving (Show, Eq, Ord)++type Env = (Ptr Word8, S)++notEnoughSpace :: Ptr Word8 -> S -> IO a+notEnoughSpace endPtr s = throwIO $ NotEnoughSpace (endPtr, s)++tooMuchSpace :: Ptr Word8 -> S -> IO a+tooMuchSpace endPtr s = throwIO $ TooMuchSpace (endPtr, s)++badEncoding :: Ptr Word8 -> S -> String -> IO a+badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr, s) msg++instance Exception DecodeException

@@ -0,0 +1,80 @@+{-# LANGUAGE CPP   ,NoMonomorphismRestriction    #-}+-- |Encoder and encoding primitives+module Flat.Encoder (+    Encoding,+    (<>),+    NumBits,+    encodersS,+    mempty,+    strictEncoder,+    eTrueF,+    eFalseF,+    eFloat,+    eDouble,+    eInteger,+    eNatural,+    eWord16,+    eWord32,+    eWord64,+    eWord8,+    eBits,+    eBits16,+    eFiller,+    eBool,+    eTrue,+    eFalse,+    eBytes,+#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+    eUTF16,+#endif+    eLazyBytes,+    eShortBytes,+    eInt,+    eInt8,+    eInt16,+    eInt32,+    eInt64,+    eWord,+    eChar,+    encodeArrayWith,+    encodeListWith,+    Size,+    arrayBits,+    sWord,+    sWord8,+    sWord16,+    sWord32,+    sWord64,+    sInt,+    sInt8,+    sInt16,+    sInt32,+    sInt64,+    sNatural,+    sInteger,+    sFloat,+    sDouble,+    sChar,+    sBytes,+    sLazyBytes,+    sShortBytes,+#ifndef ghcjs_HOST_OS+    sUTF16,+#endif+    sFillerMax,+    sBool,+    sUTF8Max,+    eUTF8,+#ifdef ETA_VERSION+    trampolineEncoding,+#endif+    ) where++import           Flat.Encoder.Prim+import           Flat.Encoder.Size(arrayBits)+import           Flat.Encoder.Strict+import           Flat.Encoder.Types++#if ! MIN_VERSION_base(4,11,0)+import           Data.Semigroup((<>))+#endif

@@ -0,0 +1,434 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE UnboxedTuples       #-}++-- |Encoding Primitives+module Flat.Encoder.Prim+  ( eBits16F+  , eBitsF+  , eFloatF+  , eDoubleF+#if ! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+  , eUTF16F+#endif+  , eUTF8F+  , eCharF+  , eNaturalF+  , eIntegerF+  , eInt64F+  , eInt32F+  , eIntF+  , eInt16F+  , eInt8F+  , eWordF+  , eWord64F+  , eWord32F+  , eWord16F+  , eBytesF+  , eLazyBytesF+  , eShortBytesF+  , eWord8F+  , eFillerF+  , eBoolF+  , eTrueF+  , eFalseF+  , varWordF+  , w7l+    -- * Exported for testing only+  , eWord32BEF+  , eWord64BEF+  , eWord32E+  , eWord64E+  ) where++import           Control.Monad+import qualified Data.ByteString                as B+import qualified Data.ByteString.Lazy           as L+import qualified Data.ByteString.Lazy.Internal  as L+import qualified Data.ByteString.Short.Internal as SBS+import           Data.Char+import           Flat.Encoder.Types+import           Flat.Endian+import           Flat.Memory+import           Flat.Types+import           Data.FloatCast+import           Data.Primitive.ByteArray+import qualified Data.Text                      as T+#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+import qualified Data.Text.Array                as TA+import qualified Data.Text.Internal             as TI+#endif+import qualified Data.Text.Encoding             as TE+import           Data.ZigZag+import           Foreign+-- import Debug.Trace+#include "MachDeps.h"+-- traceShowId :: a -> a+-- traceShowId = id+{-# INLINE eFloatF #-}+eFloatF :: Float -> Prim+eFloatF = eWord32BEF . floatToWord++{-# INLINE eDoubleF #-}+eDoubleF :: Double -> Prim+eDoubleF = eWord64BEF . doubleToWord++{-# INLINE eWord64BEF #-}+eWord64BEF :: Word64 -> Prim+eWord64BEF = eWord64E toBE64++{-# INLINE eWord32BEF #-}+eWord32BEF :: Word32 -> Prim+eWord32BEF = eWord32E toBE32++{-# INLINE eCharF #-}+eCharF :: Char -> Prim+eCharF = eWord32F . fromIntegral . ord++{-# INLINE eWordF #-}+eWordF :: Word -> Prim+{-# INLINE eIntF #-}+eIntF :: Int -> Prim+#if WORD_SIZE_IN_BITS == 64+eWordF = eWord64F . (fromIntegral :: Word -> Word64)++eIntF = eInt64F . (fromIntegral :: Int -> Int64)+#elif WORD_SIZE_IN_BITS == 32+eWordF = eWord32F . (fromIntegral :: Word -> Word32)++eIntF = eInt32F . (fromIntegral :: Int -> Int32)+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif+{-# INLINE eInt8F #-}+eInt8F :: Int8 -> Prim+eInt8F = eWord8F . zigZag++{-# INLINE eInt16F #-}+eInt16F :: Int16 -> Prim+eInt16F = eWord16F . zigZag++{-# INLINE eInt32F #-}+eInt32F :: Int32 -> Prim+eInt32F = eWord32F . zigZag++{-# INLINE eInt64F #-}+eInt64F :: Int64 -> Prim+eInt64F = eWord64F . zigZag++{-# INLINE eIntegerF #-}+eIntegerF :: Integer -> Prim+eIntegerF = eIntegralF . zigZag++{-# INLINE eNaturalF #-}+eNaturalF :: Natural -> Prim+eNaturalF = eIntegralF . toInteger++{-# INLINE eIntegralF #-}+eIntegralF :: (Bits t, Integral t) => t -> Prim+eIntegralF t =+  let vs = w7l t+   in eIntegralW vs++w7l :: (Bits t, Integral t) => t -> [Word8]+w7l t =+  let l = low7 t+      t' = t `unsafeShiftR` 7+   in if t' == 0+        then [l]+        else w7 l : w7l t'+  where+    {-# INLINE w7 #-}+    --lowByte :: (Bits t, Num t) => t -> Word8+    w7 :: Word8 -> Word8+    w7 l = l .|. 0x80++-- | Encoded as: data NonEmptyList = Elem Word7 | Cons Word7 List+{-# INLINE eIntegralW #-}+eIntegralW :: [Word8] -> Prim+eIntegralW vs s@(S op _ o)+  | o == 0 = foldM pokeWord' op vs >>= \op' -> return (S op' 0 0)+  | otherwise = foldM (flip eWord8F) s vs++{-# INLINE eWord8F #-}+eWord8F :: Word8 -> Prim+eWord8F t s@(S op _ o)+  | o == 0 = pokeWord op t+  | otherwise = pokeByteUnaligned t s++{-# 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 (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 = 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+eWord16F = varWordF++{-# INLINE eWord32F #-}+eWord32F :: Word32 -> Prim+eWord32F = varWordF++{-# INLINE eWord64F #-}+eWord64F :: Word64 -> Prim+eWord64F = varWordF++{-# INLINE varWordF #-}+varWordF :: (Bits t, Integral t) => t -> Prim+varWordF t s@(S _ _ o)+  | o == 0 = varWord pokeByteAligned t s+  | otherwise = varWord pokeByteUnaligned t s++{-# INLINE varWord #-}+varWord :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim+varWord writeByte t s+  | t < 128 = writeByte (fromIntegral t) s+  | t < 16384 = varWord2_ writeByte t s+  | t < 2097152 = varWord3_ writeByte t s+  | otherwise = varWordN_ writeByte t s+  where+    {-# INLINE varWord2_ #-}+      -- TODO: optimise, using a single Write16?+    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 `unsafeShiftR` 7) .|. 0x80) >>=+      writeByte (fromIntegral (t `unsafeShiftR` 14) .&. 0x7F)++-- {-# INLINE varWordN #-}+varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim+varWordN_ writeByte = go+  where+    go !v !st =+      let !l = low7 v+          !v' = v `unsafeShiftR` 7+       in if v' == 0+            then writeByte l st+            else writeByte (l .|. 0x80) st >>= go v'++{-# INLINE low7 #-}+low7 :: (Integral a) => a -> Word8+low7 t = fromIntegral t .&. 0x7F++-- | Encode text as UTF8 and encode the result as an array of bytes+-- PROB: encodeUtf8 calls a C primitive, not compatible with GHCJS (fixed in latest versions of GHCJS?)+eUTF8F :: T.Text -> Prim+eUTF8F = eBytesF . TE.encodeUtf8++-- PROB: Not compatible with GHCJS or ETA (that is big endian and writes contents in reverse order)+-- | Encode text as UTF16 and encode the result as an array of bytes+-- Efficient, as Text is already internally encoded as UTF16.+#if ! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+eUTF16F :: T.Text -> Prim+eUTF16F t = eFillerF >=> eUTF16F_ t+  where+    eUTF16F_ !(TI.Text (TA.Array array) w16Off w16Len) s =+      writeArray array (2 * w16Off) (2 * w16Len) (nextPtr s)+#endif++-- |Encode a Lazy ByteString+eLazyBytesF :: L.ByteString -> Prim+eLazyBytesF bs = eFillerF >=> \s -> write bs (nextPtr s)+    -- Single copy+  where+    write lbs op = do+      case lbs of+        L.Chunk h t -> writeBS h op >>= write t+        L.Empty     -> pokeWord op 0++{-# INLINE eShortBytesF #-}+eShortBytesF :: SBS.ShortByteString -> Prim+eShortBytesF bs = eFillerF >=> eShortBytesF_ bs++eShortBytesF_ :: SBS.ShortByteString -> Prim+eShortBytesF_ bs@(SBS.SBS arr) =+  \(S op _ 0) -> writeArray arr 0 (SBS.length bs) op++-- data Array a = Array0 | Array1 a ... | Array255 ...+writeArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO S+writeArray arr soff slen sop = do+  op' <- go soff slen sop+  pokeWord op' 0+  where+    go !off !len !op+      | len == 0 = return op+      | otherwise =+        let l = min 255 len+         in pokeWord' op (fromIntegral l) >>= pokeByteArray arr off l >>=+            go (off + l) (len - l)++eBytesF :: B.ByteString -> Prim+eBytesF bs = eFillerF >=> eBytesF_+  where+    eBytesF_ s = do+      op' <- writeBS bs (nextPtr s)+      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:+n = 6+t = 00.101011+o = 3+w = 111.00000++After:+[ptr] = w(111)t(10101)+w' = t(1)0000000+o'= 1++o'=3+6=9+f = 8-9 = -1+o'' = 1+8-o''=7++if n=8,o=3:+o'=11+f=8-11=-3+o''=3+8-o''=5+-}+-- {-# 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 `unsafeShiftL` f)) o'+           | f == 0 -> pokeWord op (w .|. t)+           | otherwise ->+             let o'' = -f+              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+eBoolF True  = eTrueF++{-# INLINE eTrueF #-}+eTrueF :: Prim+eTrueF (S op w o)+  | o == 7 = pokeWord op (w .|. 1)+  | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o + 1))++{-# INLINE eFalseF #-}+eFalseF :: Prim+eFalseF (S op w o)+  | o == 7 = pokeWord op w+  | otherwise = return (S op w (o + 1))++{-# INLINE eFillerF #-}+eFillerF :: Prim+eFillerF (S op w _) = pokeWord op (w .|. 1)++-- {-# INLINE poke16 #-}+-- TODO TEST+-- poke16 :: Word16 -> Prim+-- poke16 t (S op w o) | o == 0 = poke op w >> skipBytes op 2+{-# INLINE pokeByteUnaligned #-}+pokeByteUnaligned :: Word8 -> Prim+pokeByteUnaligned t (S op w o) =+  poke op (w .|. (t `unsafeShiftR` o)) >>+  return (S (plusPtr op 1) (t `unsafeShiftL` (8 - o)) o)++{-# INLINE pokeByteAligned #-}+pokeByteAligned :: Word8 -> Prim+pokeByteAligned t (S op _ _) = pokeWord op t++{-# INLINE pokeWord #-}+pokeWord :: Storable a => Ptr a -> a -> IO S+pokeWord op w = poke op w >> skipByte op++{-# INLINE pokeWord' #-}+pokeWord' :: Storable a => Ptr a -> a -> IO (Ptr b)+pokeWord' op w = poke op w >> return (plusPtr op 1)++{-# INLINE pokeW #-}+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) (conv t)+-- 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)++{-# INLINE skipBytes #-}+skipBytes :: Monad m => Ptr a -> Int -> m S+skipBytes op n = return (S (plusPtr op n) 0 0)++--{-# INLINE nextByteW #-}+--nextByteW op w = return (S (plusPtr op 1) 0 0)+writeBS :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)+writeBS bs op -- @(BS.PS foreignPointer sourceOffset sourceLength) op+  | B.length bs == 0 = return op+  | otherwise =+    let (h, t) = B.splitAt 255 bs+     in pokeWord' op (fromIntegral $ B.length h :: Word8) >>= pokeByteString h >>=+        writeBS t+    -- 2X slower (why?)+    -- withForeignPtr foreignPointer goS+    --   where+    --     goS sourcePointer = go op (sourcePointer `plusPtr` sourceOffset) sourceLength+    --       where+    --         go !op !off !len | len == 0 = return op+    --                          | otherwise = do+    --                           let l = min 255 len+    --                           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

@@ -0,0 +1,189 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP          #-}++-- |Primitives to calculate the encoding size of a value+module Flat.Encoder.Size where++import           Data.Bits+import qualified Data.ByteString                as B+import qualified Data.ByteString.Lazy           as L+import qualified Data.ByteString.Short.Internal as SBS+import           Data.Char+import           Flat.Encoder.Prim         (w7l)+import           Flat.Encoder.Types+import           Flat.Types+import qualified Data.Text                      as T+#ifndef ghcjs_HOST_OS+import qualified Data.Text.Internal             as TI+#endif+import           Data.ZigZag+#include "MachDeps.h"+-- A filler can take anything from 1 to 8 bits+sFillerMax :: NumBits+sFillerMax = 8++sBool :: NumBits+sBool = 1++sWord8 :: NumBits+sWord8 = 8++sInt8 :: NumBits+sInt8 = 8++sFloat :: NumBits+sFloat = 32++sDouble :: NumBits+sDouble = 64++{-# INLINE sChar #-}+sChar :: Char -> NumBits+sChar = sWord32 . fromIntegral . ord++sCharMax :: NumBits+sCharMax = 24++{-# INLINE sWord #-}+sWord :: Word -> NumBits+{-# INLINE sInt #-}+sInt :: Int -> NumBits+#if WORD_SIZE_IN_BITS == 64+sWord = sWord64 . fromIntegral++sInt = sInt64 . fromIntegral+#elif WORD_SIZE_IN_BITS == 32+sWord = sWord32 . fromIntegral++sInt = sInt32 . fromIntegral+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif+-- TODO: optimize ints sizes+{-# INLINE sInt16 #-}+sInt16 :: Int16 -> NumBits+sInt16 = sWord16 . zigZag++{-# INLINE sInt32 #-}+sInt32 :: Int32 -> NumBits+sInt32 = sWord32 . zigZag++{-# INLINE sInt64 #-}+sInt64 :: Int64 -> NumBits+sInt64 = sWord64 . zigZag++{-# INLINE sWord16 #-}+sWord16 :: Word16 -> NumBits+sWord16 w+  | w < 128 = 8+  | w < 16384 = 16+  | otherwise = 24++{-# INLINE sWord32 #-}+sWord32 :: Word32 -> NumBits+sWord32 w+  | w < 128 = 8+  | w < 16384 = 16+  | w < 2097152 = 24+  | w < 268435456 = 32+  | otherwise = 40++{-# INLINE sWord64 #-}+sWord64 :: Word64 -> NumBits+sWord64 w+  | w < 128 = 8+  | w < 16384 = 16+  | w < 2097152 = 24+  | w < 268435456 = 32+  | w < 34359738368 = 40+  | w < 4398046511104 = 48+  | w < 562949953421312 = 56+  | w < 72057594037927936 = 64+  | w < 9223372036854775808 = 72+  | otherwise = 80++{-# INLINE sInteger #-}+sInteger :: Integer -> NumBits+sInteger = sIntegral . zigZag++{-# INLINE sNatural #-}+sNatural :: Natural -> NumBits+sNatural = sIntegral . toInteger++-- BAD: duplication of work with encoding+{-# INLINE sIntegral #-}+sIntegral :: (Bits t, Integral t) => t -> Int+sIntegral t =+  let vs = w7l t+   in length vs * 8++--sUTF8 :: T.Text -> NumBits+--sUTF8 t = fold+-- Wildly pessimistic but fast+{-# INLINE sUTF8Max #-}+sUTF8Max :: Text -> NumBits+sUTF8Max = blobBits . (4 *) . T.length+#ifndef ghcjs_HOST_OS+{-# INLINE sUTF16 #-}+sUTF16 :: T.Text -> NumBits+sUTF16 = blobBits . textBytes+#endif+{-# INLINE sBytes #-}+sBytes :: B.ByteString -> NumBits+sBytes = blobBits . B.length++{-# INLINE sLazyBytes #-}+sLazyBytes :: L.ByteString -> NumBits+sLazyBytes bs = 16 + L.foldrChunks (\b l -> blkBitsBS b + l) 0 bs++{-# INLINE sShortBytes #-}+sShortBytes :: SBS.ShortByteString -> NumBits+sShortBytes = blobBits . SBS.length++#ifndef ghcjs_HOST_OS+-- We are not interested in the number of unicode chars (returned by T.length, an O(n) operation)+-- just the number of bytes+-- > T.length (T.pack "\x1F600")+-- 1+-- > textBytes (T.pack "\x1F600")+-- 4+{-# INLINE textBytes #-}+textBytes :: T.Text -> Int+textBytes !(TI.Text _ _ w16Len) = w16Len * 2+#endif++{-# INLINE bitsToBytes #-}+bitsToBytes :: Int -> Int+bitsToBytes = numBlks 8++{-# INLINE numBlks #-}+numBlks :: Integral t => t -> t -> t+numBlks blkSize bits =+  let (d, m) = bits `divMod` blkSize+   in d ++      (if m == 0+         then 0+         else 1)++{-# INLINE arrayBits #-}+arrayBits :: Int -> NumBits+arrayBits = (8 *) . arrayChunks++{-# INLINE arrayChunks #-}+arrayChunks :: Int -> NumBits+arrayChunks = (1 +) . numBlks 255++{-# INLINE blobBits #-}+blobBits :: Int -> NumBits+blobBits numBytes =+  16 -- initial filler + final 0+   ++  blksBits numBytes++{-# INLINE blkBitsBS #-}+blkBitsBS :: B.ByteString -> NumBits+blkBitsBS = blksBits . B.length++{-# INLINE blksBits #-}+blksBits :: Int -> NumBits+blksBits numBytes = 8 * (numBytes + numBlks 255 numBytes)

@@ -0,0 +1,292 @@+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}++-- |Strict encoder+module Flat.Encoder.Strict where++import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as L+import           Flat.Encoder.Prim+import qualified Flat.Encoder.Size  as S+import           Flat.Encoder.Types+import           Flat.Memory+import           Flat.Types+import           Data.Foldable++-- import           Data.Semigroup+-- import           Data.Semigroup          (Semigroup (..))++#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup          (Semigroup (..))+#endif++#ifdef ETA_VERSION+-- import Data.Function(trampoline)+import           GHC.IO                  (trampolineIO)+trampolineEncoding :: Encoding -> Encoding+trampolineEncoding (Encoding op) = Encoding (\s -> trampolineIO (op s))+#else++-- trampolineIO = id+#endif++-- |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, ())++newtype Encoding =+  Encoding+    { run :: Prim+    }++instance Show Encoding where+  show _ = "Encoding"++instance Semigroup Encoding where+  {-# INLINE (<>) #-}+  (<>) = mappend++instance Monoid Encoding where+  {-# INLINE mempty #-}+  mempty = Encoding return+  {-# INLINE mappend #-}+  -- mappend (Encoding f) (Encoding g) = Encoding (f >=> g)+  mappend (Encoding f) (Encoding g) = Encoding m+    where+      m s@(S !_ !_ !_) = do+        !s1 <- f s+        g s1+  {-# INLINE mconcat #-}+  mconcat = foldl' mappend mempty++-- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists)+-- TODO: check with newest GHC versions+{-# RULES+"encodersSN" forall h t . encodersS (h : t) =+             h `mappend` encodersS t+"encodersS0" encodersS [] = mempty+ #-}++{-# NOINLINE encodersS #-}+encodersS :: [Encoding] -> Encoding+-- without the explicit parameter the rules won't fire+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+ +-- {-# INLINE encodeList #-}+-- encodeList :: (Foldable t, Flat a) => t a -> Encoding+-- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse+-- {-# INLINE encodeList2 #-}+-- encodeList2 :: (Foldable t, Flat a) => t a -> Encoding+-- encodeList2 l = foldr (\a acc -> eTrue <> encode a <> acc) mempty l <> eFalse+{-# INLINE encodeArrayWith #-}+-- |Encode as Array+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''+    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 #-}+{-# INLINE eUTF8 #-}+{-# INLINE eNatural #-}+{-# INLINE eFloat #-}+{-# INLINE eDouble #-}+{-# INLINE eInteger #-}+{-# INLINE eInt64 #-}+{-# INLINE eInt32 #-}+{-# INLINE eInt16 #-}+{-# INLINE eInt8 #-}+{-# INLINE eInt #-}+{-# INLINE eWord64 #-}+{-# INLINE eWord32 #-}+{-# INLINE eWord16 #-}+{-# INLINE eWord8 #-}+{-# INLINE eWord #-}+{-# INLINE eBits #-}+{-# INLINE eFiller #-}+{-# INLINE eBool #-}+{-# INLINE eTrue #-}+{-# INLINE eFalse #-}+eChar :: Char -> Encoding+eChar = Encoding . eCharF+#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)+{-# INLINE eUTF16 #-}+eUTF16 :: Text -> Encoding+eUTF16 = Encoding . eUTF16F+#endif+eUTF8 :: Text -> Encoding+eUTF8 = Encoding . eUTF8F++eBytes :: B.ByteString -> Encoding+eBytes = Encoding . eBytesF++eLazyBytes :: L.ByteString -> Encoding+eLazyBytes = Encoding . eLazyBytesF++eShortBytes :: ShortByteString -> Encoding+eShortBytes = Encoding . eShortBytesF++eNatural :: Natural -> Encoding+eNatural = Encoding . eNaturalF++eFloat :: Float -> Encoding+eFloat = Encoding . eFloatF++eDouble :: Double -> Encoding+eDouble = Encoding . eDoubleF++eInteger :: Integer -> Encoding+eInteger = Encoding . eIntegerF++eInt64 :: Int64 -> Encoding+eInt64 = Encoding . eInt64F++eInt32 :: Int32 -> Encoding+eInt32 = Encoding . eInt32F++eInt16 :: Int16 -> Encoding+eInt16 = Encoding . eInt16F++eInt8 :: Int8 -> Encoding+eInt8 = Encoding . eInt8F++eInt :: Int -> Encoding+eInt = Encoding . eIntF++eWord64 :: Word64 -> Encoding+eWord64 = Encoding . eWord64F++eWord32 :: Word32 -> Encoding+eWord32 = Encoding . eWord32F++eWord16 :: Word16 -> Encoding+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+eFiller = Encoding eFillerF++eBool :: Bool -> Encoding+eBool = Encoding . eBoolF++eTrue :: Encoding+eTrue = Encoding eTrueF++eFalse :: Encoding+eFalse = Encoding eFalseF++-- Size Primitives+-- Variable size+{-# INLINE vsize #-}+vsize :: (t -> NumBits) -> t -> NumBits -> NumBits+vsize !f !t !n = f t + n++-- Constant size+{-# INLINE csize #-}+csize :: NumBits -> t -> NumBits -> NumBits+csize !n _ !s = n + s++sChar :: Size Char+sChar = vsize S.sChar++sInt64 :: Size Int64+sInt64 = vsize S.sInt64++sInt32 :: Size Int32+sInt32 = vsize S.sInt32++sInt16 :: Size Int16+sInt16 = vsize S.sInt16++sInt8 :: Size Int8+sInt8 = csize S.sInt8++sInt :: Size Int+sInt = vsize S.sInt++sWord64 :: Size Word64+sWord64 = vsize S.sWord64++sWord32 :: Size Word32+sWord32 = vsize S.sWord32++sWord16 :: Size Word16+sWord16 = vsize S.sWord16++sWord8 :: Size Word8+sWord8 = csize S.sWord8++sWord :: Size Word+sWord = vsize S.sWord++sFloat :: Size Float+sFloat = csize S.sFloat++sDouble :: Size Double+sDouble = csize S.sDouble++sBytes :: Size B.ByteString+sBytes = vsize S.sBytes++sLazyBytes :: Size L.ByteString+sLazyBytes = vsize S.sLazyBytes++sShortBytes :: Size ShortByteString+sShortBytes = vsize S.sShortBytes++sNatural :: Size Natural+sNatural = vsize S.sNatural++sInteger :: Size Integer+sInteger = vsize S.sInteger++-- sUTF8 = vsize S.sUTF8+sUTF8Max :: Size Text+sUTF8Max = vsize S.sUTF8Max+#ifndef ghcjs_HOST_OS+sUTF16 :: Size Text+sUTF16 = vsize S.sUTF16+#endif+sFillerMax :: Size a+sFillerMax = csize S.sFillerMax++sBool :: Size Bool+sBool = csize S.sBool

@@ -0,0 +1,25 @@+-- |Encoder Types+module Flat.Encoder.Types(+  Size,+  NumBits,+  Prim,+  S(..)+) where++import           Flat.Types+import           GHC.Ptr         (Ptr (..))++-- |Calculate the size (in bits) of the encoding of a value+type Size a = a -> NumBits -> NumBits++-- |Strict encoder state+data S =+       S+         { nextPtr  :: {-# UNPACK #-} !(Ptr Word8)+         , currByte :: {-# UNPACK #-} !Word8+         , usedBits :: {-# UNPACK #-} !NumBits+         } deriving Show++-- |A basic encoder+type Prim = S -> IO S+

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

@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP       #-}++-- |Pre-value and post-value byte alignments+module Flat.Filler (+    Filler(..),+    fillerLength,+    PreAligned(..),+    preAligned,+    PostAligned(..),+    postAligned,+    postAlignedDecoder+    ) where++import           Flat.Class+import           Flat.Encoder+import           Flat.Decoder+import           Control.DeepSeq+import           Data.Typeable++-- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse)+-- Useful to align an encoded value at byte/word boundaries.+data Filler = FillerBit Filler+            | FillerEnd+  deriving (Show, Eq, Ord, Typeable, Generic, NFData)++-- |Use a special encoding for the filler+instance Flat Filler where+  encode _ = eFiller+  size = sFillerMax+  -- use generated decode++-- |A Post aligned value, a value followed by a filler+-- Useful to complete the encoding of a top-level value+data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler }+#ifdef ETA_VERSION    +  deriving (Show, Eq, Ord, Typeable, Generic, NFData)++instance Flat a => Flat (PostAligned a) where+  encode (PostAligned val fill) = trampolineEncoding (encode val) <> encode fill++#else+  deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)+#endif+--  deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)+++-- |A Pre aligned value, a value preceded by a filler+-- Useful to prealign ByteArrays, Texts and any structure that can be encoded more efficiently when byte aligned.  +data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a }+  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Flat)++-- |Length of a filler in bits+fillerLength :: Num a => Filler -> a+fillerLength FillerEnd     = 1+fillerLength (FillerBit f) = 1 + fillerLength f++-- |Post align a value+postAligned :: a -> PostAligned a+postAligned a = PostAligned a FillerEnd++-- |Pre align a value+preAligned :: a -> PreAligned a+preAligned = PreAligned FillerEnd++-- postAlignedDecoder :: Get a -> Get (PostAligned a)+-- |Decode a value assuming that is PostAligned+postAlignedDecoder :: Get b -> Get b+postAlignedDecoder dec = do+  v <- dec+  _::Filler <- decode+  -- return (postAligned v)+  return v

@@ -0,0 +1,15 @@++-- |Flat Instances for common data types from the packages on which `flat` has a dependency.+module Flat.Instances+  ( module X+  )+where++import           Flat.Instances.Array           ( )+import           Flat.Instances.Base            ( )+import           Flat.Instances.ByteString      ( )+import           Flat.Instances.Containers     as X+import           Flat.Instances.DList           ( )+import           Flat.Instances.Mono           as X+import           Flat.Instances.Text           as X+import           Flat.Instances.Unordered       ( )

@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Flat instances for the `array` package+module Flat.Instances.Array+  ()+where++import qualified Data.Array                    as A+import qualified Data.Array.Unboxed            as U+import           Data.Array.IArray+import           Flat.Class+import           Flat.Decoder+import           Flat.Encoder+import           Flat.Instances.Base            ( )+-- import Flat.Instances.Util+import           Flat.Instances.Mono++-- $setup+-- >>> :set -XFlexibleContexts+-- >>> import           Flat.Instances.Test+-- >>> import           Flat.Instances.Mono+-- >>> import           qualified Data.Array as A+-- >>> import           qualified Data.Array.Unboxed as U+-- >>> import           Data.Array.IArray+-- >>> import           Data.Word++{-|+Array is encoded as (lowBound,highBound,AsArray (elems array)):++>>> let arr = A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] in tst (bounds arr,AsArray(elems arr)) == tst arr +True++As it's easy to see:++>>> tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)]+(True,80,[1,4,2,5,4,11,22,33,44,0])++>>> tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")]+(True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0])++Arrays and Unboxed Arrays are encoded in the same way:++>>> let bounds = ((1::Word,4::Word),(2,5));elems=[11::Word,22,33,44] in tst (U.listArray bounds elems :: U.UArray (Word,Word) Word) == tst (A.listArray bounds elems)+True+-}+instance (Flat i, Flat e, Ix i) => Flat (A.Array i e) where+  size   = sizeIArray++  encode = encodeIArray++  decode = decodeIArray++instance (Flat i, Flat e, Ix i, IArray U.UArray e) => Flat (U.UArray i e) where+  size   = sizeIArray++  encode = encodeIArray++  decode = decodeIArray++sizeIArray :: (IArray a e, Ix i, Flat e, Flat i) => a i e -> NumBits -> NumBits+sizeIArray arr = (sizeSequence . elems $ arr) . size (bounds arr)++encodeIArray :: (Ix i, IArray a e, Flat i, Flat e) => a i e -> Encoding+encodeIArray arr = encode (bounds arr) <> encodeSequence (elems arr)++decodeIArray :: (Ix i, IArray a e, Flat i, Flat e) => Get (a i e)+decodeIArray = listArray <$> decode <*> decodeSequence++{-# INLINE sizeIArray #-}+{-# INLINE encodeIArray #-}+{-# INLINE decodeIArray #-}