diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/flat.cabal b/flat.cabal --- a/flat.cabal +++ b/flat.cabal @@ -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 . -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 diff --git a/src/Data/ByteString/Convert.hs b/src/Data/ByteString/Convert.hs --- a/src/Data/ByteString/Convert.hs +++ b/src/Data/ByteString/Convert.hs @@ -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 diff --git a/src/Data/Flat.hs b/src/Data/Flat.hs deleted file mode 100644 --- a/src/Data/Flat.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Data.Flat ( - -- |Check the . - 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 diff --git a/src/Data/Flat/Bits.hs b/src/Data/Flat/Bits.hs deleted file mode 100644 --- a/src/Data/Flat/Bits.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Flat/Class.hs b/src/Data/Flat/Class.hs deleted file mode 100644 --- a/src/Data/Flat/Class.hs +++ /dev/null @@ -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.." diff --git a/src/Data/Flat/Decoder.hs b/src/Data/Flat/Decoder.hs deleted file mode 100644 --- a/src/Data/Flat/Decoder.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Decoder/Prim.hs b/src/Data/Flat/Decoder/Prim.hs deleted file mode 100644 --- a/src/Data/Flat/Decoder/Prim.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Decoder/Strict.hs b/src/Data/Flat/Decoder/Strict.hs deleted file mode 100644 --- a/src/Data/Flat/Decoder/Strict.hs +++ /dev/null @@ -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_ diff --git a/src/Data/Flat/Decoder/Types.hs b/src/Data/Flat/Decoder/Types.hs deleted file mode 100644 --- a/src/Data/Flat/Decoder/Types.hs +++ /dev/null @@ -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 - - diff --git a/src/Data/Flat/Encoder.hs b/src/Data/Flat/Encoder.hs deleted file mode 100644 --- a/src/Data/Flat/Encoder.hs +++ /dev/null @@ -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((<>)) diff --git a/src/Data/Flat/Encoder/Prim.hs b/src/Data/Flat/Encoder/Prim.hs deleted file mode 100644 --- a/src/Data/Flat/Encoder/Prim.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Encoder/Size.hs b/src/Data/Flat/Encoder/Size.hs deleted file mode 100644 --- a/src/Data/Flat/Encoder/Size.hs +++ /dev/null @@ -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) diff --git a/src/Data/Flat/Encoder/Strict.hs b/src/Data/Flat/Encoder/Strict.hs deleted file mode 100644 --- a/src/Data/Flat/Encoder/Strict.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Encoder/Types.hs b/src/Data/Flat/Encoder/Types.hs deleted file mode 100644 --- a/src/Data/Flat/Encoder/Types.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Flat/Endian.hs b/src/Data/Flat/Endian.hs deleted file mode 100644 --- a/src/Data/Flat/Endian.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Filler.hs b/src/Data/Flat/Filler.hs deleted file mode 100644 --- a/src/Data/Flat/Filler.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Instances.hs b/src/Data/Flat/Instances.hs deleted file mode 100644 --- a/src/Data/Flat/Instances.hs +++ /dev/null @@ -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 diff --git a/src/Data/Flat/Memory.hs b/src/Data/Flat/Memory.hs deleted file mode 100644 --- a/src/Data/Flat/Memory.hs +++ /dev/null @@ -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 #-} diff --git a/src/Data/Flat/Run.hs b/src/Data/Flat/Run.hs deleted file mode 100644 --- a/src/Data/Flat/Run.hs +++ /dev/null @@ -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) - diff --git a/src/Data/Flat/Types.hs b/src/Data/Flat/Types.hs deleted file mode 100644 --- a/src/Data/Flat/Types.hs +++ /dev/null @@ -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) diff --git a/src/Data/FloatCast.hs b/src/Data/FloatCast.hs --- a/src/Data/FloatCast.hs +++ b/src/Data/FloatCast.hs @@ -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 --- . --- --- Implements casting via a 1-element STUArray, as described in --- . +{-# LANGUAGE Trustworthy ,NoMonomorphismRestriction#-} + +{- | Primitives to convert between Float\/Double and Word32\/Word64. + +Code copied from . + +Based on: .. + +Implements casting via a 1-element STUArray, as described in . +-} 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 #-} diff --git a/src/Data/ZigZag.hs b/src/Data/ZigZag.hs --- a/src/Data/ZigZag.hs +++ b/src/Data/ZigZag.hs @@ -1,66 +1,104 @@ -module Data.ZigZag(zzEncode,zzEncodeInteger,zzDecode8,zzDecode16,zzDecode32,zzDecode64,zzDecodeInteger,zzDecode) where +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | 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))) diff --git a/src/Flat.hs b/src/Flat.hs new file mode 100644 --- /dev/null +++ b/src/Flat.hs @@ -0,0 +1,19 @@ +{-| +Haskell implementation of , 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 ( ) diff --git a/src/Flat/Bits.hs b/src/Flat/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Bits.hs @@ -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 + diff --git a/src/Flat/Class.hs b/src/Flat/Class.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Class.hs @@ -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.." diff --git a/src/Flat/Decoder.hs b/src/Flat/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Decoder.hs @@ -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 diff --git a/src/Flat/Decoder/Prim.hs b/src/Flat/Decoder/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Decoder/Prim.hs @@ -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 diff --git a/src/Flat/Decoder/Strict.hs b/src/Flat/Decoder/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Decoder/Strict.hs @@ -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_ diff --git a/src/Flat/Decoder/Types.hs b/src/Flat/Decoder/Types.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Decoder/Types.hs @@ -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 diff --git a/src/Flat/Encoder.hs b/src/Flat/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Encoder.hs @@ -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 diff --git a/src/Flat/Encoder/Prim.hs b/src/Flat/Encoder/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Encoder/Prim.hs @@ -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 diff --git a/src/Flat/Encoder/Size.hs b/src/Flat/Encoder/Size.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Encoder/Size.hs @@ -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) diff --git a/src/Flat/Encoder/Strict.hs b/src/Flat/Encoder/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Encoder/Strict.hs @@ -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 diff --git a/src/Flat/Encoder/Types.hs b/src/Flat/Encoder/Types.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Encoder/Types.hs @@ -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 + diff --git a/src/Flat/Endian.hs b/src/Flat/Endian.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Endian.hs @@ -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 diff --git a/src/Flat/Filler.hs b/src/Flat/Filler.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Filler.hs @@ -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 diff --git a/src/Flat/Instances.hs b/src/Flat/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances.hs @@ -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 ( ) diff --git a/src/Flat/Instances/Array.hs b/src/Flat/Instances/Array.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Array.hs @@ -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 #-} diff --git a/src/Flat/Instances/Base.hs b/src/Flat/Instances/Base.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Base.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances ,StandaloneDeriving #-} +-- | Flat instances for the base library +module Flat.Instances.Base() where + +import Data.Bool +import Data.Char +import Data.Fixed +import Flat.Instances.Util +import Data.Complex(Complex(..)) +import Data.Ratio +import Prelude hiding ( mempty ) +import Control.Monad ( liftM2 ) +-- #if MIN_VERSION_base(4,9,0) +import qualified Data.List.NonEmpty as B +-- #endif + +#if !MIN_VERSION_base(4,9,0) +deriving instance Generic (Complex a) +#endif + +-- $setup +-- >>> :set -XNegativeLiterals +-- >>> import Flat.Instances.Test +-- >>> import Data.Fixed +-- >>> import Data.Int +-- >>> import Data.Complex(Complex(..)) +-- >>> import Numeric.Natural +-- >>> import Data.Word +-- >>> import Data.Ratio +-- >>> import qualified Data.List.NonEmpty as B +-- >>> let test = tstBits + +{- | +`()`, as all data types with a single constructor, has a zero-length encoding. + +>>> test () +(True,0,"") +-} +instance Flat () where + encode _ = mempty + + size _ = id + + decode = pure () + +{-| +One bit is plenty for a Bool. + +>>> test False +(True,1,"0") + +>>> test True +(True,1,"1") +-} +instance Flat Bool where + encode = eBool + + size = sBool + + decode = dBool + +{-| +Char's are mapped to Word32 and then encoded. + +For ascii characters, the encoding is standard ascii. + +>>> test 'a' +(True,8,"01100001") + +For unicode characters, the encoding is non standard. + +>>> test 'È' +(True,16,"11001000 00000001") + +>>> test '不' +(True,24,"10001101 10011100 00000001") + +#ifndef ETA +>>> test "\x1F600" +(True,26,"11000000 01110110 00000011 10") +#endif +-} +instance Flat Char where + size = sChar + + encode = eChar + + decode = dChar + +{- | +>>> test (Nothing::Maybe Bool) +(True,1,"0") + +>>> test (Just False::Maybe Bool) +(True,2,"10") +-} +instance Flat a => Flat (Maybe a) + +{-| +>>> test (Left False::Either Bool ()) +(True,2,"00") + +>>> test (Right ()::Either Bool ()) +(True,1,"1") +-} +instance ( Flat a, Flat b ) => Flat (Either a b) + +{-| +>>> test (MkFixed 123 :: Fixed E0) +(True,16,"11110110 00000001") + +>>> test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) +True +-} +instance Flat (Fixed a) where + encode (MkFixed n) = encode n + + size (MkFixed n) = size n + + decode = MkFixed <$> decode + +{- | +Word8 always take 8 bits. + +>>> test (0::Word8) +(True,8,"00000000") + +>>> test (255::Word8) +(True,8,"11111111") +-} +instance Flat Word8 where + encode = eWord8 + + decode = dWord8 + + size = sWord8 + +{- | +Natural, Word, Word16, Word32 and Word64 are encoded as a non empty list of 7 bits chunks (least significant chunk first and most significant bit first in every chunk). + +Words are always encoded in a whole number of bytes, as every chunk is 8 bits long (1 bit for the List constructor, plus 7 bits for the value). + +The actual definition is: + +@ +Word64 ≡ Word64 Word + +Word32 ≡ Word32 Word + +Word16 ≡ Word16 Word + +Word ≡ Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7))) + +LeastSignificantFirst a ≡ LeastSignificantFirst a + +NonEmptyList a ≡ Elem a + | Cons a (NonEmptyList a) + +MostSignificantFirst a ≡ MostSignificantFirst a + +Word7 ≡ V0 + | V1 + | V2 + ... + | V127 +@ + +Values between as 0 and 127 fit in a single byte. + +127 (0b1111111) is represented as Elem V127 and encoded as: Elem=0 127=1111111 + +>>> test (127::Word) +(True,8,"01111111") + +254 (0b11111110) is represented as Cons V126 (Elem V1) (254=128+126) and encoded as: Cons=1 V126=1111110 (Elem=0 V1=0000001): + +>>> test (254::Word) +(True,16,"11111110 00000001") + +Another example, 32768 (Ob1000000000000000 = 0000010 0000000 0000000): + +>>> test (32768::Word32) +(True,24,"10000000 10000000 00000010") + +As this is a variable length encoding, values are encoded in the same way, whatever their type: + +>>> all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] +True +-} +instance Flat Word where + size = sWord + + encode = eWord + + decode = dWord + +{- | +Naturals are encoded just as the fixed size Words. + +>>> test (0::Natural) +(True,8,"00000000") + +>>> test (2^120::Natural) +(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010") +-} +instance Flat Natural where + size = sNatural + + encode = eNatural + + decode = dNatural + + +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 + + +{- | +Integer, Int, Int16, Int32 and Int64 are defined as the encoded version of the equivalent unsigned Word: + +@ +Int ≡ Int (ZigZag Word) + +Int64 ≡ Int64 (ZigZag Word64) + +Int32 ≡ Int32 (ZigZag Word32) + +Int16 ≡ Int16 (ZigZag Word16) + +Int8 ≡ Int8 (ZigZag Word8) + +ZigZag a ≡ ZigZag a +@ + +ZigZag encoding alternates between positive and negative numbers, so that numbers whose absolute value is small can be encoded efficiently: + +>>> test (0::Int) +(True,8,"00000000") + +>>> test (-1::Int) +(True,8,"00000001") + +>>> test (1::Int) +(True,8,"00000010") + +>>> test (-2::Int) +(True,8,"00000011") + +>>> test (2::Int) +(True,8,"00000100") +-} +instance Flat Int where + size = sInt + + encode = eInt + + decode = dInt + +{- | +Integers are encoded just as the fixed size Ints. + +>>> test (0::Integer) +(True,8,"00000000") + +>>> test (-1::Integer) +(True,8,"00000001") + +>>> test (1::Integer) +(True,8,"00000010") + +>>> test (-(2^4)::Integer) +(True,8,"00011111") + +>>> test (2^4::Integer) +(True,8,"00100000") + +>>> test (-(2^120)::Integer) +(True,144,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011") + +>>> test (2^120::Integer) +(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100") +-} +instance Flat Integer where + size = sInteger + + encode = eInteger + + decode = dInteger + +{-| +>>> test (0::Int8) +(True,8,"00000000") + +>>> test (127::Int8) +(True,8,"11111110") + +>>> test (-128::Int8) +(True,8,"11111111") +-} +instance Flat Int8 where + encode = eInt8 + + decode = dInt8 + + size = sInt8 + +{- | +>>> test (0::Int16) +(True,8,"00000000") + +>>> test (1::Int16) +(True,8,"00000010") + +>>> test (-1::Int16) +(True,8,"00000001") + +>>> test (minBound::Int16) +(True,24,"11111111 11111111 00000011") + +equivalent to 0b1111111111111111 + +>>> test (maxBound::Int16) +(True,24,"11111110 11111111 00000011") + +equivalent to 0b1111111111111110 +-} +instance Flat Int16 where + size = sInt16 + + encode = eInt16 + + decode = dInt16 + +{- | +>>> test (0::Int32) +(True,8,"00000000") + +>>> test (minBound::Int32) +(True,40,"11111111 11111111 11111111 11111111 00001111") + +>>> test (maxBound::Int32) +(True,40,"11111110 11111111 11111111 11111111 00001111") +-} +instance Flat Int32 where + size = sInt32 + + encode = eInt32 + + decode = dInt32 + +{- | +>>> test (0::Int64) +(True,8,"00000000") + +>>> test (minBound::Int64) +(True,80,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001") + +>>> test (maxBound::Int64) +(True,80,"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001") +-} +instance Flat Int64 where + size = sInt64 + + encode = eInt64 + + decode = dInt64 + + +{- | +Floats are encoded as standard IEEE binary32 values: + +@ +IEEE_754_binary32 ≡ IEEE_754_binary32 {sign :: Sign, + exponent :: MostSignificantFirst Bits8, + fraction :: MostSignificantFirst Bits23} +@ + +>>> test (0::Float) +(True,32,"00000000 00000000 00000000 00000000") + +>>> test (1.4012984643E-45::Float) +(True,32,"00000000 00000000 00000000 00000001") + +>>> test (1.1754942107E-38::Float) +(True,32,"00000000 01111111 11111111 11111111") +-} +instance Flat Float where + size = sFloat + + encode = eFloat + + decode = dFloat + +{- | +Doubles are encoded as standard IEEE binary64 values: + +@ +IEEE_754_binary64 ≡ IEEE_754_binary64 {sign :: Sign, + exponent :: MostSignificantFirst Bits11, + fraction :: MostSignificantFirst Bits52} +@ +-} +instance Flat Double where + size = sDouble + + encode = eDouble + + decode = dDouble + +{-| +>>> test (4 :+ 2 :: Complex Word8) +(True,16,"00000100 00000010") +-} +instance Flat a => Flat (Complex a) + +{-| +Ratios are encoded as tuples of (numerator,denominator) + +>>> test (3%4::Ratio Word8) +(True,16,"00000011 00000100") +-} +instance ( Integral a, Flat a ) => Flat (Ratio a) where + size a = size ( numerator a, denominator a ) + + encode a = encode ( numerator a, denominator a ) + + -- decode = uncurry (%) <$> decode + decode = liftM2 (%) decode decode + +{-| +>>> test ([]::[Bool]) +(True,1,"0") + +>>> test [False,False] +(True,5,"10100") +-} +instance {-# OVERLAPPABLE #-}Flat a => Flat [ a ] + +-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901) +-- where +--size [] n = n+1 +--size (h:t) n = trampoline size t (trampoline size h (n+1)) +-- size = sizeListWith size -- foldl' (\n e -> ) n +-- encode = error "BAD" +-- encode = trampoline . encodeListWith encode +-- decode = decodeListWith decode +-- sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l +-- #ifdef ETA_VERSION +-- import Data.Function(trampoline) +-- import GHC.IO(trampolineIO) +-- #else +-- trampoline = id +-- trampolineIO = id +-- #endif + +{- | +For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char]. + +>>> test "" +(True,1,"0") + +>>> test "aaa" +(True,28,"10110000 11011000 01101100 0010") +-} +instance {-# OVERLAPPING #-}Flat [ Char ] + + +-- #if MIN_VERSION_base(4,9,0) +{-| +>>> test (B.fromList [True]) +(True,2,"10") + +>>> test (B.fromList [False,False]) +(True,4,"0100") +-} +instance {-# OVERLAPPABLE #-}Flat a => Flat (B.NonEmpty a) +-- #endif + +{- | +Tuples are supported up to 7 elements. + +>>> test (False,()) +(True,1,"0") + +>>> test ((),()) +(True,0,"") + +"7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal) + +>>> test (False,True,True,True,False,True,True) +(True,7,"0111011") + +tst (1::Int,"2","3","4","5","6","7","8") +...error +-} + +-- Not sure if these should be OVERLAPPABLE +instance {-# OVERLAPPABLE #-}( Flat a, Flat b ) => Flat ( a, b ) + +instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c ) => Flat ( a, b, c ) + +instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c, Flat d ) + => Flat ( a, b, c, d ) + +instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c, Flat d, Flat e ) + => Flat ( a, b, c, d, e ) + +instance {-# OVERLAPPABLE #-}( Flat a, Flat b, Flat c, Flat d, Flat e, Flat f ) + => Flat ( a, b, c, d, e, f ) + +instance {-# OVERLAPPABLE #-}( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + ) => Flat ( a, b, c, d, e, f, g ) + + diff --git a/src/Flat/Instances/ByteString.hs b/src/Flat/Instances/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/ByteString.hs @@ -0,0 +1,87 @@ +-- | Flat instances for the bytestring library +{-# LANGUAGE NoMonomorphismRestriction #-} +module Flat.Instances.ByteString + () +where + +import Flat.Class +import Flat.Decoder +import Flat.Encoder +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as SBS + +-- $setup +-- >>> import Flat.Instances.Test +-- >>> import Flat.Instances.Base +-- >>> import qualified Data.ByteString as B +-- >>> import qualified Data.ByteString.Lazy as L +-- >>> import qualified Data.ByteString.Short as SBS + +{-| +ByteString, ByteString.Lazy and ByteString.Short are all encoded as Prealigned Arrays: + +@ +PreAligned a ≡ PreAligned {preFiller :: Filler, preValue :: a} + +Filler ≡ FillerBit Filler + | FillerEnd + +Array v = A0 + | A1 v (Array v) + | A2 v v (Array v) + ... + | A255 ... (Array v) +@ + +That's to say as a byte-aligned sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. + +>>> tst (B.pack [11,22,33]) +(True,48,[1,3,11,22,33,0]) + +where: + +1= PreAlignment (takes a byte if we are already on a byte boundary) + +3= Number of bytes in ByteString + +11,22,33= Bytes + +0= End of Array + +>>> tst (B.pack []) +(True,16,[1,0]) + +Pre-alignment ensures that a ByteString always starts at a byte boundary: + +>>> tst ((False,True,False,B.pack [11,22,33])) +(True,51,[65,3,11,22,33,0]) + +All ByteStrings are encoded in the same way: + +>>> all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])] +True +-} +instance Flat B.ByteString where + encode = eBytes + size = sBytes + decode = dByteString + +{- | +>>> tst ((False,True,False,L.pack [11,22,33])) +(True,51,[65,3,11,22,33,0]) +-} +instance Flat L.ByteString where + encode = eLazyBytes + size = sLazyBytes + decode = dLazyByteString + +{- | +>>> tst ((False,True,False,SBS.pack [11,22,33])) +(True,51,[65,3,11,22,33,0]) +-} +instance Flat SBS.ShortByteString where + encode = eShortBytes + size = sShortBytes + decode = dShortByteString + diff --git a/src/Flat/Instances/Containers.hs b/src/Flat/Instances/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Containers.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving ,DeriveGeneric #-} + +{-# LANGUAGE CPP #-} +-- |Instances for the containers library +module Flat.Instances.Containers (sizeMap + , encodeMap + , decodeMap +) where + +import Flat.Instances.Util +import Data.Map +import Flat.Instances.Base() +import Flat.Instances.Mono +import Data.Tree +import Data.Set +import Data.IntMap +import Data.Sequence + +-- $setup +-- >>> import Flat.Instances.Test +-- >>> import Data.Set +-- >>> import Data.Sequence +-- >>> import Data.IntMap +-- >>> import Data.Map +-- >>> import Data.Tree + +{-| +Maps are defined as a list of (Key,Value) tuples: + +@ +Map = List (Key,Value) + +List a = Nil | Cons a (List a) +@ +-} + +{-| +>>> tst (Data.IntMap.empty :: IntMap ()) +(True,1,[0]) + +>>> asList Data.IntMap.fromList [(1,"a"),(2,"b")] +True +-} +instance Flat a => Flat (IntMap a) where + size = sizeMap + encode = encodeMap + decode = decodeMap + +{-| +Maps are encoded as lists: + +>>> tst (Data.Map.empty :: Map () ()) +(True,1,[0]) + +>>> asList Data.Map.fromList [("a","aa"),("b","bb")] +True + +Key/Values are encoded in order: + +>>> let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l) +True + +IntMap and Map are encoded in the same way: + +>>> let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l) +True +-} +instance (Flat a, Flat b, Ord a) => Flat (Map a b) where + size = sizeMap + encode = encodeMap + decode = decodeMap + +{-| +Data.Sequence.Seq is encoded as a list + +>>> asList Data.Sequence.fromList [3::Word8,4,7] +True +-} +instance Flat a => Flat (Seq a) where + size = sizeList -- . toList + encode = encodeList -- . Data.Sequence.toList + decode = Data.Sequence.fromList <$> decodeList + +{-| +Data.Set is encoded as a list + +>>> asList Data.Set.fromList [3::Word8,4,7] +True +-} +instance (Flat a,Ord a) => Flat (Set a) where + size = sizeSet + encode = encodeSet + decode = decodeSet + +{-| +>>> tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []]) +(True,39,[1,129,64,200,32]) +-} +#if ! MIN_VERSION_containers(0,5,8) +deriving instance Generic (Tree a) +#endif + +instance (Flat a) => Flat (Tree a) diff --git a/src/Flat/Instances/DList.hs b/src/Flat/Instances/DList.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/DList.hs @@ -0,0 +1,27 @@ +module Flat.Instances.DList + () +where + +import Flat.Class +import Flat.Instances.Mono +import Data.DList + +-- $setup +-- >>> import Flat.Instances.Test +-- >>> import Flat.Instances.Base() +-- >>> import Flat.Run +-- >>> import Data.DList +-- >>> let test = tstBits + +{-| +>>> test (Data.DList.fromList [7::Word,7]) +(True,19,"10000011 11000001 110") + +>>> let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l +True +-} + +instance Flat a => Flat (DList a) where + size = sizeList . toList + encode = encodeList . toList + decode = fromList <$> decodeList diff --git a/src/Flat/Instances/Mono.hs b/src/Flat/Instances/Mono.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Mono.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances,UndecidableInstances ,NoMonomorphismRestriction #-} +module Flat.Instances.Mono + ( sizeSequence + , encodeSequence + , decodeSequence + , sizeList + , encodeList + , decodeList + , sizeSet + , encodeSet + , decodeSet + , sizeMap + , encodeMap + , decodeMap + , AsArray(..) + , AsList(..) + , AsSet(..) + , AsMap(..) + ) +where + +import Data.MonoTraversable ( Element + , ofoldl' + , otoList + --, olength + , MonoFoldable + ) +import Data.Sequences ( IsSequence ) +import qualified Data.Sequences as S +import Data.Containers +import Flat.Instances.Util +import qualified Data.Foldable as F + +-- $setup +-- >>> import Flat.Instances.Base() +-- >>> import Flat.Instances.Test +-- >>> import Data.Word +-- >>> import qualified Data.Set +-- >>> import qualified Data.Map + +{-| +Sequences are defined as Arrays: + +Array v = A0 + | A1 v (Array v) + | A2 v v (Array v) + ... + | A255 ... (Array v) + +In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. + +Lists are defined as: + +List a ≡ Nil + | Cons a (List a) + +The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays + +>>> tst $ AsArray ([]::[()]) +(True,8,[0]) + +>>> tst $ AsArray [11::Word8,22,33] +(True,40,[3,11,22,33,0]) + +>>> tst $ AsList ([]::[()]) +(True,1,[0]) + +>>> tst (AsList [11::Word8,22,33]) +(True,28,[133,197,164,32]) + +>>> tst (AsSet (Data.Set.fromList [11::Word8,22,33])) +(True,28,[133,197,164,32]) + +-} +newtype AsArray a = + AsArray + { unArray :: a + } deriving (Show,Eq,Ord) + +instance (IsSequence r, Flat (Element r)) => Flat (AsArray r) where + size (AsArray a) = sizeSequence a + encode (AsArray a) = encodeSequence a + decode = AsArray <$> decodeSequence + +-- |Calculate size of an instance of IsSequence as the sum: +-- * of the size of all the elements +-- * plus the size of the array constructors (1 byte every 255 elements plus one final byte) +sizeSequence + :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits +sizeSequence s acc = + let (sz, len) = + ofoldl' (\(acc, l) e -> (size e acc, l + 1)) (acc, 0 :: NumBits) s + in sz + arrayBits len +{-# INLINE sizeSequence #-} + +-- TODO: check which one is faster +-- sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s) + +-- |Encode an instance of IsSequence, as an array +encodeSequence :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding +encodeSequence = encodeArray . otoList +{-# INLINE encodeSequence #-} + +-- |Decode an instance of IsSequence, as an array +decodeSequence :: (Flat (Element b), IsSequence b) => Get b +decodeSequence = S.fromList <$> decodeArrayWith decode +{-# INLINE decodeSequence #-} + +newtype AsList a = + AsList + { unList :: a + } deriving (Show,Eq,Ord) + +instance (IsSequence l, Flat (Element l)) => Flat (AsList l) where + -- size = sizeList . S.unpack . unList + -- encode = encodeList . S.unpack . unList + -- decode = AsList . S.fromList <$> decodeListotoList + + size = sizeList . unList + encode = encodeList . unList + decode = AsList <$> decodeList + +{-# INLINE sizeList #-} +sizeList + :: (MonoFoldable mono, Flat (Element mono)) => mono -> NumBits -> NumBits +sizeList l sz = ofoldl' (\s e -> size e (s + 1)) (sz + 1) l + +{-# INLINE encodeList #-} +encodeList :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding +encodeList = encodeListWith encode . otoList + +{-# INLINE decodeList #-} +decodeList :: (IsSequence b, Flat (Element b)) => Get b +decodeList = S.fromList <$> decodeListWith decode + +newtype AsSet a = + AsSet + { unSet :: a + } deriving (Show,Eq,Ord) + +instance (IsSet set, Flat (Element set)) => Flat (AsSet set) where + size = sizeSet . unSet + encode = encodeSet . unSet + decode = AsSet <$> decodeSet + +sizeSet :: (IsSet set, Flat (Element set)) => Size set +sizeSet l acc = ofoldl' (\acc e -> size e (acc + 1)) (acc + 1) $ l +{-# INLINE sizeSet #-} + +encodeSet :: (IsSet set, Flat (Element set)) => set -> Encoding +encodeSet = encodeList . setToList +{-# INLINE encodeSet #-} + +decodeSet :: (IsSet set, Flat (Element set)) => Get set +decodeSet = setFromList <$> decodeList +{-# INLINE decodeSet #-} + +{-| +Maps are saved as lists of (key,value) tuples. + +>>> tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) +(True,1,[0]) + +>>> tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) +(True,18,[129,132,128]) +-} +newtype AsMap a = + AsMap + { unMap :: a + } deriving (Show,Eq,Ord) + +instance (IsMap map, Flat (ContainerKey map), Flat (MapValue map)) => Flat (AsMap map) where + size = sizeMap . unMap + encode = encodeMap . unMap + decode = AsMap <$> decodeMap + +{-# INLINE sizeMap #-} +sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r +sizeMap m acc = + F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1) + . mapToList + $ m +-- sizeMap l sz = ofoldl' (\s (k, v) -> size k (size v (s + 1))) (sz + 1) l + +{-# INLINE encodeMap #-} +-- |Encode an instance of IsMap, as a list of (Key,Value) tuples +encodeMap + :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) + => map + -> Encoding +encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList + +{-# INLINE decodeMap #-} +-- |Decode an instance of IsMap, as a list of (Key,Value) tuples +decodeMap + :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map +decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode) + diff --git a/src/Flat/Instances/Test.hs b/src/Flat/Instances/Test.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Test.hs @@ -0,0 +1,44 @@ +-- | doctest utilities +module Flat.Instances.Test + ( tst + , tstBits + , asList + , flatBits + , allBits + , prettyShow + , module Data.Word + ) +where + +import Flat.Class ( Flat(..) ) +import Flat.Run ( flat + , unflat + ) +import Flat.Bits ( bits + , asBytes + , paddedBits + ) +import Flat.Types ( NumBits ) +import Data.Word +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +-- |Returns: result of flat/unflat test, encoding size in bits, byte encoding +tst :: (Eq a, Flat a) => a -> (Bool, NumBits, [Word8]) +tst v = (unflat (flat v) == Right v, size v 0, showBytes v) + +-- |Returns: result of flat/unflat test, encoding size in bits, bits encoding +tstBits :: (Eq a, Flat a) => a -> (Bool, NumBits, String) +tstBits v = (unflat (flat v) == Right v, Flat.Class.size v 0, flatBits v) + +-- |Test that container is serialised as a List +asList :: (Eq a1, Eq a2, Flat a1, Flat a2) => (a2 -> a1) -> a2 -> Bool +asList f l = tst (f l) == tst l + +flatBits :: Flat a => a -> String +flatBits = prettyShow . bits + +allBits :: Flat a => a -> String +allBits = prettyShow . paddedBits + +showBytes :: Flat a => a -> [Word8] +showBytes = asBytes . bits diff --git a/src/Flat/Instances/Text.hs b/src/Flat/Instances/Text.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Text.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} + +-- | Flat instances for the text library +module Flat.Instances.Text( + UTF8Text(..) +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) && ! defined (ETA) + ,UTF16Text(..) +#endif +) where + +import Flat.Instances.Util +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- $setup +-- >>> import Flat.Instances.Base() +-- >>> import Flat.Instances.Test +-- >>> import qualified Data.Text as T +-- >>> import qualified Data.Text.Lazy as TL +-- >>> import Data.Word + +{-| +Text (and Data.Text.Lazy) is encoded as a byte aligned array of bytes corresponding to its UTF8 encoding. + +>>> tst $ T.pack "" +(True,16,[1,0]) + +>>> tst $ T.pack "aaa" +(True,120,[1,3,97,97,97,0]) + +>>> tst $ T.pack "¢¢¢" +(True,120,[1,6,194,162,194,162,194,162,0]) + +>>> tst $ T.pack "日日日" +(True,120,[1,9,230,151,165,230,151,165,230,151,165,0]) + +#ifndef ETA +>>> tst $ T.pack "𐍈𐍈𐍈" +(True,120,[1,12,240,144,141,136,240,144,141,136,240,144,141,136,0]) +#endif + +Strict and Lazy Text has the same encoding: + +>>> tst (T.pack "abc") == tst (TL.pack "abc") +True +-} +instance Flat T.Text where + size = sUTF8Max + encode = eUTF8 + decode = dUTF8 + +instance Flat TL.Text where + size = sUTF8Max . TL.toStrict + encode = eUTF8 . TL.toStrict + decode = TL.fromStrict <$> dUTF8 + +{-| +The desired text encoding can be explicitly specified using the wrappers UTF8Text and UTF16Text. + +The default encoding is UTF8: + +>>> tst (UTF8Text $ T.pack "日日日") == tst (T.pack "日日日") +True +-} +-- |A wrapper to encode/decode Text as UTF8 (slower but more compact) +newtype UTF8Text = UTF8Text {unUTF8::T.Text} deriving (Eq,Ord,Show) + +instance Flat UTF8Text where + size (UTF8Text t) = sUTF8Max t + encode (UTF8Text t) = eUTF8 t + decode = UTF8Text <$> dUTF8 + +#if ! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) && ! defined (ETA) +{-| +>>> tst (UTF16Text $ T.pack "aaa") +(True,72,[1,6,97,0,97,0,97,0,0]) + +>>> tst (UTF16Text $ T.pack "𐍈𐍈𐍈") +(True,120,[1,12,0,216,72,223,0,216,72,223,0,216,72,223,0]) +-} + +-- |A wrapper to encode/decode Text as UTF16 (faster but bigger) +newtype UTF16Text = UTF16Text {unUTF16::T.Text} deriving (Eq,Ord,Show) + +instance Flat UTF16Text where + size (UTF16Text t) = sUTF16 t + encode (UTF16Text t) = eUTF16 t + decode = UTF16Text <$> dUTF16 + +#endif + diff --git a/src/Flat/Instances/Unordered.hs b/src/Flat/Instances/Unordered.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Unordered.hs @@ -0,0 +1,47 @@ +module Flat.Instances.Unordered + () +where + +import Flat.Instances.Mono +import Flat.Instances.Util +import Data.HashSet +import Data.Hashable +import qualified Data.HashMap.Strict as MS + +-- $setup +-- >>> import Flat.Instances.Base() +-- >>> import Flat.Instances.Test +-- >>> import Data.Word +-- >>> import qualified Data.HashMap.Strict +-- >>> import qualified Data.HashMap.Lazy +-- >>> import qualified Data.HashSet +-- >>> let test = tstBits + +{-| +>>> test (Data.HashSet.fromList [1..3::Word]) +(True,28,"10000000 11000000 10100000 0110") +-} + +instance (Hashable a, Eq a,Flat a) => Flat (HashSet a) where + size = sizeSet + encode = encodeSet + decode = decodeSet + +{-| +>>> test (Data.HashMap.Strict.fromList [(1,11),(2,22)]) +(True,35,"10000001 00001011 01000001 00001011 000") + +>>> test (Data.HashMap.Lazy.fromList [(1,11),(2,22)]) +(True,35,"10000001 00001011 01000001 00001011 000") + +-} +instance (Hashable k,Eq k,Flat k,Flat v) => Flat (MS.HashMap k v) where + size = sizeMap + encode = encodeMap + decode = decodeMap + +-- instance (Hashable k,Eq k,Flat k,Flat v) => Flat (ML.HashMap k v) where +-- size = sizeMap +-- encode = encodeMap +-- decode = decodeMap + diff --git a/src/Flat/Instances/Util.hs b/src/Flat/Instances/Util.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Util.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TupleSections ,ViewPatterns ,NoMonomorphismRestriction ,BangPatterns ,ScopedTypeVariables #-} + +module Flat.Instances.Util + ( module F + -- sizeList + -- , decodeList + -- , encodeList + , encodeArray + ) +where + +import Flat.Class as F +import Flat.Decoder as F +import Flat.Encoder as F +import Flat.Types as F +-- import Data.List +-- import GHC.Exts(IsList) + +-- -- $setup +-- >>> import Flat.Instances.Base() +-- >>> import Flat.Instances.Test +-- >>> let test = tstBits + +-- {-| +-- >>> test [] +-- (True,1,"0") + +-- >>> test [1::Word8] +-- (True,10,"10000000 10") +-- -} + +-- {-# INLINE sizeList #-} +-- sizeList :: Flat a => [a] -> NumBits -> NumBits +-- sizeList l sz = foldl' (\s e -> size e (s + 1)) (sz + 1) l + +-- {-# INLINE encodeList #-} +-- encodeList :: Flat a => [a] -> Encoding +-- encodeList = encodeListWith encode + +-- {-# INLINE decodeList #-} +-- decodeList :: Flat a => Get [a] +-- decodeList = decodeListWith decode + +{-# INLINE encodeArray #-} +encodeArray :: Flat a => [a] -> Encoding +encodeArray = encodeArrayWith encode diff --git a/src/Flat/Instances/Vector.hs b/src/Flat/Instances/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Instances/Vector.hs @@ -0,0 +1,45 @@ +-- | Flat instances for the vector package. +module Flat.Instances.Vector + () +where + +import Flat.Instances.Mono +import Flat.Instances.Util + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as S + +-- $setup +-- >>> import Flat.Instances.Test +-- >>> import Flat.Instances.Base() +-- >>> import qualified Data.Vector as V +-- >>> import qualified Data.Vector.Unboxed as U +-- >>> import qualified Data.Vector.Storable as S + +{-| +Vectors are encoded as arrays. + +>>> tst (V.fromList [11::Word8,22,33]) +(True,40,[3,11,22,33,0]) + +All Vectors are encoded in the same way: + +>>> let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)] +True +-} + +instance Flat a => Flat (V.Vector a) where + size = sizeSequence + encode = encodeSequence + decode = decodeSequence + +instance (U.Unbox a,Flat a) => Flat (U.Vector a) where + size = sizeSequence + encode = encodeSequence + decode = decodeSequence + +instance (S.Storable a,Flat a) => Flat (S.Vector a) where + size = sizeSequence + encode = encodeSequence + decode = decodeSequence diff --git a/src/Flat/Memory.hs b/src/Flat/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Memory.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{- | +Memory access primitives. + +Includes code from the store-core package. +-} +module 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) + + +-- | Wrapper around @copyAddrToByteArray#@ primop. +-- Copied from the store-core package +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 #-} diff --git a/src/Flat/Run.hs b/src/Flat/Run.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Run.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +-- |Encoding and decoding functions +module Flat.Run ( + flat, + flatRaw, + unflat, + unflatWith, + unflatRaw, + unflatRawWith, + ) where + +import qualified Data.ByteString as B +import Data.ByteString.Convert +import Flat.Class +import Flat.Decoder +import qualified Flat.Encoder as E +import Flat.Filler + +-- |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) +#ifdef ETA_VERSION + (E.trampolineEncoding (encode a)) +#else + (encode a) +#endif + +-- #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 + + + diff --git a/src/Flat/Tutorial.hs b/src/Flat/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Tutorial.hs @@ -0,0 +1,161 @@ +module Flat.Tutorial + ( + -- $setup + + -- $main + ) +where + + +{- $setup +To (de)serialise a data type, make it an instance of the 'Flat.Class.Flat' class. + +There is based support to automatically derive a correct instance. + +Let’s see some code. + +We need a couple of extensions: + +>>> :set -XDeriveGeneric -XDeriveAnyClass + +The @Flat@ top module: + +>>> import Flat + +And, just for fun, a couple of functions to display an encoded value as a sequence of bits: + +>>> import Flat.Instances.Test (flatBits,allBits) + +Define a few custom data types, deriving @Generic@ and @Flat@: + +>>> data Result = Bad | Good deriving (Show,Generic,Flat) + +>>> data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) + +>>> data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat) +-} + +{- $main +Now we can encode a List of Directions using 'Flat.Run.flat': + +>>> flat $ Cons North (Cons South Nil) +"\149" + +The result is a strict . + +And decode it back using 'Flat.Run.unflat': + +>>> unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction) +Right (Cons North (Cons South Nil)) + +The result is a 'Flat.Decoded' value: 'Either' a 'Flat.DecodeException' or the actual value. + +=== Optimal Bit-Encoding +#optimal-bit-encoding# + +A pecularity of Flat is that it uses an optimal bit-encoding rather than +the usual byte-oriented one. + +One bit is all we need for a 'Result' or for an empty 'List' value: + +>>> flatBits Good +"1" + +>>> flatBits (Nil::List Direction) +"0" + +Two or three bits suffice for a 'Direction' value: + +>>> flatBits South +"01" + +>>> flatBits West +"111" + +For the serialisation to work with byte-oriented devices or storage, we need to add some padding. + +To do so, rather than encoding a plain value, 'Flat.Run.flat' encodes a 'Flat.Filler.PostAligned' value, that's to say a value followed by a 'Flat.Filler.Filler' that stretches till the next byte boundary. + +In practice, the padding is a, possibly empty, sequence of 0s followed by a 1. + +For example, this list encodes as 7 bits: + +>>> flatBits $ Cons North (Cons South Nil) +"1001010" + +And, with the added padding of a final "1", will snugly fit in a single byte: + +>>> allBits $ Cons North (Cons South Nil) +"10010101" + +But .. you don't need to worry about these details as byte-padding is automatically added by the function 'Flat.Run.flat' and removed by 'Flat.Run.unflat'. + +=== Pre-defined Instances + +Flat instances are already defined for relevant types of some common packages: array, base, bytestring, containers, dlist, mono-traversable, text, unordered-containers, vector. + +They are automatically imported by the "Flat" module. + +For example: + +>>> flatBits $ Just True +"11" + +== Compatibility +#compatibility# + +=== + +* x32 and x64: 7.10.3, 8.0.2, 8.2.2, 8.4.4, 8.6.5, 8.8.3. + +* and : 8.0.2. + +=== + +* @ghcjs-8.4.0.1@. + +NOTE: Some tests are not run for @ghcjs@ as they are related to unsupported features such as UTF16 encoding of Text and short . + +For details of what tests are skipped search @test/Spec.hs@ for @ghcjs_HOST_OS@. + +NOTE: Some older versions of @ghcjs@ and versions of @flat@ prior to 0.33 encoded @Double@ values incorrectly when not aligned with a byte boundary. + +=== + +It builds (with @etlas 1.5.0.0@ and @eta-0.8.6b2@) and passes the @doctest-static@ test but it won't complete the main @spec@ test probably because of a recursive iteration issue, see . + +Support for @eta@ is not currently being actively mantained. + +== Known Bugs and Infelicities +#known-bugs-and-infelicities# + +=== Longish compilation times + +Relies more than other serialisation libraries on extensive inlining for its good performance, this unfortunately leads to longer compilation times. + +If you have many data types or very large ones this might become an issue. + +A couple of good practices that will eliminate or mitigate this problem are: + +- During development, turn optimisations off (@stack --fast@ or @-O0@ + in the cabal file). + +- Keep your serialisation code in a separate module(s). + +=== Data types with more than 512 constructors are currently unsupported + +This limit could be easily extended, shout if you need it. + +=== Other + +. + +== Acknowledgements +#acknowledgements# + +@flat@ reuses ideas and readapts code from various packages, mainly: +@store@, @binary-bits@ and @binary@ and includes contributions from +Justus Sagemüller. +-} + + diff --git a/src/Flat/Types.hs b/src/Flat/Types.hs new file mode 100644 --- /dev/null +++ b/src/Flat/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- |Common Types +module 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 + diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,13 +1,19 @@ -#resolver: lts-9.21 -resolver: lts-11.22 -#resolver: lts-12.16 -# resolver: nightly-2018-11-02 +resolver: lts-14.27 +packages: + - . +# - ../EXTERNAL/doctest + +allow-newer: true + extra-deps: -#- QuickCheck-2.12.6.1@sha256:95b4e3b01033bf7d2ad21d0085266dba378477ac88e3d11ff238fc9db2575e6d -# Required to avoid problem with Natural instance in QuickCheck -- QuickCheck-2.11.3@sha256:e4c56f52532c993fc4460aeac7a2543dc03a68fba36eff420f3294d4d2622416 -- tasty-1.1.0.4@sha256:1310ceed449b3227614b329a1672a2c5bb046cb49e281996523567b3b0ad9ecc -- tasty-quickcheck-0.10@sha256:9ddbacf1504bbbc4b99ab447d26651ad8454b69ceced3486e4623dccb89fb3d9 -- optparse-applicative-0.14.3.0@sha256:b6b56a922d10911a2824b965750ddc7794de746e347afe67f1a84d05168368dc -- wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3 + # Required for lts-6.35 and lts-9.21 + - quickcheck-instances-0.3.22 + - QuickCheck-2.13.2 + - splitmix-0.0.2 + - time-compat-1.9.3 + - hashable-1.2.6.1 + + # Modified doctest, used to generate static tests + - git: https://github.com/tittoassini/doctest + commit: c9cdbe4eee086cb8aa46e96532160320dd367f09 diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,169 @@ + +-- Execute doctest tests with no dependencies on doctest +-- TODO: move in a different doctest-static package +{-# LANGUAGE OverloadedStrings ,DeriveFunctor#-} +{-# LANGUAGE FlexibleInstances,UndecidableInstances #-} +-- move to doctest +module DocTest + ( asPrint + , test + , testProp + , LineChunk(..) + , ExpectedLine(..) + ) +where +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit + +import Test.Tasty.QuickCheck +-- import Runner.Example +import Data.Char +import Data.List +import Data.String + +class Print f where + asPrint :: f -> IO String + +instance Show a => Print (IO a) where + asPrint io = io >>= return . show + +instance {-# OVERLAPPABLE #-} Show a => Print a where + asPrint a = return (show a) + +{- + +-} +-- test :: TestName -> ExpectedResult -> IO String -> IO TestTree +test :: TestName -> String -> IO String -> IO TestTree +test loc expectedS valIO = do + let expected = read expectedS + actual <- lines <$> valIO + return $ testCase loc (mkResult expected actual @=? Equal) + -- return $ testCase loc (unlines exp @=? unlines actual) + +testProp :: Testable t => TestName -> t -> IO TestTree +testProp loc = return . testProperty loc + + +-- Code copied and adapted by doctest + +data Result = Equal | NotEqual [String] + deriving (Eq, Show,Read) + +-- | Remove trailing white space from a string. +-- +-- >>> stripEnd "foo " +-- "foo" +stripEnd :: String -> String +stripEnd = reverse . dropWhile isSpace . reverse + +mkResult :: ExpectedResult -> [String] -> Result +mkResult expected actual | expected `matches` actual = Equal + | otherwise = NotEqual (formatNotEqual expected actual) + where + chunksMatch :: [LineChunk] -> String -> Bool + chunksMatch [] "" = True + chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys + chunksMatch (LineChunk x : xs) ys = + x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys + chunksMatch zs@(WildCardChunk : xs) (_ : ys) = + xs `chunksMatch` ys || zs `chunksMatch` ys + chunksMatch _ _ = False + + matches :: ExpectedResult -> [String] -> Bool + matches (ExpectedLine x : xs) (y : ys) = x `chunksMatch` y && xs `matches` ys + matches (WildCardLine : xs) ys | xs `matches` ys = True + matches zs@(WildCardLine : _) (_ : ys) = zs `matches` ys + matches [] [] = True + matches [] _ = False + matches _ [] = False + + +formatNotEqual :: ExpectedResult -> [String] -> [String] +formatNotEqual expected_ actual = + formatLines "expected: " expected ++ formatLines " but got: " actual + where + expected :: [String] + expected = map + (\x -> case x of + ExpectedLine str -> concatMap lineChunkToString str + WildCardLine -> "..." + ) + expected_ + + -- use show to escape special characters in output lines if any output line + -- contains any unsafe character + escapeOutput | any (not . isSafe) (concat $ expected ++ actual) = map show + | otherwise = id + + isSafe :: Char -> Bool + isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) + + formatLines :: String -> [String] -> [String] + formatLines message xs = case escapeOutput xs of + y : ys -> (message ++ y) : map (padding ++) ys + [] -> [message] + where padding = replicate (length message) ' ' + +lineChunkToString :: LineChunk -> String +lineChunkToString WildCardChunk = "..." +lineChunkToString (LineChunk str) = str + +-- import Control.DeepSeq (deepseq, NFData(rnf)) + +-- | A thing with a location attached. +data Located a = Located Location a + deriving (Eq, Show, Functor) + +-- instance NFData a => NFData (Located a) where +-- rnf (Located loc a) = loc `deepseq` a `deepseq` () + +-- | Discard location information. +unLoc :: Located a -> a +unLoc (Located _ a) = a + +-- | Add dummy location information. +noLocation :: a -> Located a +noLocation = Located (UnhelpfulLocation "") + +-- | A line number. +type Line = Int + +-- | A combination of file name and line number. +data Location = UnhelpfulLocation String | Location FilePath Line + deriving Eq + +instance Show Location where + show (UnhelpfulLocation s) = s + show (Location file line ) = file ++ ":" ++ show line + +-- instance NFData Location where +-- rnf (UnhelpfulLocation str) = str `deepseq` () +-- rnf (Location file line ) = file `deepseq` line `deepseq` () + +-- | +-- Create a list from a location, by repeatedly increasing the line number by +-- one. +enumerate :: Location -> [Location] +enumerate loc = case loc of + UnhelpfulLocation _ -> repeat loc + Location file line -> map (Location file) [line ..] + +data DocTest = Example Expression ExpectedResult | Property Expression + deriving (Eq, Show,Read) + +data LineChunk = LineChunk String | WildCardChunk + deriving (Show, Eq,Read) + +instance IsString LineChunk where + fromString = LineChunk + +data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine + deriving (Show, Eq,Read) + +instance IsString ExpectedLine where + fromString = ExpectedLine . return . LineChunk + +type Expression = String +type ExpectedResult = [ExpectedLine] diff --git a/test/DocTest/Data/FloatCast.hs b/test/DocTest/Data/FloatCast.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Data/FloatCast.hs @@ -0,0 +1,11 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Data.FloatCast where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Data.FloatCast +import Numeric (showHex) +import Data.Word + +tests :: IO TestTree +tests = testGroup "Data.FloatCast" <$> sequence [ DocTest.testProp "src/Data/FloatCast.hs:41" ( \f -> wordToFloat (floatToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:43" "[ExpectedLine [LineChunk \"3189768192\"]]" (DocTest.asPrint( floatToWord (-0.15625) )), DocTest.test "src/Data/FloatCast.hs:46" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToFloat 3189768192 )), DocTest.test "src/Data/FloatCast.hs:49" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( floatToWord (-5.828125) == 0xC0BA8000 )), DocTest.testProp "src/Data/FloatCast.hs:67" ( \f -> wordToDouble (doubleToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:69" "[ExpectedLine [LineChunk \"\\\"3ff0000000000002\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord 1.0000000000000004) "" )), DocTest.test "src/Data/FloatCast.hs:72" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( doubleToWord 1.0000000000000004 == 0x3FF0000000000002 )), DocTest.test "src/Data/FloatCast.hs:75" "[ExpectedLine [LineChunk \"\\\"bfc4000000000000\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord (-0.15625)) "" )), DocTest.test "src/Data/FloatCast.hs:78" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToDouble 0xbfc4000000000000 )), DocTest.test "src/Data/FloatCast.hs:93" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) ))] diff --git a/test/DocTest/Data/ZigZag.hs b/test/DocTest/Data/ZigZag.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Data/ZigZag.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NegativeLiterals,ScopedTypeVariables,FlexibleContexts#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Data.ZigZag where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Data.ZigZag +import Data.Word +import Data.Int +import Numeric.Natural +import Test.QuickCheck.Instances.Natural + +tests :: IO TestTree +tests = testGroup "Data.ZigZag" <$> sequence [ DocTest.testProp "src/Data/ZigZag.hs:66" ( \(f::Integer) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:68" ( \(f::Natural) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:70" ( \(f::Int8) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:71" ( \(f::Word8) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:72" ( \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:73" ( \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.testProp "src/Data/ZigZag.hs:75" ( \(f::Int64) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:76" ( \(f::Word64) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:77" ( \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:78" ( \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.test "src/Data/ZigZag.hs:33" "[ExpectedLine [LineChunk \"0\"]]" (DocTest.asPrint( zigZag (0::Int8) )), DocTest.test "src/Data/ZigZag.hs:36" "[ExpectedLine [LineChunk \"1\"]]" (DocTest.asPrint( zigZag (-1::Int16) )), DocTest.test "src/Data/ZigZag.hs:39" "[ExpectedLine [LineChunk \"2\"]]" (DocTest.asPrint( zigZag (1::Int32) )), DocTest.test "src/Data/ZigZag.hs:42" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( zigZag (-2::Int16) )), DocTest.test "src/Data/ZigZag.hs:45" "[ExpectedLine [LineChunk \"99\"]]" (DocTest.asPrint( zigZag (-50::Integer) )), DocTest.test "src/Data/ZigZag.hs:48" "[ExpectedLine [LineChunk \"100\"]]" (DocTest.asPrint( zigZag (50::Integer) )), DocTest.test "src/Data/ZigZag.hs:51" "[ExpectedLine [LineChunk \"128\"]]" (DocTest.asPrint( zigZag (64::Integer) )), DocTest.test "src/Data/ZigZag.hs:54" "[ExpectedLine [LineChunk \"511\"]]" (DocTest.asPrint( zigZag (-256::Integer) )), DocTest.test "src/Data/ZigZag.hs:57" "[ExpectedLine [LineChunk \"512\"]]" (DocTest.asPrint( zigZag (256::Integer) )), DocTest.test "src/Data/ZigZag.hs:60" "[ExpectedLine [LineChunk \"[5,3,1,0,2,4,6]\"]]" (DocTest.asPrint( map zigZag [-3..3::Integer] )), DocTest.test "src/Data/ZigZag.hs:63" "[ExpectedLine [LineChunk \"[0,-1,1,-2,2,-3,3]\"]]" (DocTest.asPrint( map zagZig [0..6::Word8] ))] diff --git a/test/DocTest/Flat/Bits.hs b/test/DocTest/Flat/Bits.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Bits.hs @@ -0,0 +1,12 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Bits where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Bits +import Data.Word +import Flat.Instances.Base +import Flat.Instances.Test + +tests :: IO TestTree +tests = testGroup "Flat.Bits" <$> sequence [ DocTest.test "src/Flat/Bits.hs:44" "[ExpectedLine [LineChunk \"[True]\"]]" (DocTest.asPrint( bits True )), DocTest.test "src/Flat/Bits.hs:55" "[ExpectedLine [LineChunk \"[True,False,False,False,False,False,False,True]\"]]" (DocTest.asPrint( paddedBits True )), DocTest.test "src/Flat/Bits.hs:71" "[ExpectedLine [LineChunk \"[False,False,False,False,False,True,False,True]\"]]" (DocTest.asPrint( asBits (5::Word8) )), DocTest.test "src/Flat/Bits.hs:79" "[ExpectedLine [LineChunk \"[1,3]\"]]" (DocTest.asPrint( asBytes $ asBits (256+3::Word16) )), DocTest.test "src/Flat/Bits.hs:96" "[ExpectedLine [LineChunk \"\\\"00000001 00000011\\\"\"]]" (DocTest.asPrint( prettyShow $ asBits (256+3::Word16) ))] diff --git a/test/DocTest/Flat/Decoder/Prim.hs b/test/DocTest/Flat/Decoder/Prim.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Decoder/Prim.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE BinaryLiterals#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Decoder.Prim where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Decoder.Prim +import Data.Word +import Data.Int +import Flat.Run + +tests :: IO TestTree +tests = testGroup "Flat.Decoder.Prim" <$> sequence [ DocTest.test "src/Flat/Decoder/Prim.hs:186" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 ))] diff --git a/test/DocTest/Flat/Endian.hs b/test/DocTest/Flat/Endian.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Endian.hs @@ -0,0 +1,10 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Endian where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Endian +import Numeric (showHex) + +tests :: IO TestTree +tests = testGroup "Flat.Endian" <$> sequence [ DocTest.test "src/Flat/Endian.hs:36" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE64 0xF0F1F2F3F4F5F6F7 == if isBigEndian then 0xF0F1F2F3F4F5F6F7 else 0xF7F6F5F4F3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:49" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE32 0xF0F1F2F3 == if isBigEndian then 0xF0F1F2F3 else 0xF3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:62" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE16 0xF0F1 == if isBigEndian then 0xF0F1 else 0xF1F0 ))] diff --git a/test/DocTest/Flat/Instances/Array.hs b/test/DocTest/Flat/Instances/Array.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Array.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE FlexibleContexts#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Array where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Array +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 + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Array" <$> sequence [ DocTest.test "src/Flat/Instances/Array.hs:31" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( 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 )), DocTest.test "src/Flat/Instances/Array.hs:36" "[ExpectedLine [LineChunk \"(True,80,[1,4,2,5,4,11,22,33,44,0])\"]]" (DocTest.asPrint( tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] )), DocTest.test "src/Flat/Instances/Array.hs:39" "[ExpectedLine [LineChunk \"(True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0])\"]]" (DocTest.asPrint( tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")] )), DocTest.test "src/Flat/Instances/Array.hs:44" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( 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) ))] diff --git a/test/DocTest/Flat/Instances/Base.hs b/test/DocTest/Flat/Instances/Base.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Base.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NegativeLiterals#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Base where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Base +import Flat.Instances.Test +import Data.Fixed +import Data.Int +import Data.Complex(Complex(..)) +import Numeric.Natural +import Data.Word +import Data.Ratio +import qualified Data.List.NonEmpty as B +test = tstBits + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Base" <$> sequence [ DocTest.test "src/Flat/Instances/Base.hs:38" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test () )), DocTest.test "src/Flat/Instances/Base.hs:51" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test False )), DocTest.test "src/Flat/Instances/Base.hs:54" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test True )), DocTest.test "src/Flat/Instances/Base.hs:69" "[ExpectedLine [LineChunk \"(True,8,\\\"01100001\\\")\"]]" (DocTest.asPrint( test 'a' )), DocTest.test "src/Flat/Instances/Base.hs:74" "[ExpectedLine [LineChunk \"(True,16,\\\"11001000 00000001\\\")\"]]" (DocTest.asPrint( test 'È' )), DocTest.test "src/Flat/Instances/Base.hs:77" "[ExpectedLine [LineChunk \"(True,24,\\\"10001101 10011100 00000001\\\")\"]]" (DocTest.asPrint( test '不' )), DocTest.test "src/Flat/Instances/Base.hs:93" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (Nothing::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:96" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (Just False::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:102" "[ExpectedLine [LineChunk \"(True,2,\\\"00\\\")\"]]" (DocTest.asPrint( test (Left False::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:105" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test (Right ()::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:111" "[ExpectedLine [LineChunk \"(True,16,\\\"11110110 00000001\\\")\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) )), DocTest.test "src/Flat/Instances/Base.hs:114" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) )), DocTest.test "src/Flat/Instances/Base.hs:127" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:130" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (255::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:174" "[ExpectedLine [LineChunk \"(True,8,\\\"01111111\\\")\"]]" (DocTest.asPrint( test (127::Word) )), DocTest.test "src/Flat/Instances/Base.hs:179" "[ExpectedLine [LineChunk \"(True,16,\\\"11111110 00000001\\\")\"]]" (DocTest.asPrint( test (254::Word) )), DocTest.test "src/Flat/Instances/Base.hs:184" "[ExpectedLine [LineChunk \"(True,24,\\\"10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (32768::Word32) )), DocTest.test "src/Flat/Instances/Base.hs:189" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] )), DocTest.test "src/Flat/Instances/Base.hs:202" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:205" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (2^120::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:257" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int) )), DocTest.test "src/Flat/Instances/Base.hs:260" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:263" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:266" "[ExpectedLine [LineChunk \"(True,8,\\\"00000011\\\")\"]]" (DocTest.asPrint( test (-2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:269" "[ExpectedLine [LineChunk \"(True,8,\\\"00000100\\\")\"]]" (DocTest.asPrint( test (2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:282" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:285" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:288" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:291" "[ExpectedLine [LineChunk \"(True,8,\\\"00011111\\\")\"]]" (DocTest.asPrint( test (-(2^4)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:294" "[ExpectedLine [LineChunk \"(True,8,\\\"00100000\\\")\"]]" (DocTest.asPrint( test (2^4::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:297" "[ExpectedLine [LineChunk \"(True,144,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (-(2^120)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:300" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100\\\")\"]]" (DocTest.asPrint( test (2^120::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:311" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:314" "[ExpectedLine [LineChunk \"(True,8,\\\"11111110\\\")\"]]" (DocTest.asPrint( test (127::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:317" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (-128::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:328" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:331" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:334" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:337" "[ExpectedLine [LineChunk \"(True,24,\\\"11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (minBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:342" "[ExpectedLine [LineChunk \"(True,24,\\\"11111110 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (maxBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:355" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:358" "[ExpectedLine [LineChunk \"(True,40,\\\"11111111 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (minBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:361" "[ExpectedLine [LineChunk \"(True,40,\\\"11111110 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (maxBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:372" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:375" "[ExpectedLine [LineChunk \"(True,80,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (minBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:378" "[ExpectedLine [LineChunk \"(True,80,\\\"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (maxBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:398" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000000\\\")\"]]" (DocTest.asPrint( test (0::Float) )), DocTest.test "src/Flat/Instances/Base.hs:401" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000001\\\")\"]]" (DocTest.asPrint( test (1.4012984643E-45::Float) )), DocTest.test "src/Flat/Instances/Base.hs:404" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 01111111 11111111 11111111\\\")\"]]" (DocTest.asPrint( test (1.1754942107E-38::Float) )), DocTest.test "src/Flat/Instances/Base.hs:431" "[ExpectedLine [LineChunk \"(True,16,\\\"00000100 00000010\\\")\"]]" (DocTest.asPrint( test (4 :+ 2 :: Complex Word8) )), DocTest.test "src/Flat/Instances/Base.hs:439" "[ExpectedLine [LineChunk \"(True,16,\\\"00000011 00000100\\\")\"]]" (DocTest.asPrint( test (3%4::Ratio Word8) )), DocTest.test "src/Flat/Instances/Base.hs:451" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test ([]::[Bool]) )), DocTest.test "src/Flat/Instances/Base.hs:454" "[ExpectedLine [LineChunk \"(True,5,\\\"10100\\\")\"]]" (DocTest.asPrint( test [False,False] )), DocTest.test "src/Flat/Instances/Base.hs:479" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test "" )), DocTest.test "src/Flat/Instances/Base.hs:482" "[ExpectedLine [LineChunk \"(True,28,\\\"10110000 11011000 01101100 0010\\\")\"]]" (DocTest.asPrint( test "aaa" )), DocTest.test "src/Flat/Instances/Base.hs:490" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (B.fromList [True]) )), DocTest.test "src/Flat/Instances/Base.hs:493" "[ExpectedLine [LineChunk \"(True,4,\\\"0100\\\")\"]]" (DocTest.asPrint( test (B.fromList [False,False]) )), DocTest.test "src/Flat/Instances/Base.hs:502" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (False,()) )), DocTest.test "src/Flat/Instances/Base.hs:505" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test ((),()) )), DocTest.test "src/Flat/Instances/Base.hs:510" "[ExpectedLine [LineChunk \"(True,7,\\\"0111011\\\")\"]]" (DocTest.asPrint( test (False,True,True,True,False,True,True) ))] diff --git a/test/DocTest/Flat/Instances/ByteString.hs b/test/DocTest/Flat/Instances/ByteString.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/ByteString.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.ByteString where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.ByteString +import Flat.Instances.Test +import Flat.Instances.Base +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as SBS + +tests :: IO TestTree +tests = testGroup "Flat.Instances.ByteString" <$> sequence [ DocTest.test "src/Flat/Instances/ByteString.hs:39" "[ExpectedLine [LineChunk \"(True,48,[1,3,11,22,33,0])\"]]" (DocTest.asPrint( tst (B.pack [11,22,33]) )), DocTest.test "src/Flat/Instances/ByteString.hs:52" "[ExpectedLine [LineChunk \"(True,16,[1,0])\"]]" (DocTest.asPrint( tst (B.pack []) )), DocTest.test "src/Flat/Instances/ByteString.hs:57" "[ExpectedLine [LineChunk \"(True,51,[65,3,11,22,33,0])\"]]" (DocTest.asPrint( tst ((False,True,False,B.pack [11,22,33])) )), DocTest.test "src/Flat/Instances/ByteString.hs:62" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])] )), DocTest.test "src/Flat/Instances/ByteString.hs:71" "[ExpectedLine [LineChunk \"(True,51,[65,3,11,22,33,0])\"]]" (DocTest.asPrint( tst ((False,True,False,L.pack [11,22,33])) )), DocTest.test "src/Flat/Instances/ByteString.hs:80" "[ExpectedLine [LineChunk \"(True,51,[65,3,11,22,33,0])\"]]" (DocTest.asPrint( tst ((False,True,False,SBS.pack [11,22,33])) ))] diff --git a/test/DocTest/Flat/Instances/Containers.hs b/test/DocTest/Flat/Instances/Containers.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Containers.hs @@ -0,0 +1,15 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Containers where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Containers +import Flat.Instances.Test +import Data.Set +import Data.Sequence +import Data.IntMap +import Data.Map +import Data.Tree + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Containers" <$> sequence [ DocTest.test "src/Flat/Instances/Containers.hs:44" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (Data.IntMap.empty :: IntMap ()) )), DocTest.test "src/Flat/Instances/Containers.hs:47" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.IntMap.fromList [(1,"a"),(2,"b")] )), DocTest.test "src/Flat/Instances/Containers.hs:58" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (Data.Map.empty :: Map () ()) )), DocTest.test "src/Flat/Instances/Containers.hs:61" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.Map.fromList [("a","aa"),("b","bb")] )), DocTest.test "src/Flat/Instances/Containers.hs:66" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l) )), DocTest.test "src/Flat/Instances/Containers.hs:71" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l) )), DocTest.test "src/Flat/Instances/Containers.hs:82" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.Sequence.fromList [3::Word8,4,7] )), DocTest.test "src/Flat/Instances/Containers.hs:93" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.Set.fromList [3::Word8,4,7] )), DocTest.test "src/Flat/Instances/Containers.hs:104" "[ExpectedLine [LineChunk \"(True,39,[1,129,64,200,32])\"]]" (DocTest.asPrint( tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []]) ))] diff --git a/test/DocTest/Flat/Instances/DList.hs b/test/DocTest/Flat/Instances/DList.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/DList.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.DList where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.DList +import Flat.Instances.Test +import Flat.Instances.Base() +import Flat.Run +import Data.DList +test = tstBits + +tests :: IO TestTree +tests = testGroup "Flat.Instances.DList" <$> sequence [ DocTest.test "src/Flat/Instances/DList.hs:17" "[ExpectedLine [LineChunk \"(True,19,\\\"10000011 11000001 110\\\")\"]]" (DocTest.asPrint( test (Data.DList.fromList [7::Word,7]) )), DocTest.test "src/Flat/Instances/DList.hs:20" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l ))] diff --git a/test/DocTest/Flat/Instances/Mono.hs b/test/DocTest/Flat/Instances/Mono.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Mono.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Mono where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Mono +import Flat.Instances.Base() +import Flat.Instances.Test +import Data.Word +import qualified Data.Set +import qualified Data.Map + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Mono" <$> sequence [ DocTest.test "src/Flat/Instances/Mono.hs:60" "[ExpectedLine [LineChunk \"(True,8,[0])\"]]" (DocTest.asPrint( tst $ AsArray ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:63" "[ExpectedLine [LineChunk \"(True,40,[3,11,22,33,0])\"]]" (DocTest.asPrint( tst $ AsArray [11::Word8,22,33] )), DocTest.test "src/Flat/Instances/Mono.hs:66" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst $ AsList ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:69" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Mono.hs:72" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsSet (Data.Set.fromList [11::Word8,22,33])) )), DocTest.test "src/Flat/Instances/Mono.hs:162" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) )), DocTest.test "src/Flat/Instances/Mono.hs:165" "[ExpectedLine [LineChunk \"(True,18,[129,132,128])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) ))] diff --git a/test/DocTest/Flat/Instances/Text.hs b/test/DocTest/Flat/Instances/Text.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Text.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Text where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Text +import Flat.Instances.Base() +import Flat.Instances.Test +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Text" <$> sequence [ DocTest.test "src/Flat/Instances/Text.hs:25" "[ExpectedLine [LineChunk \"(True,16,[1,0])\"]]" (DocTest.asPrint( tst $ T.pack "" )), DocTest.test "src/Flat/Instances/Text.hs:28" "[ExpectedLine [LineChunk \"(True,120,[1,3,97,97,97,0])\"]]" (DocTest.asPrint( tst $ T.pack "aaa" )), DocTest.test "src/Flat/Instances/Text.hs:31" "[ExpectedLine [LineChunk \"(True,120,[1,6,194,162,194,162,194,162,0])\"]]" (DocTest.asPrint( tst $ T.pack "¢¢¢" )), DocTest.test "src/Flat/Instances/Text.hs:34" "[ExpectedLine [LineChunk \"(True,120,[1,9,230,151,165,230,151,165,230,151,165,0])\"]]" (DocTest.asPrint( tst $ T.pack "日日日" )), DocTest.test "src/Flat/Instances/Text.hs:44" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( tst (T.pack "abc") == tst (TL.pack "abc") )), DocTest.test "src/Flat/Instances/Text.hs:62" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( tst (UTF8Text $ T.pack "日日日") == tst (T.pack "日日日") ))] diff --git a/test/DocTest/Flat/Instances/Unordered.hs b/test/DocTest/Flat/Instances/Unordered.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Unordered.hs @@ -0,0 +1,16 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Unordered where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Unordered +import Flat.Instances.Base() +import Flat.Instances.Test +import Data.Word +import qualified Data.HashMap.Strict +import qualified Data.HashMap.Lazy +import qualified Data.HashSet +test = tstBits + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Unordered" <$> sequence [ DocTest.test "src/Flat/Instances/Unordered.hs:21" "[ExpectedLine [LineChunk \"(True,28,\\\"10000000 11000000 10100000 0110\\\")\"]]" (DocTest.asPrint( test (Data.HashSet.fromList [1..3::Word]) )), DocTest.test "src/Flat/Instances/Unordered.hs:31" "[ExpectedLine [LineChunk \"(True,35,\\\"10000001 00001011 01000001 00001011 000\\\")\"]]" (DocTest.asPrint( test (Data.HashMap.Strict.fromList [(1,11),(2,22)]) )), DocTest.test "src/Flat/Instances/Unordered.hs:34" "[ExpectedLine [LineChunk \"(True,35,\\\"10000001 00001011 01000001 00001011 000\\\")\"]]" (DocTest.asPrint( test (Data.HashMap.Lazy.fromList [(1,11),(2,22)]) ))] diff --git a/test/DocTest/Flat/Instances/Vector.hs b/test/DocTest/Flat/Instances/Vector.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Instances/Vector.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Instances.Vector where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Instances.Vector +import Flat.Instances.Test +import Flat.Instances.Base() +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as S + +tests :: IO TestTree +tests = testGroup "Flat.Instances.Vector" <$> sequence [ DocTest.test "src/Flat/Instances/Vector.hs:23" "[ExpectedLine [LineChunk \"(True,40,[3,11,22,33,0])\"]]" (DocTest.asPrint( tst (V.fromList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Vector.hs:28" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)] ))] diff --git a/test/DocTest/Flat/Tutorial.hs b/test/DocTest/Flat/Tutorial.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/Tutorial.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric,DeriveAnyClass#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.Tutorial where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.Tutorial +import Flat +import Flat.Instances.Test (flatBits,allBits) +data Result = Bad | Good deriving (Show,Generic,Flat) +data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) +data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat) + +tests :: IO TestTree +tests = testGroup "Flat.Tutorial" <$> sequence [ DocTest.test "src/Flat/Tutorial.hs:41" "[ExpectedLine [LineChunk \"\\\"\\\\149\\\"\"]]" (DocTest.asPrint( flat $ Cons North (Cons South Nil) )), DocTest.test "src/Flat/Tutorial.hs:48" "[ExpectedLine [LineChunk \"Right (Cons North (Cons South Nil))\"]]" (DocTest.asPrint( unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction) )), DocTest.test "src/Flat/Tutorial.hs:61" "[ExpectedLine [LineChunk \"\\\"1\\\"\"]]" (DocTest.asPrint( flatBits Good )), DocTest.test "src/Flat/Tutorial.hs:64" "[ExpectedLine [LineChunk \"\\\"0\\\"\"]]" (DocTest.asPrint( flatBits (Nil::List Direction) )), DocTest.test "src/Flat/Tutorial.hs:69" "[ExpectedLine [LineChunk \"\\\"01\\\"\"]]" (DocTest.asPrint( flatBits South )), DocTest.test "src/Flat/Tutorial.hs:72" "[ExpectedLine [LineChunk \"\\\"111\\\"\"]]" (DocTest.asPrint( flatBits West )), DocTest.test "src/Flat/Tutorial.hs:83" "[ExpectedLine [LineChunk \"\\\"1001010\\\"\"]]" (DocTest.asPrint( flatBits $ Cons North (Cons South Nil) )), DocTest.test "src/Flat/Tutorial.hs:88" "[ExpectedLine [LineChunk \"\\\"10010101\\\"\"]]" (DocTest.asPrint( allBits $ Cons North (Cons South Nil) )), DocTest.test "src/Flat/Tutorial.hs:101" "[ExpectedLine [LineChunk \"\\\"11\\\"\"]]" (DocTest.asPrint( flatBits $ Just True ))] diff --git a/test/DocTests.hs b/test/DocTests.hs new file mode 100644 --- /dev/null +++ b/test/DocTests.hs @@ -0,0 +1,20 @@ +module Main where +import Test.Tasty +import Test.Tasty.HUnit +import qualified DocTest.Flat.Bits +import qualified DocTest.Flat.Instances.Array +import qualified DocTest.Flat.Instances.ByteString +import qualified DocTest.Flat.Instances.DList +import qualified DocTest.Flat.Instances.Containers +import qualified DocTest.Flat.Instances.Base +import qualified DocTest.Flat.Instances.Unordered +import qualified DocTest.Flat.Instances.Vector +import qualified DocTest.Flat.Instances.Mono +import qualified DocTest.Flat.Instances.Text +import qualified DocTest.Flat.Tutorial +import qualified DocTest.Flat.Decoder.Prim +import qualified DocTest.Flat.Endian +import qualified DocTest.Data.ZigZag +import qualified DocTest.Data.FloatCast + +main = (testGroup "DocTests" <$> sequence [DocTest.Flat.Bits.tests,DocTest.Flat.Instances.Array.tests,DocTest.Flat.Instances.ByteString.tests,DocTest.Flat.Instances.DList.tests,DocTest.Flat.Instances.Containers.tests,DocTest.Flat.Instances.Base.tests,DocTest.Flat.Instances.Unordered.tests,DocTest.Flat.Instances.Vector.tests,DocTest.Flat.Instances.Mono.tests,DocTest.Flat.Instances.Text.tests,DocTest.Flat.Tutorial.tests,DocTest.Flat.Decoder.Prim.tests,DocTest.Flat.Endian.tests,DocTest.Data.ZigZag.tests,DocTest.Data.FloatCast.tests]) >>= defaultMain diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,624 +1,801 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Tests for the flat module -module Main where - -import Control.Monad -import Data.Bits -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Short as SBS -import Data.Char -import Data.Either -import Data.Flat -import Data.Flat.Bits -import Data.Flat.Decoder -import qualified Data.Flat.Encoder as E -import qualified Data.Flat.Encoder.Prim as E -import qualified Data.Flat.Encoder.Strict as E -import Data.Int -import Data.List -import qualified Data.Map as M -import Data.Ord -import Data.Proxy -import qualified Data.Sequence as Seq -import qualified Data.Text as T -import Data.Word -import Numeric.Natural -import System.Exit -import Test.Data -import Test.Data.Arbitrary -import Test.Data.Flat -import Test.Data.Values hiding (lbs, ns) -import Test.E -import Test.E.Arbitrary -import Test.E.Flat -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC hiding (getSize) --- import System.Arch -import Data.Flat.Endian -import Data.FloatCast - --- instance Flat [Int16] --- instance Flat [Word8] --- instance Flat [Bool] - -main = do --- #ifdef ghcjs_HOST_OS --- print "GHCJS" --- #endif - - -- printInfo - - mainTest - -- print $ flatRaw 18446744073709551615::Word64 - -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64) - -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1) - -- mainShow - -- eWord64E id 0b - --- printInfo = do --- print $ "BigEndian: " ++ show isBigEndian --- print getSystemArch --- print getSystemEndianness - -mainShow = do - mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1..10] - exitFailure - -mainTest = defaultMain tests - -tests :: TestTree -tests = testGroup "Tests" [ - testPrimitives - - ,testEncDec - - ,testFlat - ] - -testPrimitives = testGroup "conversion/memory primitives" [ - testEndian - ,testFloatingConvert - --,testShifts - ] - -testEncDec = testGroup "encode/decode primitives" [ - testEncodingPrim - ,testDecodingPrim -#ifdef TEST_DECBITS - ,testDecBits -#endif - ] - -testFlat = testGroup "flat/unflat" [ - testSize - ,testLargeEnum - ,testContainers - ,flatTests - ,flatUnflatRT - ] - - --- Data.Flat.Endian tests (to run, need to modify imports and cabal file) -testEndian = testGroup "Endian" [ - conv toBE16 (2^10 + 3) (2^9+2^8+4) - ,conv toBE32 (2^18 + 3) 50332672 - ,conv toBE64 (2^34 + 3) 216172782180892672 - ,conv toBE16 0x1234 0x3412 - ,conv toBE32 0x11223344 0x44332211 - ,conv toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301 - ] - -testFloatingConvert = testGroup "Floating conversions" [ - conv floatToWord -0.15625 3189768192 - ,conv wordToFloat 3189768192 -0.15625 - ,conv doubleToWord -0.15625 13818169556679524352 - ,conv wordToDouble 13818169556679524352 -0.15625 - ,rt "floatToWord" (prop_float_conv :: RT Float) - ,rt "doubleToWord" (prop_double_conv :: RT Double) - ] - --- ghcjs bug on shiftR 0, see: https://github.com/ghcjs/ghcjs/issues/706 -testShifts = testGroup "Shifts" $ map tst [0..33] - where - tst n = testCase ("shiftR " ++ show n) $ - let val = 4294967295::Word32 - s = val `shift` (-n) - r = val `shiftR` n - in r @?= s - --- shR = shiftR --- shR = unsafeShiftR -shR val 0 = val -shR val n = shift val (-n) - -testEncodingPrim = testGroup "Encoding Primitives" [ - encRawWith 1 E.eTrueF [0b10000001] - ,encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001] - - ,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1] - ,encRawWith 32 (E.eWord32BEF $ 2^18 + 3) [0,4,0,3,1] - - ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1] - ,encRawWith 64 (E.eWord64BEF $ 2^34 + 3) [0,0,0,4,0,0,0,3,1] - ,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129] - ,encRawWith 65 (E.eTrueF >=> E.eWord64BEF (2^34 + 3)) [128,0,0,2,0,0,0,1,129] - ,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129] - ,encRawWith 65 (E.eFalseF >=> E.eWord64BEF (2^34 + 3)) [0,0,0,2,0,0,0,1,129] - ] - where - encRawWith sz enc exp = testCase (unwords ["encode raw with size",show sz]) $ flatRawWith sz enc @?= exp - - -conv f v e = testCase (unwords ["conv",sshow v,showB . flat $ v,"to",sshow e]) $ f v @?= e - -testDecodingPrim = testGroup "Decoding Primitives" [ - dec ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) [0b10111110,0b10011010] ((),False,True,False) - ,dec ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) [0b11000000 - ,0b00000001 - ,0b01000000] ((),2^15+2,True,()) - ,dec ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) [0b11000000 - ,0b00000000 - ,0b00000000 - ,0b00000001 - ,0b01000000] ((),2^31+2,True,()) - ,dec dBE64 [0b10000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000010 - ] (2^63+2) - - ,dec ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) [0b11000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000000 - ,0b00000001 - ,0b01000000] ((),2^63+2,True,()) - - ] - where - dec decOp v e = testCase (unwords ["decode",sshow v]) $ unflatRawWith decOp (B.pack v) @?= Right e - -testDecBits = testGroup "Decode Bits" $ concat [ - decBitsN dBEBits8 - ,decBitsN dBEBits16 - ,decBitsN dBEBits32 - ,decBitsN dBEBits64 - ] - where - -- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions - decBitsN :: forall a. (Num a,FiniteBits a,Show a,Flat a) => (Int -> Get a) -> [TestTree] - decBitsN dec = let s = finiteBitSize (undefined::a) - in [decBits_ dec val numBitsToTake pre | numBitsToTake <- [0 .. s], val <- [0::a ,1+2^(s - 2)+2^(s - 5) ,fromIntegral $ (2^s::Integer) - 1],pre <- [0,1,7]] - - decBits_ :: forall a. (FiniteBits a,Show a,Flat a) => (Int -> Get a) -> a -> Int -> Int -> TestTree - decBits_ deco val numBitsToTake pre = - -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary - let vs = B.pack . asBytes . fromBools $ replicate pre False ++ toBools (asBits val) - len = B.length vs - sz = finiteBitSize (undefined::a) - dec :: Get a - dec = do - dropBits pre - r <- deco numBitsToTake - dropBits (len*8-numBitsToTake-pre) - return r - -- we expect the first numBitsToTake bits of the value - expectedD@(Right expected) :: Decoded a = Right $ val `shR` (sz - numBitsToTake) -- ghcjs: shiftR fails, see: https://github.com/ghcjs/ghcjs/issues/706 - actualD@(Right actual) :: Decoded a = unflatRawWith dec vs - in testCase (unwords ["take",show numBitsToTake,"bits from",show val,"of size",show sz,"with prefix",show pre,"sequence",showB vs,show expected,show actual,show $ val == actual,show $ expected == actual,show $ expected /= actual,show $ show expected == show actual,show $ flat expected == flat actual]) - $ actualD @?= expectedD - - -testSize = testGroup "Size" $ concat [ - sz () 0 - ,sz True 1 - ,sz One 2 - ,sz Two 2 - ,sz Three 2 - ,sz Four 3 - ,sz Five 3 - ,sz 'a' 8 - ,sz 'à' 16 - ,sz '经' 24 - ,sz (0::Word8) 8 - ,sz (1::Word8) 8 - ,concatMap (uncurry sz) ns - ,concatMap (uncurry sz) nsI - ,concatMap (uncurry sz) nsII - ,sz (1.1::Float) 32 - ,sz (1.1::Double) 64 - ,sz "" 1 - ,sz "abc" (4+3*8) - ,sz ((),(),Unit) 0 - ,sz (True,False,One,Five) 7 - ,sz map1 7 - ,sz bs (4+3*8) - ,sz stBS bsSize - ,sz lzBS bsSize -#ifndef ghcjs_HOST_OS - ,sz shBS bsSize -#endif - ,sz tx utf8Size - ,sz (UTF8Text tx) utf8Size - ,sz (UTF16Text tx) utf16Size - ] - where - tx = T.pack "txt" - utf8Size = 8+8+3*32+8 - utf16Size = 8+8+3*16+8 - bsSize = 8+8+3*8+8 - -sz v e = [testCase (unwords ["size of",sshow v]) $ getSize v @?= e] - --- E258_256 = 11111110 _257 = 111111110 _258 = 111111111 -testLargeEnum = testGroup "test enum with more than 256 constructors" $ concat - [ -#ifdef ENUM_LARGE - sz E258_256 8 - , sz E258_257 9 - , sz E258_258 9 - - -- As encode are inlined, this is going to take for ever if this is compiled with -O1 or -O2 - -- , encRaw (E258_256) [0b11111110] - -- , encRaw (E258_257) [0b11111111,0b00000000] - -- , encRaw (E258_258) [0b11111111,0b10000000] - -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000] - - , map trip [E258_1,E258_256,E258_257,E258_258] - , map trip [E256_1,E256_134,E256_256] -#endif - ] - -testContainers = testGroup "containers" [ - trip longSeq - , trip dataMap - , trip listMap - -- , trip intMap - ] - -flatUnflatRT = testGroup "unflat (flat v) == v" - [ rt "()" (prop_Flat_roundtrip:: RT ()) - ,rt "Bool" (prop_Flat_roundtrip::RT Bool) - ,rt "Word8" (prop_Flat_Large_roundtrip:: RTL Word8) - ,rt "Word16" (prop_Flat_Large_roundtrip:: RTL Word16) - ,rt "Word32" (prop_Flat_Large_roundtrip:: RTL Word32) - ,rt "Word64" (prop_Flat_Large_roundtrip:: RTL Word64) - ,rt "Word" (prop_Flat_Large_roundtrip:: RTL Word) - ,rt "Int8" (prop_Flat_Large_roundtrip:: RTL Int8) - ,rt "Int16" (prop_Flat_Large_roundtrip:: RTL Int16) - ,rt "Int32" (prop_Flat_Large_roundtrip:: RTL Int32) - ,rt "Int64" (prop_Flat_Large_roundtrip:: RTL Int64) - ,rt "Int" (prop_Flat_Large_roundtrip:: RTL Int) - ,rt "Integer" (prop_Flat_roundtrip:: RT Integer) - ,rt "Natural" (prop_Flat_roundtrip:: RT Natural) - ,rt "Float" (prop_Flat_roundtrip:: RT Float) - ,rt "Double" (prop_Flat_roundtrip:: RT Double) - ,rt "Char" (prop_Flat_roundtrip:: RT Char) - --,rt "ASCII" (prop_Flat_roundtrip:: RT ASCII) - ,rt "Unit" (prop_Flat_roundtrip:: RT Unit) - ,rt "Un" (prop_Flat_roundtrip:: RT Un ) - ,rt "N" (prop_Flat_roundtrip:: RT N ) - ,rt "E2" (prop_Flat_roundtrip:: RT E2 ) - ,rt "E3" (prop_Flat_roundtrip:: RT E3 ) - ,rt "E4" (prop_Flat_roundtrip:: RT E4 ) - ,rt "E8" (prop_Flat_roundtrip:: RT E8 ) - ,rt "E16" (prop_Flat_roundtrip:: RT E16 ) - ,rt "E17" (prop_Flat_roundtrip:: RT E17 ) - ,rt "E32" (prop_Flat_roundtrip:: RT E32 ) - ,rt "A" (prop_Flat_roundtrip:: RT A ) - ,rt "B" (prop_Flat_roundtrip:: RT B ) - ,rt "Maybe N" (prop_Flat_roundtrip:: RT (Maybe N)) - ,rt "Either N Bool" (prop_Flat_roundtrip:: RT (Either N Bool)) - ,rt "Either Int Char" (prop_Flat_roundtrip:: RT (Either Int Char)) - -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool)) - -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N)) - ,rt "List N" (prop_Flat_roundtrip:: RT (List N)) - ,rt "[Int16]" (prop_Flat_roundtrip:: RT [Int16]) - ,rt "String" (prop_Flat_roundtrip:: RT String) - -- Generates incorrect ascii chars? - ,rt "Text" (prop_Flat_roundtrip:: RT T.Text) - ,rt "ByteString" (prop_Flat_roundtrip:: RT B.ByteString) - ,rt "Lazy ByteString" (prop_Flat_roundtrip:: RT L.ByteString) -#ifndef ghcjs_HOST_OS - ,rt "Short ByteString" (prop_Flat_roundtrip:: RT SBS.ShortByteString) -#endif - ] - -rt n = QC.testProperty (unwords ["round trip",n]) - -flatTests = testGroup "flat/unflat Unit tests" $ concat [ - - -- Expected errors - errDec (Proxy::Proxy Bool) [] -- no data - ,errDec (Proxy::Proxy Bool) [128] -- no filler - ,errDec (Proxy::Proxy Bool) [128+1,1,2,4,8] -- additional bytes - - ,encRaw () [] - ,encRaw ((),(),Unit) [] - ,encRaw (Unit,'a',Unit,'a',Unit,'a',Unit) [97,97,97] - ,a () [1] - ,a True [128+1] - ,a (True,True) [128+64+1] - ,a (True,False,True) [128+32+1] - ,a (True,False,True,True) [128+32+16+1] - ,a (True,False,True,True,True) [128+32+16+8+1] - ,a (True,False,True,True,True,True) [128+32+16+8+4+1] - ,a (True,False,True,True,True,True,True) [128+32+16+8+4+2+1] - ,a (True,False,True,True,(True,True,True,True)) [128+32+16+8+4+2+1,1] - ,encRaw (True,False,True,True) [128+32+16] - ,encRaw ((True,True,False,True,False),(False,False,True,False,True,True)) [128+64+16+1,64+32] - ,encRaw ('\0','\1','\127') [0,1,127] - ,encRaw (33::Word32,44::Word32) [33,44] - --,s (Elem True) [64] - --,s (NECons True (NECons False (Elem True))) [128+64+32+4] - ,encRaw (0::Word8) [0] - ,encRaw (1::Word8) [1] - ,encRaw (255::Word8) [255] - ,encRaw (0::Word16) [0] - ,encRaw (1::Word16) [1] - ,encRaw (255::Word16) [255,1] - ,encRaw (256::Word16) [128,2] - ,encRaw (65535::Word16) [255,255,3] - ,encRaw (127::Word32) [127] - ,encRaw (128::Word32) [128,1] - ,encRaw (129::Word32) [129,1] - ,encRaw (255::Word32) [255,1] - ,encRaw (16383::Word32) [255,127] - ,encRaw (16384::Word32) [128,128,1] - ,encRaw (16385::Word32) [129,128,1] - ,encRaw (32767::Word32) [255,255,1] - ,encRaw (32768::Word32) [128,128,2] - ,encRaw (32769::Word32) [129,128,2] - ,encRaw (65535::Word32) [255,255,3] - ,encRaw (2097151::Word32) [255,255,127] - ,encRaw (2097152::Word32) [128,128,128,1] - ,encRaw (2097153::Word32) [129,128,128,1] - ,encRaw (4294967295::Word32) [255,255,255,255,15] - ,encRaw (255::Word64) [255,1] - ,encRaw (65535::Word64) [255,255,3] - ,encRaw (4294967295::Word64) [255,255,255,255,15] - ,encRaw (18446744073709551615::Word64) [255,255,255,255,255,255,255,255,255,1] - ,encRaw (False,18446744073709551615::Word64) [127,255,255,255,255,255,255,255,255,128,128] - ,encRaw (255::Word) [255,1] - ,encRaw (65535::Word) [255,255,3] - ,encRaw (4294967295::Word) [255,255,255,255,15] - ,tstI [0::Int8,2,-2] - ,encRaw (127::Int8) [254] - ,encRaw (-128::Int8) [255] - ,tstI [0::Int16,2,-2,127,-128] - ,tstI [0::Int32,2,-2,127,-128] - ,tstI [0::Int64,2,-2,127,-128] - ,encRaw (-1024::Int64) [255,15] - ,encRaw (maxBound::Word8) [255] - ,encRaw (True,maxBound::Word8) [255,128] - ,encRaw (maxBound::Word16) [255,255,3] - ,encRaw (True,maxBound::Word16) [255,255,129,128] - ,encRaw (maxBound::Word32) [255,255,255,255,15] - ,encRaw (True,maxBound::Word32) [255,255,255,255,135,128] - ,encRaw (maxBound::Word64) [255,255,255,255,255,255,255,255,255,1] - ,encRaw (True,maxBound::Word64) [255,255,255,255,255,255,255,255,255,128,128] - ,encRaw (minBound::Int64) [255,255,255,255,255,255,255,255,255,1] - ,encRaw (maxBound::Int64) [254,255,255,255,255,255,255,255,255,1] - ,tstI [0::Int,2,-2,127,-128] - ,tstI [0::Integer,2,-2,127,-128,-256,-512] - ,encRaw (-1024::Integer) [255,15] - ,encRaw (0::Float) [0,0,0,0] - ,encRaw (-2::Float) [0b11000000,0,0,0] - ,encRaw (0.085::Float) [0b00111101,0b10101110,0b00010100,0b01111011] - ,encRaw (0::Double) [0,0,0,0,0,0,0,0] - ,encRaw (-2::Double) [0b11000000,0,0,0,0,0,0,0] - ,encRaw (23::Double) [0b01000000,0b00110111,0,0,0,0,0,0] - ,encRaw (-0.15625::Float) [0b10111110,0b00100000,0,0] - ,encRaw (-0.15625::Double) [0b10111111,0b11000100,0,0,0,0,0,0] - ,encRaw (-123.2325E-23::Double) [0b10111011,0b10010111,0b01000111,0b00101000,0b01110101,0b01111011,0b01000111,0b10111010] - ,encRaw (Left True :: Either Bool (Double, Double)) [0b01000000] - ,encRaw (-2.1234E15 :: Double) [195,30,44,226,90,221,64,0] - ,encRaw (1.1234E-22 :: Double) [59,96,249,241,120,219,249,174] - ,encRaw ((False,-2.1234E15) :: (Bool,Double)) [97,143,22,113,45,110,160,0,0] - ,encRaw ((True,-2.1234E15) :: (Bool,Double)) [225,143,22,113,45,110,160,0,0] - ,encRaw ((-2.1234E15 , 1.1234E-22) :: (Double, Double)) $ [0b11000011,30,44,226,90,221,64,0] ++ [59,96,249,241,120,219,249,174] - ,encRaw ((True,-2.1234E15 , 1.1234E-22) :: (Bool,Double, Double)) [0b11100001,143,22,113,45,110,160,0,29,176,124,248,188,109,252,215,0] - ,encRaw (Right (-2.1234E15 , 1.1234E-22) :: Either Bool (Double, Double)) [0b11100001,143,22,113,45,110,160,0,29,176,124,248,188,109,252,215,0] - ,encRaw (Left True:: Either Bool Direction) [0b01000000] - ,encRaw (Right West :: Either Bool Direction) [0b11110000] - - - - ,map trip [minBound,maxBound::Word8] - ,map trip [minBound,maxBound::Word16] - ,map trip [minBound,maxBound::Word32] - ,map trip [minBound,maxBound::Word64] - ,map trip [minBound::Int8,maxBound::Int8] - ,map trip [minBound::Int16,maxBound::Int16] - ,map trip [minBound::Int32,maxBound::Int32] - ,map trip [minBound::Int64,maxBound::Int64] - ,map trip [0::Float,-0::Float,0/0::Float,1/0::Float] - ,map trip [0::Double,-0::Double,0/0::Double,1/0::Double] - ,encRaw '\0' [0] - ,encRaw '\1' [1] - ,encRaw '\127' [127] - ,encRaw 'a' [97] - ,encRaw 'à' [224,1] - ,encRaw '经' [207,253,1] - ,[trip [chr 0x10FFFF]] - ,encRaw Unit [] - ,encRaw (Un False) [0] - ,encRaw (One,Two,Three) [16+8] - ,encRaw (Five,Five,Five) [255,128] - --,s (NECons True (Elem True)) [128+64+16] - ,encRaw "" [0] -#ifdef LIST_BIT - ,encRaw "abc" [176,216,172,96] - ,encRaw [False,True,False,True] [128 - +32+16 - +8 - +2+1,0] -#elif defined(LIST_BYTE) - ,s "abc" s3 - ,s (cs 600) s600 -#endif - -- Aligned structures - --,s (T.pack "") [1,0] - --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0] - --,s (T.pack "abc") (al s3) - --,s (T.pack $ cs 600) (al s600) - ,encRaw map1 [0b10111000] - ,encRaw (B.pack $ csb 3) (bsl c3) - ,encRaw (B.pack $ csb 600) (bsl s600) - ,encRaw (L.pack $ csb 3) (bsl c3) - -- Long LazyStrings can have internal sections shorter than 255 - --,s (L.pack $ csb 600) (bsl s600) - ,[trip [1..100::Int16]] - ,[trip asciiStrT,trip "维护和平正",trip (T.pack "abc"),trip unicodeText,trip unicodeTextUTF8T] - ,[trip longBS,trip longLBS] -#ifndef ghcjs_HOST_OS - ,[trip longSBS] - ,[trip unicodeTextUTF16T] -#endif - ] - where - - --al = (1:) -- prealign - bsl = id -- noalign - - tstI = map ti - - ti v | v >= 0 = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral v ::Word64) - | otherwise = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral (-v) - 1 ::Word64) - - teq a b = ser a @?= ser b - - --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v] - - -- Aligned values unflat to the original value, modulo the added filler. - a v e = [testCase (unwords ["flat",sshow v]) $ ser v @?= e - ,testCase (unwords ["unflat",sshow v]) $ let Right v' = des e in v @?= v'] - -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e - -- ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v'] - - -encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree] -encRaw v e = [testCase (unwords ["flat raw",sshow v,show . B.unpack . flat $ v]) $ serRaw v @?= e] - -trip :: forall a .(Show a,Flat a) => a -> TestTree -trip v = testCase (unwords ["roundtrip",sshow v]) $ - -- we use show to get Right NaN == Right NaN - show (unflat (flat v::B.ByteString)::Decoded a) @?= show (Right v::Decoded a) - --- Test Data -lzBS = L.pack bs -stBS = B.pack bs -bs = [32,32,32::Word8] -s3 = [3,97,98,99,0] -c3a = [3,99,99,99,0] -- Array Word8 -c3 = pre c3a -s600 = pre s600a -pre = (1:) -s600a = concat [[255],csb 255,[255],csb 255,[90],csb 90,[0]] -s600B = concat [[55],csb 55,[255],csb 255,[90],csb 90,[200],csb 200,[0]] -longSeq :: Seq.Seq Word8 -longSeq = Seq.fromList lbs -longBS = B.pack lbs -longLBS = L.concat $ concat $ replicate 10 [L.pack lbs] -lbs = concat $ replicate 100 [234,123,255,0] -cs n = replicate n 'c' -- take n $ cycle ['a'..'z'] -csb = map (fromIntegral . ord) . cs -map1 = M.fromList [(False,True),(True,False)] - -ns :: [(Word64, Int)] -ns = [( (-) (2 ^(i*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]] - -nsI :: [(Int64, Int)] -nsI = nsI_ -nsII :: [(Integer, Int)] -nsII = nsI_ -nsI_ = [( (-) (2 ^(((-) i 1)*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]] - - - -#ifndef ghcjs_HOST_OS -shBS = SBS.toShort stBS -longSBS = SBS.toShort longBS -#endif - -sshow = take 80 . show - -showB = show . B.unpack - -errDec :: forall a . (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree] ---errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""] -errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in isRight ev @?= False] - -ser :: Flat a => a -> [Word8] -ser = B.unpack . flat - -des :: Flat a => [Word8] -> Decoded a -des = unflat - -flatRawWith sz enc = B.unpack $ E.strictEncoder (sz+8) (E.Encoding $ enc >=> E.eFillerF) - -serRaw :: Flat a => a -> [Word8] --- serRaw = B.unpack . flatRaw --- serRaw = L.unpack . flatRaw -serRaw = asBytes . bits - ---desRaw :: Flat a => [Word8] -> Decoded a ---desRaw = unflatRaw . L.pack - -type RT a = a -> Bool -type RTL a = Large a -> Bool - -prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool -prop_Flat_roundtrip = roundTripExt - -prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool -prop_Flat_Large_roundtrip (Large x) = roundTripExt x - -roundTrip x = unflat (flat x::B.ByteString) == Right x - --- Test roundtrip for both the value and the value embedded between bools -roundTripExt x = roundTrip x && roundTrip (True,x,False) - -prop_double_conv d = wordToDouble (doubleToWord d) == d - -prop_float_conv d = wordToFloat (floatToWord d) == d - -{- -prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool -prop_common_unsigned n _ = let n2 :: h = fromIntegral n - in flat n == flat n2 --} - --- e :: Stream Bool --- e = unflatIncremental . flat $ stream1 - --- el :: List Bool --- el = unflatIncremental . flat $ infList - --- deflat = unflat - --- b1 :: BLOB UTF8 --- b1 = BLOB UTF8 (preAligned (List255 [97,98,99])) --- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99]))) - - - - - +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for the flat module +module Main where + +import Control.Monad +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as SBS +import Data.Char +import Data.Either +import Flat +import Flat.Bits +import Flat.Decoder +import qualified Flat.Encoder as E +import qualified Flat.Encoder.Prim as E +import qualified Flat.Encoder.Strict as E +import Data.Int +import Data.Proxy +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import Data.Word +import Numeric.Natural +import System.Exit +import Test.Data +import Test.Data.Arbitrary () +import Test.Data.Flat +import Test.Data.Values hiding (lbs, ns) +import Test.E +import Test.E.Arbitrary () +import Test.E.Flat +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC hiding (getSize) +import Flat.Endian +import Data.FloatCast +import Data.Text.Arbitrary +-- import Test.QuickCheck.Arbitrary +import qualified Data.Complex as B +import qualified Data.Ratio as B +import qualified Data.Map as C +import qualified Data.Map.Strict as CS +import qualified Data.Map.Lazy as CL +import qualified Data.IntMap.Strict as CS +import qualified Data.IntMap.Lazy as CL +-- import Data.List +-- import Data.Ord +#if MIN_VERSION_base(4,9,0) +import qualified Data.List.NonEmpty as BI +#endif + +instance Arbitrary UTF8Text where + arbitrary = UTF8Text <$> arbitrary + + shrink t = UTF8Text <$> shrink (unUTF8 t) + +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) +instance Arbitrary UTF16Text where + arbitrary = UTF16Text <$> arbitrary + + shrink t = UTF16Text <$> shrink (unUTF16 t) +#endif + +-- instance Flat [Int16] +-- instance Flat [Word8] +-- instance Flat [Bool] +main = do + -- #ifdef ghcjs_HOST_OS + -- print "GHCJS" + -- #endif + -- printInfo + -- print $ flat asciiStrT + mainTest + + -- print $ flatRaw 18446744073709551615::Word64 + -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64) + -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1) + -- mainShow + -- eWord64E id 0b +mainShow = do + mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1 .. 10] + exitFailure + +mainTest = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [testPrimitives, testEncDec, testFlat] + +testPrimitives = + testGroup "conversion/memory primitives" [testEndian, testFloatingConvert] + + --,testShifts -- ghcjs fails this +testEncDec = testGroup + "encode/decode primitives" + [ testEncodingPrim + , testDecodingPrim +#ifdef TEST_DECBITS + , testDecBits +#endif + ] + +testFlat = testGroup + "flat/unflat" + [testSize, testLargeEnum, testContainers, flatUnflatRT, flatTests] + +-- Flat.Endian tests (to run, need to modify imports and cabal file) +testEndian = testGroup + "Endian" + [ convBE toBE16 (2 ^ 10 + 3) (2 ^ 9 + 2 ^ 8 + 4) + , convBE toBE32 (2 ^ 18 + 3) 50332672 + , convBE toBE64 (2 ^ 34 + 3) 216172782180892672 + , convBE toBE16 0x1234 0x3412 + , convBE toBE32 0x11223344 0x44332211 + , convBE toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301] + +testFloatingConvert = testGroup + "Floating conversions" + [ conv floatToWord (-0.15625) 3189768192 + , conv wordToFloat 3189768192 (-0.15625) + , conv doubleToWord (-0.15625) 13818169556679524352 + , conv wordToDouble 13818169556679524352 (-0.15625) + , rt "floatToWord" (prop_float_conv :: RT Float) + , rt "doubleToWord" (prop_double_conv :: RT Double)] + +convBE f v littleEndianE = + let e = if isBigEndian + then v + else littleEndianE + in testCase (unwords ["conv BigEndian", sshow v, "to", sshow e]) $ f v @?= e + +conv f v e = testCase + (unwords ["conv", sshow v, showB . flat $ v, "to", sshow e]) + $ f v @?= e + +-- ghcjs bug on shiftR 0, see: https://github.com/ghcjs/ghcjs/issues/706 +testShifts = testGroup "Shifts" $ map tst [0 .. 33] + where + tst n = testCase ("shiftR " ++ show n) + $ let val = 4294967295 :: Word32 + s = val `shift` (-n) + r = val `shiftR` n + in r @?= s + +-- shR = shiftR +-- shR = unsafeShiftR +shR val 0 = val +shR val n = shift val (-n) + +testEncodingPrim = testGroup + "Encoding Primitives" + [ encRawWith 1 E.eTrueF [0b10000001] + , encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001] + -- Depends on endianess + --,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1] + -- ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1] + --,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129] + --,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129] + -- Big Endian + , encRawWith 32 (E.eWord32BEF $ 2 ^ 18 + 3) [0, 4, 0, 3, 1] + , encRawWith 64 (E.eWord64BEF $ 2 ^ 34 + 3) [0, 0, 0, 4, 0, 0, 0, 3, 1] + , encRawWith + 65 + (E.eTrueF >=> E.eWord64BEF (2 ^ 34 + 3)) + [128, 0, 0, 2, 0, 0, 0, 1, 129] + , encRawWith + 65 + (E.eFalseF >=> E.eWord64BEF (2 ^ 34 + 3)) + [0, 0, 0, 2, 0, 0, 0, 1, 129]] + where + encRawWith sz enc exp = testCase + (unwords ["encode raw with size", show sz]) + $ flatRawWith sz enc @?= exp + +testDecodingPrim = testGroup + "Decoding Primitives" + [ dec + ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) + [0b10111110, 0b10011010] + ((), False, True, False) + , dec + ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) + [0b11000000, 0b00000001, 0b01000000] + ((), 2 ^ 15 + 2, True, ()) + , dec + ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) + [0b11000000, 0b00000000, 0b00000000, 0b00000001, 0b01000000] + ((), 2 ^ 31 + 2, True, ()) + , dec + dBE64 + [ 0b10000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000010] + (2 ^ 63 + 2) + , dec + ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) + [ 0b11000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000001 + , 0b01000000] + ((), 2 ^ 63 + 2, True, ())] + where + dec decOp v e = testCase (unwords ["decode", sshow v]) + $ unflatRawWith decOp (B.pack v) @?= Right e + +testDecBits = testGroup "Decode Bits" + $ concat + [ decBitsN dBEBits8 + , decBitsN dBEBits16 + , decBitsN dBEBits32 + , decBitsN dBEBits64] +-- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions + where + decBitsN :: forall a. + (Num a, FiniteBits a, Show a, Flat a) + => (Int -> Get a) + -> [TestTree] + decBitsN dec = let s = finiteBitSize (undefined :: a) + in [decBits_ dec val numBitsToTake pre + | numBitsToTake <- [0 .. s] + , val <- [ 0 :: a + , 1 + 2 ^ (s - 2) + 2 ^ (s - 5) + , fromIntegral $ (2 ^ s :: Integer) - 1] + , pre <- [0, 1, 7]] + + decBits_ :: forall a. + (FiniteBits a, Show a, Flat a) + => (Int -> Get a) + -> a + -> Int + -> Int + -> TestTree + decBits_ deco val numBitsToTake pre = + -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary + let vs = B.pack . asBytes . fromBools + $ replicate pre False ++ toBools (asBits val) + len = B.length vs + sz = finiteBitSize (undefined :: a) + dec :: Get a + dec = do + dropBits pre + r <- deco numBitsToTake + dropBits (len * 8 - numBitsToTake - pre) + return r + -- we expect the first numBitsToTake bits of the value + expectedD @ (Right expected) :: Decoded a = Right + $ val `shR` (sz - numBitsToTake) -- ghcjs: shiftR fails, see: https://github.com/ghcjs/ghcjs/issues/706 + actualD @ (Right actual) :: Decoded a = unflatRawWith dec vs + in testCase + (unwords + [ "take" + , show numBitsToTake + , "bits from" + , show val + , "of size" + , show sz + , "with prefix" + , show pre + , "sequence" + , showB vs + , show expected + , show actual + , show $ val == actual + , show $ expected == actual + , show $ expected /= actual + , show $ show expected == show actual + , show $ flat expected == flat actual]) + $ actualD @?= expectedD + +testSize = testGroup "Size" + $ concat + [ sz () 0 + , sz True 1 + , sz One 2 + , sz Two 2 + , sz Three 2 + , sz Four 3 + , sz Five 3 + , sz 'a' 8 + , sz 'à' 16 + , sz '经' 24 + , sz (0 :: Word8) 8 + , sz (1 :: Word8) 8 + , concatMap (uncurry sz) ns + , concatMap (uncurry sz) nsI + , concatMap (uncurry sz) nsII + , sz (1.1 :: Float) 32 + , sz (1.1 :: Double) 64 + , sz "" 1 + , sz "abc" (4 + 3 * 8) + , sz ((), (), Unit) 0 + , sz (True, False, One, Five) 7 + , sz map1 7 + , sz bs (4 + 3 * 8) + , sz stBS bsSize + , sz lzBS bsSize +#ifndef ghcjs_HOST_OS + , sz shBS bsSize +#endif + , sz tx utf8Size + , sz (UTF8Text tx) utf8Size +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) + , sz (UTF16Text tx) utf16Size +#endif + ] + where + tx = T.pack "txt" + + utf8Size = 8 + 8 + 3 * 32 + 8 + + utf16Size = 8 + 8 + 3 * 16 + 8 + + bsSize = 8 + 8 + 3 * 8 + 8 + +sz v e = [testCase (unwords ["size of", sshow v]) $ getSize v @?= e] + +-- E258_256 = 11111110 _257 = 111111110 _258 = 111111111 +testLargeEnum = testGroup "test enum with more than 256 constructors" + $ concat + [ +#ifdef ENUM_LARGE + sz E258_256 8 + , sz E258_257 9 + , sz E258_258 9 + -- As encodes are inlined, this is going to take for ever if this is compiled with -O1 or -O2 + -- , encRaw (E258_256) [0b11111110] + -- , encRaw (E258_257) [0b11111111,0b00000000] + -- , encRaw (E258_258) [0b11111111,0b10000000] + -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000] + , map trip [E258_1, E258_256, E258_257, E258_258] + , map trip [E256_1, E256_134, E256_256] +#endif + ] + +testContainers = + testGroup "containers" [trip longSeq, trip dataMap, trip listMap] + + -- , trip intMap +flatUnflatRT = testGroup + "unflat (flat v) == v" + [ rt "()" (prop_Flat_roundtrip :: RT ()) + , rt "Bool" (prop_Flat_roundtrip :: RT Bool) + , rt "Char" (prop_Flat_roundtrip :: RT Char) + , rt "Complex" (prop_Flat_roundtrip :: RT (B.Complex Float)) + , rt "Either N Bool" (prop_Flat_roundtrip :: RT (Either N Bool)) + , rt "Either Int Char" (prop_Flat_roundtrip :: RT (Either Int Char)) + , rt "Int8" (prop_Flat_Large_roundtrip :: RTL Int8) + , rt "Int16" (prop_Flat_Large_roundtrip :: RTL Int16) + , rt "Int32" (prop_Flat_Large_roundtrip :: RTL Int32) + , rt "Int64" (prop_Flat_Large_roundtrip :: RTL Int64) + , rt "Int" (prop_Flat_Large_roundtrip :: RTL Int) + , rt "[Int16]" (prop_Flat_roundtrip :: RT [Int16]) + , rt "String" (prop_Flat_roundtrip :: RT String) +#if MIN_VERSION_base(4,9,0) + , rt "NonEmpty" (prop_Flat_roundtrip :: RT (BI.NonEmpty Bool)) +#endif + , rt "Maybe N" (prop_Flat_roundtrip :: RT (Maybe N)) + , rt "Ratio" (prop_Flat_roundtrip :: RT (B.Ratio Int32)) + , rt "Word8" (prop_Flat_Large_roundtrip :: RTL Word8) + , rt "Word16" (prop_Flat_Large_roundtrip :: RTL Word16) + , rt "Word32" (prop_Flat_Large_roundtrip :: RTL Word32) + , rt "Word64" (prop_Flat_Large_roundtrip :: RTL Word64) + , rt "Word" (prop_Flat_Large_roundtrip :: RTL Word) + , rt "Natural" (prop_Flat_roundtrip :: RT Natural) + , rt "Integer" (prop_Flat_roundtrip :: RT Integer) + , rt "Float" (prop_Flat_roundtrip :: RT Float) + , rt "Double" (prop_Flat_roundtrip :: RT Double) + , rt "Text" (prop_Flat_roundtrip :: RT T.Text) + , rt "UTF8 Text" (prop_Flat_roundtrip :: RT UTF8Text) +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) + , rt "UTF16 Text" (prop_Flat_roundtrip :: RT UTF16Text) +#endif + , rt "ByteString" (prop_Flat_roundtrip :: RT B.ByteString) + , rt "Lazy ByteString" (prop_Flat_roundtrip :: RT L.ByteString) +#ifndef ghcjs_HOST_OS + , rt "Short ByteString" (prop_Flat_roundtrip :: RT SBS.ShortByteString) +#endif + , rt "Map.Strict" (prop_Flat_roundtrip :: RT (CS.Map Int Bool)) + , rt "Map.Lazy" (prop_Flat_roundtrip :: RT (CL.Map Int Bool)) + , rt "IntMap.Strict" (prop_Flat_roundtrip :: RT (CS.IntMap Bool)) + , rt "IntMap.Lazy" (prop_Flat_roundtrip :: RT (CL.IntMap Bool)) + , rt "Unit" (prop_Flat_roundtrip :: RT Unit) + , rt "Un" (prop_Flat_roundtrip :: RT Un) + , rt "N" (prop_Flat_roundtrip :: RT N) + , rt "E2" (prop_Flat_roundtrip :: RT E2) + , rt "E3" (prop_Flat_roundtrip :: RT E3) + , rt "E4" (prop_Flat_roundtrip :: RT E4) + , rt "E8" (prop_Flat_roundtrip :: RT E8) + , rt "E16" (prop_Flat_roundtrip :: RT E16) + , rt "E17" (prop_Flat_roundtrip :: RT E17) + , rt "E32" (prop_Flat_roundtrip :: RT E32) + , rt "A" (prop_Flat_roundtrip :: RT A) + , rt "B" (prop_Flat_roundtrip :: RT B) + -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool)) + -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N)) + , rt "List N" (prop_Flat_roundtrip :: RT (List N))] + +rt n = QC.testProperty (unwords ["round trip", n]) + +flatTests = testGroup "flat/unflat Unit tests" + $ concat + [ -- Expected errors + errDec (Proxy :: Proxy Bool) [] -- no data + , errDec (Proxy :: Proxy Bool) [128] -- no filler + , errDec (Proxy :: Proxy Bool) [128 + 1, 1, 2, 4, 8] -- additional bytes + , encRaw () [] + , encRaw ((), (), Unit) [] + , encRaw (Unit, 'a', Unit, 'a', Unit, 'a', Unit) [97, 97, 97] + , a () [1] + , a True [128 + 1] + , a (True, True) [128 + 64 + 1] + , a (True, False, True) [128 + 32 + 1] + , a (True, False, True, True) [128 + 32 + 16 + 1] + , a (True, False, True, True, True) [128 + 32 + 16 + 8 + 1] + , a (True, False, True, True, True, True) [128 + 32 + 16 + 8 + 4 + 1] + , a + (True, False, True, True, True, True, True) + [128 + 32 + 16 + 8 + 4 + 2 + 1] + , a + (True, False, True, True, (True, True, True, True)) + [128 + 32 + 16 + 8 + 4 + 2 + 1, 1] + , encRaw (True, False, True, True) [128 + 32 + 16] + , encRaw + ( (True, True, False, True, False) + , (False, False, True, False, True, True)) + [128 + 64 + 16 + 1, 64 + 32] + , encRaw ('\0', '\1', '\127') [0, 1, 127] + , encRaw (33 :: Word32, 44 :: Word32) [33, 44] + --,s (Elem True) [64] + --,s (NECons True (NECons False (Elem True))) [128+64+32+4] + , encRaw (0 :: Word8) [0] + , encRaw (1 :: Word8) [1] + , encRaw (255 :: Word8) [255] + , encRaw (0 :: Word16) [0] + , encRaw (1 :: Word16) [1] + , encRaw (255 :: Word16) [255, 1] + , encRaw (256 :: Word16) [128, 2] + , encRaw (65535 :: Word16) [255, 255, 3] + , encRaw (127 :: Word32) [127] + , encRaw (128 :: Word32) [128, 1] + , encRaw (129 :: Word32) [129, 1] + , encRaw (255 :: Word32) [255, 1] + , encRaw (16383 :: Word32) [255, 127] + , encRaw (16384 :: Word32) [128, 128, 1] + , encRaw (16385 :: Word32) [129, 128, 1] + , encRaw (32767 :: Word32) [255, 255, 1] + , encRaw (32768 :: Word32) [128, 128, 2] + , encRaw (32769 :: Word32) [129, 128, 2] + , encRaw (65535 :: Word32) [255, 255, 3] + , encRaw (2097151 :: Word32) [255, 255, 127] + , encRaw (2097152 :: Word32) [128, 128, 128, 1] + , encRaw (2097153 :: Word32) [129, 128, 128, 1] + , encRaw (4294967295 :: Word32) [255, 255, 255, 255, 15] + , encRaw (255 :: Word64) [255, 1] + , encRaw (65535 :: Word64) [255, 255, 3] + , encRaw (4294967295 :: Word64) [255, 255, 255, 255, 15] + , encRaw + (18446744073709551615 :: Word64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , encRaw + (False, 18446744073709551615 :: Word64) + [127, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128] + , encRaw (255 :: Word) [255, 1] + , encRaw (65535 :: Word) [255, 255, 3] + , encRaw (4294967295 :: Word) [255, 255, 255, 255, 15] + , tstI [0 :: Int8, 2, -2] + , encRaw (127 :: Int8) [254] + , encRaw (-128 :: Int8) [255] + , tstI [0 :: Int16, 2, -2, 127, -128] + , tstI [0 :: Int32, 2, -2, 127, -128] + , tstI [0 :: Int64, 2, -2, 127, -128] + , encRaw (-1024 :: Int64) [255, 15] + , encRaw (maxBound :: Word8) [255] + , encRaw (True, maxBound :: Word8) [255, 128] + , encRaw (maxBound :: Word16) [255, 255, 3] + , encRaw (True, maxBound :: Word16) [255, 255, 129, 128] + , encRaw (maxBound :: Word32) [255, 255, 255, 255, 15] + , encRaw (True, maxBound :: Word32) [255, 255, 255, 255, 135, 128] + , encRaw + (maxBound :: Word64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , encRaw + (True, maxBound :: Word64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128] + , encRaw + (minBound :: Int64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , encRaw + (maxBound :: Int64) + [254, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , tstI [0 :: Int, 2, -2, 127, -128] + , tstI [0 :: Integer, 2, -2, 127, -128, -256, -512] + , encRaw (-1024 :: Integer) [255, 15] + , encRaw (0 :: Float) [0, 0, 0, 0] + , encRaw (-2 :: Float) [0b11000000, 0, 0, 0] + , encRaw (0.085 :: Float) [0b00111101, 0b10101110, 0b00010100, 0b01111011] + , encRaw (0 :: Double) [0, 0, 0, 0, 0, 0, 0, 0] + , encRaw (-2 :: Double) [0b11000000, 0, 0, 0, 0, 0, 0, 0] + , encRaw (23 :: Double) [0b01000000, 0b00110111, 0, 0, 0, 0, 0, 0] + , encRaw (-0.15625 :: Float) [0b10111110, 0b00100000, 0, 0] + , encRaw (-0.15625 :: Double) [0b10111111, 0b11000100, 0, 0, 0, 0, 0, 0] + , encRaw + (-123.2325E-23 :: Double) + [ 0b10111011 + , 0b10010111 + , 0b01000111 + , 0b00101000 + , 0b01110101 + , 0b01111011 + , 0b01000111 + , 0b10111010] + , encRaw (Left True :: Either Bool (Double, Double)) [0b01000000] + , encRaw (-2.1234E15 :: Double) [195, 30, 44, 226, 90, 221, 64, 0] + , encRaw (1.1234E-22 :: Double) [59, 96, 249, 241, 120, 219, 249, 174] + , encRaw + ((False, -2.1234E15) :: (Bool, Double)) + [97, 143, 22, 113, 45, 110, 160, 0, 0] + , encRaw + ((True, -2.1234E15) :: (Bool, Double)) + [225, 143, 22, 113, 45, 110, 160, 0, 0] + , encRaw ((-2.1234E15, 1.1234E-22) :: (Double, Double)) + $ [0b11000011, 30, 44, 226, 90, 221, 64, 0] + ++ [59, 96, 249, 241, 120, 219, 249, 174] + , encRaw + ((True, -2.1234E15, 1.1234E-22) :: (Bool, Double, Double)) + [ 0b11100001 + , 143 + , 22 + , 113 + , 45 + , 110 + , 160 + , 0 + , 29 + , 176 + , 124 + , 248 + , 188 + , 109 + , 252 + , 215 + , 0] + , encRaw + (Right (-2.1234E15, 1.1234E-22) :: Either Bool (Double, Double)) + [ 0b11100001 + , 143 + , 22 + , 113 + , 45 + , 110 + , 160 + , 0 + , 29 + , 176 + , 124 + , 248 + , 188 + , 109 + , 252 + , 215 + , 0] + , encRaw (Left True :: Either Bool Direction) [0b01000000] + , encRaw (Right West :: Either Bool Direction) [0b11110000] + , map trip [minBound, maxBound :: Word8] + , map trip [minBound, maxBound :: Word16] + , map trip [minBound, maxBound :: Word32] + , map trip [minBound, maxBound :: Word64] + , map trip [minBound :: Int8, maxBound :: Int8] + , map trip [minBound :: Int16, maxBound :: Int16] + , map trip [minBound :: Int32, maxBound :: Int32] + , map trip [minBound :: Int64, maxBound :: Int64] + , map tripShow [0 :: Float, -0 :: Float, 0 / 0 :: Float, 1 / 0 :: Float] + , map + tripShow + [0 :: Double, -0 :: Double, 0 / 0 :: Double, 1 / 0 :: Double] + , encRaw '\0' [0] + , encRaw '\1' [1] + , encRaw '\127' [127] + , encRaw 'a' [97] + , encRaw 'à' [224, 1] + , encRaw '经' [207, 253, 1] + , [trip [chr 0x10FFFF]] + , encRaw Unit [] + , encRaw (Un False) [0] + , encRaw (One, Two, Three) [16 + 8] + , encRaw (Five, Five, Five) [255, 128] + --,s (NECons True (Elem True)) [128+64+16] + , encRaw "" [0] +#ifdef LIST_BIT + , encRaw "abc" [176, 216, 172, 96] + , encRaw [False, True, False, True] [128 + 32 + 16 + 8 + 2 + 1, 0] +#elif defined(LIST_BYTE) + , s "abc" s3 + , s (cs 600) s600 +#endif + -- Aligned structures + --,s (T.pack "") [1,0] + --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0] + --,s (T.pack "abc") (al s3) + --,s (T.pack $ cs 600) (al s600) + , encRaw map1 [0b10111000] + , encRaw (B.pack $ csb 3) (bsl c3) + , encRaw (B.pack $ csb 600) (bsl s600) + , encRaw (L.pack $ csb 3) (bsl c3) + -- Long LazyStrings can have internal sections shorter than 255 + --,s (L.pack $ csb 600) (bsl s600) + , [trip [1 .. 100 :: Int16]] + -- See https://github.com/typelead/eta/issues/901 +#ifndef ETA_VERSION + , [trip longAsciiStrT] + , [trip longBoolListT] +#endif + , [trip asciiTextT] + , [trip english] + , [trip "维护和平正"] + , [trip (T.pack "abc")] + , [trip unicodeText] + , [trip unicodeTextUTF8T] + , [trip longBS, trip longLBS] +#ifndef ghcjs_HOST_OS + , [trip longSBS] +#endif +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) + , [trip unicodeTextUTF16T] +#endif + ] +--al = (1:) -- prealign + where + bsl = id -- noalign + + tstI = map ti + + ti v + | v >= 0 = testCase (unwords ["Int", show v]) + $ teq v (2 * fromIntegral v :: Word64) + | otherwise = testCase (unwords ["Int", show v]) + $ teq v (2 * fromIntegral (-v) - 1 :: Word64) + + teq a b = ser a @?= ser b + + --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v] + -- Aligned values unflat to the original value, modulo the added filler. + a v e = [ testCase (unwords ["flat", sshow v]) $ ser v @?= e + , testCase (unwords ["unflat", sshow v]) + $ let Right v' = des e + in v @?= v'] + + -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e + -- ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v'] +encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree] +encRaw v e = + [ testCase (unwords ["flat raw", sshow v, show . B.unpack . flat $ v]) + $ serRaw v @?= e] + +trip :: forall a. (Show a, Flat a, Eq a) => a -> TestTree +trip v = testCase (unwords ["roundtrip", sshow v]) + $ + -- direct comparison + (unflat (flat v :: B.ByteString) :: Decoded a) @?= (Right v :: Decoded a) + +tripShow :: forall a. (Show a, Flat a, Eq a) => a -> TestTree +tripShow v = testCase (unwords ["roundtrip", sshow v]) + $ + -- we use show to get Right NaN == Right NaN + show (unflat (flat v :: B.ByteString) :: Decoded a) + @?= show (Right v :: Decoded a) + +-- Test Data +lzBS = L.pack bs + +stBS = B.pack bs + +bs = [32, 32, 32 :: Word8] + +s3 = [3, 97, 98, 99, 0] + +c3a = [3, 99, 99, 99, 0] -- Array Word8 + +c3 = pre c3a + +s600 = pre s600a + +pre = (1:) + +s600a = concat [[255], csb 255, [255], csb 255, [90], csb 90, [0]] + +s600B = + concat [[55], csb 55, [255], csb 255, [90], csb 90, [200], csb 200, [0]] + +longSeq :: Seq.Seq Word8 +longSeq = Seq.fromList lbs + +longBS = B.pack lbs + +longLBS = L.concat $ concat $ replicate 10 [L.pack lbs] + +lbs = concat $ replicate 100 [234, 123, 255, 0] + +cs n = replicate n 'c' -- take n $ cycle ['a'..'z'] + +csb = map (fromIntegral . ord) . cs + +map1 = C.fromList [(False, True), (True, False)] + +ns :: [(Word64, Int)] +ns = [((-) (2 ^ (i * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]] + +nsI :: [(Int64, Int)] +nsI = nsI_ + +nsII :: [(Integer, Int)] +nsII = nsI_ + +nsI_ = [((-) (2 ^ (((-) i 1) * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]] + +#ifndef ghcjs_HOST_OS +shBS = SBS.toShort stBS + +longSBS = SBS.toShort longBS +#endif + +sshow = take 80 . show + +showB = show . B.unpack + +errDec :: forall a. (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree] + +--errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""] +errDec _ bs = [ testCase "bad decode" + $ let ev = (des bs :: Decoded a) + in isRight ev @?= False] + +ser :: Flat a => a -> [Word8] +ser = B.unpack . flat + +des :: Flat a => [Word8] -> Decoded a +des = unflat + +flatRawWith sz enc = B.unpack + $ E.strictEncoder (sz + 8) (E.Encoding $ enc >=> E.eFillerF) + +serRaw :: Flat a => a -> [Word8] + +-- serRaw = B.unpack . flatRaw +-- serRaw = L.unpack . flatRaw +serRaw = asBytes . bits + +--desRaw :: Flat a => [Word8] -> Decoded a +--desRaw = unflatRaw . L.pack +type RT a = a -> Bool + +type RTL a = Large a -> Bool + +prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool +prop_Flat_roundtrip = roundTripExt + +prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool +prop_Flat_Large_roundtrip (Large x) = roundTripExt x + +roundTrip x = unflat (flat x :: B.ByteString) == Right x + +-- Test roundtrip for both the value and the value embedded between bools +roundTripExt x = roundTrip x && roundTrip (True, x, False) + +prop_double_conv d = wordToDouble (doubleToWord d) == d + +prop_float_conv d = wordToFloat (floatToWord d) == d +{- +prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool +prop_common_unsigned n _ = let n2 :: h = fromIntegral n + in flat n == flat n2 +-} +-- e :: Stream Bool +-- e = unflatIncremental . flat $ stream1 +-- el :: List Bool +-- el = unflatIncremental . flat $ infList +-- deflat = unflat +-- b1 :: BLOB UTF8 +-- b1 = BLOB UTF8 (preAligned (List255 [97,98,99])) +-- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99]))) + + + + diff --git a/test/Test/Data.hs b/test/Test/Data.hs --- a/test/Test/Data.hs +++ b/test/Test/Data.hs @@ -1,43 +1,51 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + {- A collection of data types used for testing. -} - module Test.Data where import Data.Data import Data.Int import Data.Word import GHC.Generics -import qualified Test.Data2 as D2 --- import Test.Tasty.QuickCheck +import qualified Test.Data2 as D2 -data Void deriving Generic +-- import Test.Tasty.QuickCheck +data Void + deriving Generic -data X = X X deriving Generic +data X = X X + deriving Generic -data Unit = Unit deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Unit = Unit + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Un = Un {un::Bool} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Un = Un { un :: Bool } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data D2 = D2 Bool N deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data D2 = D2 Bool N + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data D4 = D4 Bool N Unit N3 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data D4 = D4 Bool N Unit N3 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- Enumeration -data N3 = N1 | N2 | N3 - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Enum) +data N3 = N1 + | N2 + | N3 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum) data N = One | Two @@ -47,10 +55,8 @@ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum, Bounded) -- toForestD :: Forest a -> ForestD (Tr2 a) - -- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt)) - -- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt)) - +-- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt)) toForest2 :: Forest a -> Forest2 a toForest2 (Forest f) = Forest2 (ForestD $ fmap toTr f) @@ -61,80 +67,114 @@ toTr2 (Tr a (Forest f)) = Tr2 (TrD a (ForestD $ fmap toTr2 f)) -- tying the recursive knot, equivalent to Forest/Tree -data Forest2 a = Forest2 (ForestD (TrD (Forest2 a) a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Tr2 a = Tr2 (TrD (ForestD (Tr2 a)) a) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Forest2 a = Forest2 (ForestD (TrD (Forest2 a) a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Tr2 a = Tr2 (TrD (ForestD (Tr2 a)) a) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + -- First-order non mutually recursive -data ForestD t = ForestD (List t) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data TrD f a = TrD a f deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data ForestD t = ForestD (List t) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data TrD f a = TrD a f + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + -- Explicit mutually recursive -data Forest a = Forest (List (Tr a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Tr a = Tr a (Forest a) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Forest a = Forest (List (Tr a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Tr a = Tr a (Forest a) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + data Words = Words Word8 Word16 Word32 Word64 - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) data Ints = Ints Int8 Int16 Int32 Int64 - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- non-recursive data type data Various = V1 (Maybe Bool) - -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N) + -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N) | V2 Bool (Either Bool (Maybe Bool)) | VF Float Double Double | VW Word Word8 Word16 Word32 Word64 | VI Int Int8 Int16 Int32 Int64 | VII Integer Integer Integer - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- Phantom type -data Phantom a = Phantom deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - +data Phantom a = Phantom + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- Recursive data types - -data RR a b c = RN {rna::a, rnb::b ,rnc::c} +data RR a b c = RN { rna :: a, rnb :: b, rnc :: c } | RA a (RR a a c) b | RAB a (RR c b a) b deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Expr = ValB Bool | Or Expr Expr | If Expr Expr Expr deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Expr = ValB Bool + | Or Expr Expr + | If Expr Expr Expr + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) data List a = C a (List a) | N - deriving (Eq, Ord, Read, Show, Typeable, Traversable, Data, Generic ,Generic1,Functor,Foldable) + deriving (Eq, Ord, Read, Show, Typeable, Traversable, Data, Generic, Generic1 + , Functor, Foldable) -data ListS a = Nil | Cons a (ListS a) - deriving (Eq, Ord, Read, Show, Typeable, Functor, Foldable, Traversable, Data, Generic ,Generic1) +data ListS a = Nil + | Cons a (ListS a) + deriving (Eq, Ord, Read, Show, Typeable, Functor, Foldable, Traversable, Data + , Generic, Generic1) -- non-regular Haskell datatypes like: -- Binary instances but no Model -data Nest a = NilN | ConsN (a, Nest (a, a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Nest a = NilN + | ConsN (a, Nest (a, a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data TN a = LeafT a | BranchT (TN (a,a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data TN a = LeafT a + | BranchT (TN (a, a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Bush a = NilB | ConsB (a, Bush (Bush a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Bush a = NilB + | ConsB (a, Bush (Bush a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + -- Perfectly balanced binary tree -data Perfect a = ZeroP a | SuccP (Perfect (Fork a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Fork a = Fork a a deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Perfect a = ZeroP a + | SuccP (Perfect (Fork a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Fork a = Fork a a + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + -- non regular with higher-order kind parameters -- no Binary/Model instances -data PerfectF f α = NilP | ConsP α (PerfectF f (f α)) deriving (Typeable,Generic) -- No Data +data PerfectF f α = NilP + | ConsP α (PerfectF f (f α)) + deriving (Typeable, Generic) -- No Data data Pr f g a = Pr (f a (g a)) -data Higher f a = Higher (f a) deriving (Typeable,Generic,Data) +data Higher f a = Higher (f a) + deriving (Typeable, Generic, Data) -- data Pr2 (f :: * -> *) a = Pr2 (f ) - -data Free f a = Pure a | Roll (f (Free f a)) deriving (Typeable,Generic) +data Free f a = Pure a + | Roll (f (Free f a)) + deriving (Typeable, Generic) -- mutual references -data A = A B | AA Int deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data B = B A | BB Char deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data A = A B + | AA Int + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data B = B A + | BB Char + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + -- recursive sets: -- Prob: ghc will just explode on this -- data MM1 = MM1 MM2 MM4 MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) @@ -144,66 +184,92 @@ -- data MM4 = MM4 MM4 MM2 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- data MM5 = MM5 Unit MM6 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- data MM6 = MM6 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - data A0 = A0 B0 B0 D0 Bool | A1 (List Bool) (List Unit) (D2.List Bool) (D2.List Bool) - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data B0 = B0 C0 | B1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data C0 = C0 A0 | C1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data D0 = D0 E0 | D1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data E0 = E0 D0 | E1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Even = Zero | SuccE Odd +data B0 = B0 C0 + | B1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data C0 = C0 A0 + | C1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data D0 = D0 E0 + | D1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data E0 = E0 D0 + | E1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Even = Zero + | SuccE Odd + data Odd = SuccO Even -- Existential types -- data Fold a b = forall x. Fold (x -> a -> x) x (x -> b) - -- data Some :: (* -> *) -> * where -- Some :: f a -> Some f - -- data Dict (c :: Constraint) where -- Dict :: c => Dict c -data Direction = North | South | Center | East | West - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Direction = North + | South + | Center + | East + | West + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) data Stream a = Stream a (Stream a) - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Functor,Foldable,Traversable) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Functor, Foldable + , Traversable) -data Tree a = Node (Tree a) (Tree a) | Leaf a - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable) +data Tree a = Node (Tree a) (Tree a) + | Leaf a + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable) -- Example schema from: http://mechanical-sympathy.blogspot.co.uk/2014/05/simple-binary-encoding.html -data Car = Car { - serialNumber::Word64 - ,modelYear::Word16 - ,available::Bool - ,code::CarModel - ,someNumbers::[Int32] - ,vehicleCode::String - ,extras::[OptionalExtra] - ,engine::Engine - ,fuelFigures::[Consumption] - ,performanceFigures :: [(OctaneRating,[Acceleration])] - ,make::String - ,carModel::String - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Car = + Car { serialNumber :: Word64 + , modelYear :: Word16 + , available :: Bool + , code :: CarModel + , someNumbers :: [Int32] + , vehicleCode :: String + , extras :: [OptionalExtra] + , engine :: Engine + , fuelFigures :: [Consumption] + , performanceFigures :: [(OctaneRating, [Acceleration])] + , make :: String + , carModel :: String + } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Acceleration = Acceleration {mph::Word16,seconds::Float} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Acceleration = Acceleration { mph :: Word16, seconds :: Float } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) type OctaneRating = Word8 -- minValue="90" maxValue="110" -data Consumption = Consumption {cSpeed::Word16,cMpg::Float} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Consumption = Consumption { cSpeed :: Word16, cMpg :: Float } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data CarModel = ModelA | ModelB | ModelC deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data CarModel = ModelA + | ModelB + | ModelC + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data OptionalExtra = SunRoof | SportsPack | CruiseControl deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data OptionalExtra = SunRoof + | SportsPack + | CruiseControl + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Engine = Engine { - capacity :: Word16 - ,numCylinders:: Word8 - ,maxRpm:: Word16 -- constant 9000 - ,manufacturerCode :: String - ,fuel::String -- constant Petrol - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Engine = Engine { capacity :: Word16 + , numCylinders :: Word8 + , maxRpm :: Word16 -- constant 9000 + , manufacturerCode :: String + , fuel :: String -- constant Petrol + } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/test/Test/Data/Arbitrary.hs b/test/Test/Data/Arbitrary.hs --- a/test/Test/Data/Arbitrary.hs +++ b/test/Test/Data/Arbitrary.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} --- {-# LANGUAGE TemplateHaskell , CPP#-} +{-# LANGUAGE CPP , ScopedTypeVariables #-} module Test.Data.Arbitrary where import qualified Data.ByteString as BS @@ -11,11 +10,21 @@ import Test.Data -- import Data.DeriveTH +-- #if MIN_VERSION_base(4,9,0) +import qualified Data.List.NonEmpty as BI +-- #endif + import Numeric.Natural (Natural) +-- #if MIN_VERSION_base(4,9,0) && MIN_VERSION_QuickCheck(2,10,0) +instance Arbitrary a => Arbitrary (BI.NonEmpty a) where + arbitrary = BI.fromList . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList a)) + shrink xs = BI.fromList <$> shrink (BI.toList xs) + instance Arbitrary Natural where arbitrary = arbitrarySizedNatural shrink = shrinkIntegral +-- #endif -- Copied from quickcheck-instances (not used directly as it requires old-time that is incompatible with ghcjs) @@ -31,13 +40,13 @@ arbitrary = SBS.pack <$> arbitrary shrink xs = SBS.pack <$> shrink (SBS.unpack xs) -instance Arbitrary TS.Text where - arbitrary = TS.pack <$> arbitrary - shrink xs = TS.pack <$> shrink (TS.unpack xs) +-- instance Arbitrary TS.Text where +-- arbitrary = TS.pack <$> arbitrary +-- shrink xs = TS.pack <$> shrink (TS.unpack xs) -instance Arbitrary TL.Text where - arbitrary = TL.pack <$> arbitrary - shrink xs = TL.pack <$> shrink (TL.unpack xs) +-- instance Arbitrary TL.Text where +-- arbitrary = TL.pack <$> arbitrary +-- shrink xs = TL.pack <$> shrink (TL.unpack xs) -- xxx = generate (arbitrary :: Gen (Large (Int))) @@ -58,6 +67,7 @@ -- instance Arbitrary Word7 where arbitrary = toEnum <$> choose (0, 127) -- derive makeArbitrary ''ASCII -- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta) + -- , run in the project directory: derive -a test/Test/Data.hs --derive=Arbitrary {-! deriving instance Arbitrary N diff --git a/test/Test/Data/Flat.hs b/test/Test/Data/Flat.hs --- a/test/Test/Data/Flat.hs +++ b/test/Test/Data/Flat.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE UndecidableInstances ,DeriveGeneric, FlexibleContexts, FlexibleInstances,StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances, DeriveGeneric + , FlexibleContexts, FlexibleInstances, StandaloneDeriving #-} + module Test.Data.Flat ( module Test.Data ) where -import Data.Flat -import Data.Flat.Encoder -import Data.Flat.Decoder + +import Flat +-- import Flat.Encoder +-- import Flat.Decoder import Test.Data import Test.Data2.Flat ( ) -import Data.Word -import Data.Foldable -import Data.Int -import GHC.Generics +-- import Data.Word +-- import Data.Foldable +-- import Data.Int +-- import GHC.Generics {- Compilation times: @@ -24,20 +27,37 @@ | 8.0.2 | NO | 4:18 | | 8.0.2 | YES | 4:18 | -} - -- GHC 8.0.2 chokes on this -- instance Flat A0 -- instance Flat B0 -- instance Flat C0 -- instance Flat D0 -- instance Flat E0 +deriving instance Generic (a, b, c, d, e, f, g, h) -deriving instance Generic (a,b,c,d,e,f,g,h) -deriving instance Generic (a,b,c,d,e,f,g,h,i) -instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g,Flat h) => Flat (a,b,c,d,e,f,g,h) -instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g,Flat h,Flat i) => Flat (a,b,c,d,e,f,g,h,i) +deriving instance Generic (a, b, c, d, e, f, g, h, i) +instance {-# OVERLAPPABLE #-}( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + , Flat h) => Flat (a, b, c, d, e, f, g, h) + +instance {-# OVERLAPPABLE #-}( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + , Flat h + , Flat i) => Flat (a, b, c, d, e, f, g, h, i) + instance Flat N + instance Flat Unit instance Flat a => Flat (List a) @@ -45,38 +65,40 @@ instance Flat a => Flat (Tree a) instance Flat Direction + instance Flat Words + instance Flat Ints + instance Flat Void instance Flat N3 + instance Flat Un instance Flat a => Flat (ListS a) instance Flat A + instance Flat B instance Flat D2 + instance Flat D4 instance Flat a => Flat (Phantom a) -- Slow to compile instance Flat Various - -- Custom instances -- instance {-# OVERLAPPING #-} Flat (Tree (N,N,N)) --where -- size (Node t1 t2) = 1 + size t1 + size t2 -- size (Leaf a) = 1 + size a - -- -57% -- instance {-# OVERLAPPING #-} Flat [N] -- where size = foldl' (\s n -> s + 1 + size n) 1 - -- instance {-# OVERLAPPING #-} Flat (N,N,N) -- where - -- {-# INLINE size #-} - -- size (n1,n2,n3) = size n1 + size n2 + size n3 - +-- {-# INLINE size #-} +-- size (n1,n2,n3) = size n1 + size n2 + size n3 -- -50% -- instance {-# OVERLAPPING #-} Flat (N,N,N) where -- {-# INLINE encode #-} @@ -88,22 +110,14 @@ -- Three -> eBitsF 2 2 -- Four -> eBitsF 3 6 -- Five -> eBitsF 3 7 - - -- instance (Flat a, Flat b, Flat c) => Flat (RR a b c) -- instance Flat a => Flat (Perfect a) -- instance Flat a => Flat (Fork a) -- instance Flat a => Flat (Nest a) --instance Flat a => Flat (Stream a) where decode = Stream <$> decode <*> decode -- instance Flat Expr - - - --instance (Flat a,Flat (f a),Flat (f (f a))) => Flat (PerfectF f a) - - -- instance Flat a => Flat (Stream a) - {- | | @@ -114,11 +128,9 @@ -- instance {-# OVERLAPPABLE #-} Flat a => Flat (Tree a) where -- encode (Node t1 t2) = eFalse <> encode t1 <> encode t2 -- encode (Leaf a) = eTrue <> encode a - -- instance {-# OVERLAPPING #-} Flat (Tree N) where -- encode (Node t1 t2) = eFalse <> encode t1 <> encode t2 -- encode (Leaf a) = eTrue <> encode a - -- -- -34% (why?) -- instance Flat N where -- {-# INLINE encode #-} @@ -128,62 +140,54 @@ -- Three -> eBits 2 2 -- Four -> eBits 3 6 -- Five -> eBits 3 7 - -- instance {-# OVERLAPPING #-} Flat (Tree N) - -- where - -- {-# INLINE decode #-} - -- decode = do - -- tag <- dBool - -- if tag - -- then Leaf <$> decode - -- else Node <$> decode <*> decode - +-- where +-- {-# INLINE decode #-} +-- decode = do +-- tag <- dBool +-- if tag +-- then Leaf <$> decode +-- else Node <$> decode <*> decode -- instance Flat N - -- where - -- {-# INLINE decode #-} - -- decode = do - -- tag <- dBool - -- if tag - -- then do - -- tag <- dBool - -- if tag - -- then do - -- tag <- dBool - -- if tag - -- then return Five - -- else return Four - -- else return Three - -- else do - -- tag <- dBool - -- if tag - -- then return Two - -- else return One - - -- {-# INLINE size #-} - -- size n s = s + case n of - -- One -> 2 - -- Two -> 2 - -- Three -> 2 - -- Four -> 3 - -- Five -> 3 - +-- where +-- {-# INLINE decode #-} +-- decode = do +-- tag <- dBool +-- if tag +-- then do +-- tag <- dBool +-- if tag +-- then do +-- tag <- dBool +-- if tag +-- then return Five +-- else return Four +-- else return Three +-- else do +-- tag <- dBool +-- if tag +-- then return Two +-- else return One +-- {-# INLINE size #-} +-- size n s = s + case n of +-- One -> 2 +-- Two -> 2 +-- Three -> 2 +-- Four -> 3 +-- Five -> 3 -- instance Flat N where -- instance {-# OVERLAPPING #-} Flat (Tree N) -- where - -- -- {-# INLINE encode #-} -- encode (Node t1 t2) = Writer $ \s -> do -- !s1 <- runWriter eFalse s -- !s2 <- runWriter (encode t1) s1 -- s3 <- runWriter (encode t2) s2 -- return s3 - - -- encode (Leaf a) = Writer $ \s -> do - -- s1 <- runWriter eTrue s - -- runWriter (encode a) s1 - +-- encode (Leaf a) = Writer $ \s -> do +-- s1 <- runWriter eTrue s +-- runWriter (encode a) s1 -- size (Node t1 t2) = 1 + size t1 + size t2 -- size (Leaf a) = 1 + size a - --instance Flat N diff --git a/test/Test/Data/Values.hs b/test/Test/Data/Values.hs --- a/test/Test/Data/Values.hs +++ b/test/Test/Data/Values.hs @@ -1,6 +1,8 @@ + {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NoMonomorphismRestriction , ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Data.Values where import Control.DeepSeq @@ -9,20 +11,21 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Short.Internal as SBS import Data.Char -import Data.Flat +import Flat import Data.Foldable import Data.Int -import Data.List +import qualified Data.IntMap as IM +-- import qualified Data.IntSet as IS +-- import Data.List import qualified Data.Map as M import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Word import Test.Data import qualified Test.Data2 as D2 -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -- import Data.Array as A + instance NFData Various instance NFData a => NFData (List a) instance NFData a => NFData (D2.List a) @@ -74,7 +77,8 @@ s1 = "a" s2 = "中文版本" s3 = ['A'..'z'] -s4 = Prelude.concatMap show [1..400] +s4 :: [Char] +s4 = Prelude.concatMap show [1::Int ..400] t1 = T.pack s1 t2 = T.pack s2 @@ -94,10 +98,10 @@ l1 = l2L $ take 11 [11::Word8,22..33] lBool :: List Bool -lBool = l2L $ map odd [1..99] +lBool = l2L $ map odd [1::Int ..99] lBool2 :: List Bool -lBool2 = l2L $ map odd [1..1000] +lBool2 = l2L $ map odd [1::Int ..1000] lBool0 = C False (C True (C True (C False (C False (C False (C True (C False (C True (C False (C True (C True (C False (C False (C False N)))))))))))))) @@ -155,7 +159,7 @@ treeN33Large :: Tree ((N,N,N),(N,N,N),(N,N,N)) treeN33Large = mkTree asN33 largeSize -treeVarious = mkTree (const v2) 100 +treeVarious = mkTree (const v2) (100::Int) mkTreeOf :: forall a. (Enum a ,Bounded a)=> Int -> Tree a mkTreeOf = let l = fromEnum (maxBound :: a) +1 @@ -181,10 +185,15 @@ treeN = mkTree asN3 1 -asciiStrT = ("asciiStr", longS $ "To hike, or not to hike? US Federal Reserve chair Janet Yellen faces a tricky decision at today's FOMC meeting. Photograph: Action Press/Rex. Theme park operator Merlin Entertainments suffered a significant drop in visitor numbers to its Alton Towers attraction after a serious rollercoaster accident in June.") +longAsciiStrT = ("asciiStr", longS english ) +asciiTextT = ("asciiText", T.pack $ longS english ) + unicodeTextUTF8T = ("unicodeTextUTF8",UTF8Text unicodeText) + +#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION) unicodeTextUTF16T = ("unicodeTextUTF16",UTF16Text unicodeText) +#endif unicodeTextT = ("unicodeText",unicodeText) unicodeText = T.pack unicodeStr @@ -193,12 +202,23 @@ unicodeStr = notLongS uniSS -uniSS = "\x1F600\&\x1F600\&\x1F600\&I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1].维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" +-- uniSS = "\x1F600\&\x1F600\&\x1F600\&I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1].维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" +uniSS = concat [special,latin,chinese] +special = "∀\&" +-- Crashes eta +-- emoji = "\x1F600" + +english = "To hike, or not to hike? US Federal Reserve chair Janet Yellen faces a tricky decision at today's FOMC meeting. Photograph: Action Press/Rex. Theme park operator Merlin Entertainments suffered a significant drop in visitor numbers to its Alton Towers attraction after a serious rollercoaster accident in June." +latin = "I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1]." +chinese = "维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" + longS = take 1000000 . concat . repeat notLongS = take 1000 . concat . repeat +longBoolListT = ("Long [Bool]",map (odd . ord) (longS uniSS) :: [Bool]) + arr0 = ("[Bool]",map (odd . ord) unicodeStr :: [Bool]) arr1 = ("[Word]",map (fromIntegral . ord) unicodeStr :: [Word]) @@ -303,7 +323,9 @@ , NF arr0 , NF longS , NF unicodeStr - , NF asciiStrT + , NF longBoolListT + , NF longAsciiStrT + , NF asciiTextT , NF unicodeStrT , NF unicodeTextT --, NF unicodeTextUTF8T diff --git a/test/Test/Data2/Flat.hs b/test/Test/Data2/Flat.hs --- a/test/Test/Data2/Flat.hs +++ b/test/Test/Data2/Flat.hs @@ -1,5 +1,5 @@ module Test.Data2.Flat(module Test.Data2) where -import Data.Flat +import Flat import Test.Data2 instance Flat a => Flat (List a) diff --git a/test/Test/E.hs b/test/Test/E.hs --- a/test/Test/E.hs +++ b/test/Test/E.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass ,CPP #-} module Test.E where -import Data.Flat +import Flat import Data.List import Control.DeepSeq -- import Data.Proxy diff --git a/test/Test/E/Flat.hs b/test/Test/E/Flat.hs --- a/test/Test/E/Flat.hs +++ b/test/Test/E/Flat.hs @@ -3,12 +3,12 @@ {-# LANGUAGE StandaloneDeriving #-} module Test.E.Flat() where -import Data.Flat -import Data.Flat.Decoder -import Data.Flat.Encoder +import Flat +import Flat.Decoder() +import Flat.Encoder() import Test.E -t = putStrLn $ gen 4 +-- t = putStrLn $ gen 4 -- Test only, incorrect instances -- Not faster than generated ones (at least up to E16)