flat (empty) → 0.2
raw patch · 33 files changed
+3753/−0 lines, 33 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, containers, cpu, deepseq, derive, dlist, flat, ghc-prim, mono-traversable, pretty, primitive, tasty, tasty-hunit, tasty-quickcheck, text, transformers, vector
Files
- LICENSE +30/−0
- README.md +159/−0
- Setup.hs +2/−0
- flat.cabal +99/−0
- src/Data/Flat.hs +16/−0
- src/Data/Flat/Bits.hs +57/−0
- src/Data/Flat/Class.hs +247/−0
- src/Data/Flat/Decoder.hs +36/−0
- src/Data/Flat/Decoder/Prim.hs +112/−0
- src/Data/Flat/Decoder/Strict.hs +245/−0
- src/Data/Flat/Decoder/Types.hs +130/−0
- src/Data/Flat/Encoder.hs +66/−0
- src/Data/Flat/Encoder/Prim.hs +371/−0
- src/Data/Flat/Encoder/Size.hs +178/−0
- src/Data/Flat/Encoder/Strict.hs +242/−0
- src/Data/Flat/Encoder/Types.hs +25/−0
- src/Data/Flat/Filler.hs +58/−0
- src/Data/Flat/Instances.hs +213/−0
- src/Data/Flat/Memory.hs +81/−0
- src/Data/Flat/Run.hs +59/−0
- src/Data/Flat/Types.hs +29/−0
- src/Data/FloatCast.hs +46/−0
- src/Data/ZigZag.hs +66/−0
- stack.yaml +26/−0
- stack801.yaml +22/−0
- stack802.yaml +23/−0
- test/Spec.hs +365/−0
- test/Test/Data.hs +205/−0
- test/Test/Data/Arbitrary.hs +40/−0
- test/Test/Data/Flat.hs +187/−0
- test/Test/Data/Values.hs +301/−0
- test/Test/Data2.hs +12/−0
- test/Test/Data2/Flat.hs +5/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Pasqualino `Titto` Assini ++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,159 @@++[](https://travis-ci.org/tittoassini/flat) [](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` (or equivalently: `flatStrict` and `unflatStrict`):++```haskell+unflatStrict . 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 [typed](https://github.com/tittoassini/typed).++#### 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/tittoassini/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`.++### 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`, `cereal` and `flat` are usually faster++ One thing that is not shown by the benchmarks is that, if the serialized data is to be transferred over a network, the total total transfer time (encoding time + transmission time + decoding time) is usually dominated by the transmission time and that's where the smaller binaries produced by flat give it a significant advantage.++ Consider for example the Cars dataset. As you can see in the following comparison with `store`, the overall top performer for encoding/decoding speed, the total transfer time is actually significantly lower for `flat` for all except the highest transmission speeds.++||Store|Flat|+|---|---|---|+|Encoding (mSec)| 3.1| 7.0|+|Decoding (mSec)| 22.6| 30.0|+|Size (bytes)|702728|114841|+|Transmission (mSec) @ 1 MegaByte/Sec|702.7|114.8|+|Transmission (mSec) @ 10 MegaByte/Sec| 70.3| 11.5|+|Transmission (mSec) @ 100 MegaByte/Sec| 7.0| 1.1|+|Total Transfer (mSec) @ 1 MegaByte/Sec|728.4|151.8|+|Total Transfer (mSec) @ 10 MegaByte/Sec| 96.0| 48.5|+|Total Transfer (mSec) @ 100 MegaByte/Sec| 32.7| 38.1|+++### Haskell Compatibility++Tested with:+ * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1 and 8.0.2 (x64)+ * [ghc](https://www.haskell.org/ghc/) 7.10.3/LLVM 3.5.2 (Arm7)+ * [ghcjs](https://github.com/ghcjs/ghcjs)++### Installation++Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat).++### Acknowledgements++ `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary`.++### Known Bugs and Infelicities++* A performance issue with GHC 8.0.2 for some data types++* Longish compilation times for generated Flat instances+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ flat.cabal view
@@ -0,0 +1,99 @@+name: flat+version: 0.2+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini+maintainer: tittoassini@gmail.com+homepage: http://github.com/tittoassini/flat+synopsis: Principled and efficient bit-oriented binary serialization.+description: See http\://github.com/tittoassini/flat for a tutorial+category: Data,Parsing,Serialization+author: Pasqualino `Titto` Assini+tested-with: GHC ==7.10.3 GHC ==8.0.2+extra-source-files:+ stack.yaml+ stack801.yaml+ stack802.yaml+ README.md++source-repository head+ type: git+ location: https://github.com/tittoassini/flat++library+ exposed-modules:+ 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.Instances+ Data.Flat.Memory+ Data.Flat.Run+ Data.Flat.Types+ Data.Flat+ Data.FloatCast+ Data.ZigZag+ build-depends:+ array >=0.5.1.0,+ base >=4.8 && <5,+ bytestring >=0.10.6.0,+ containers >=0.5.6.2,+ cpu >=0.1.2,+ deepseq >=1.4.1.1,+ dlist >=0.7.1.2,+ ghc-prim >=0.3.1,+ mono-traversable >=1.0.1,+ pretty >=1.1.2.0,+ primitive >=0.6.1.0,+ text >=1.2.2.1,+ transformers >=0.4.2.0,+ vector >=0.11.0.0+ default-language: Haskell2010+ default-extensions: CPP+ other-extensions: DataKinds DefaultSignatures DeriveAnyClass+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable+ FlexibleContexts FlexibleInstances NoMonomorphismRestriction+ OverloadedStrings PolyKinds ScopedTypeVariables TupleSections+ TypeFamilies TypeOperators UndecidableInstances+ hs-source-dirs: src+ ghc-options: -O2 -funbox-strict-fields -Wall -fno-warn-orphans -fno-warn-name-shadowing++test-suite flat-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-depends:+ base >=4.8 && <5,+ cpu >=0.1.2,+ ghc-prim >=0.3.1.0,+ tasty >=0.11.0.2,+ tasty-hunit >=0.9.2,+ tasty-quickcheck >=0.8.4,+ pretty >=1.1.2.0,+ containers >=0.5.6.2,+ derive >=2.5.26,+ text >=1.2.2.1,+ bytestring >=0.10.6.0,+ deepseq >=1.4.1.1,+ text >=1.2.2.1,+ flat >=0.1.3+ default-language: Haskell2010+ hs-source-dirs: test+ cpp-options: -DLIST_BIT+ other-modules:+ Test.Data+ Test.Data2+ Test.Data.Arbitrary+ Test.Data.Flat+ Test.Data2.Flat+ Test.Data.Values+
+ src/Data/Flat.hs view
@@ -0,0 +1,16 @@+module Data.Flat (+ -- |Check the <https://github.com/tittoassini/flat tutorial and github repo>.+ module X,+ UTF8Text(..),+ UTF16Text(..),+ Get,+ Decoded,+ DecodeException,+ ) where++import Data.Flat.Class as X+import Data.Flat.Decoder+import Data.Flat.Filler as X+import Data.Flat.Instances as X+import Data.Flat.Run as X+import Data.Flat.Types
+ src/Data/Flat/Bits.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- |Utilities to represent and display bit sequences+module Data.Flat.Bits (Bits, toBools, bits, paddedBits, asBytes) where++import Data.Bits hiding (Bits)+import qualified Data.ByteString as L+import Data.Flat.Decoder+import Data.Flat.Class+import Data.Flat.Filler+import Data.Flat.Run+-- import Data.Int+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++-- |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 * L.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 * L.length lbs) lbs++takeBits :: Int -> L.ByteString -> V.Vector Bool+takeBits numBits lbs = V.generate (fromIntegral numBits) (\n -> let (bb,b) = n `divMod` 8 in testBit (L.index lbs (fromIntegral bb)) (7-b))++-- |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+
+ src/Data/Flat/Class.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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.Flat.Decoder (Get, dBool)+import Data.Flat.Encoder+import Data.Proxy+import GHC.Generics+import GHC.TypeLits+import Prelude hiding (mempty)+-- import GHC.Magic(inline)++-- |Class of types that can be encoded/decoded+class Flat a where++ {-# INLINE encode #-}+ encode :: a -> Encoding+ default encode :: (Generic a, GEncode (Rep a)) => a -> Encoding+ encode = genericEncode++ {-# INLINE decode #-}+ decode :: Get a+ default decode :: (Generic a, GDecode (Rep a)) => Get a+ decode = genericDecode++ {-# INLINE size #-}+ size :: a -> NumBits -> NumBits+ default size :: (Generic a, GSize (Rep a)) => a -> NumBits -> NumBits+ size = genericSize++{-# INLINE genericEncode #-}+genericEncode :: (GEncode (Rep a), Generic a) => a -> Encoding+genericEncode = gencode . from++{-# INLINE genericDecode #-}+genericDecode :: (GDecode (Rep b), Generic b) => Get b+genericDecode = to `fmap` gget++{-# INLINE genericSize #-}+genericSize :: (GSize (Rep a), Generic a) => a -> NumBits -> NumBits+genericSize !x !n = gsize n $ from x++-- |Calculate the size in bits of the serialisation of the value+getSize :: Flat a => a -> NumBits+getSize a = size a 0++-- |Generic Encoder+class GEncode f where+ gencode :: f t -> Encoding++-- Metadata (constructor name, etc)+instance {-# OVERLAPPABLE #-} GEncode a => GEncode (M1 i c a) where+ gencode = gencode . unM1+ {-# INLINE gencode #-}++-- Special case, single constructor datatype+instance {-# OVERLAPPING #-} (GEncoders a) => GEncode (D1 i (C1 c a)) where+ gencode !x = encodersS $ gencoders x id []+ {-# INLINE gencode #-}++-- Type without constructors+instance GEncode V1 where+ gencode _ = unused+ {-# INLINE gencode #-}++-- Constructor without arguments+instance GEncode U1 where+ gencode U1 = mempty+ {-# INLINE gencode #-}++-- Product: constructor with parameters+instance GEncode (a :*: b) where+ gencode _ = unused+ {-# INLINE gencode #-}++-- Constants, additional parameters, and rank-1 recursion+instance Flat a => GEncode (K1 i a) where+ --gencode = inline encode . unK1+ gencode = encode . unK1+ {-# INLINE gencode #-}++-- Build constructor representation as single tag+instance (NumConstructors (a :+: b) <= 255, GEncodeSum 0 0 (a :+: b)) => GEncode (a :+: b) where+ gencode x = gencodeSum x (Proxy :: Proxy 0) (Proxy :: Proxy 0)+ {-# INLINE gencode #-}+++class GEncoders f where+ -- |Determine the list of encoders corresponding to a type+ gencoders :: f t -> ([Encoding] -> [Encoding]) -> ([Encoding] -> [Encoding])++instance {-# OVERLAPPABLE #-} GEncoders a => GEncoders (M1 i c a) where+ gencoders m !l = gencoders (unM1 m) l+ {-# INLINE gencoders #-}++instance {-# OVERLAPPING #-} GEncoders a => GEncoders (D1 i (C1 c a)) where+ gencoders x !l = gencoders (unM1 . unM1 $ x) l+ {-# INLINE gencoders #-}++-- Type without constructors+instance GEncoders V1 where+ gencoders _ _ = unused++-- Constructor without arguments+instance GEncoders U1 where+ gencoders U1 !l = l+ {-# INLINE gencoders #-}++-- Constants, additional parameters, and rank-1 recursion+instance Flat a => GEncoders (K1 i a) where+ gencoders k !l = l . (gencode k :)+ {-# INLINE gencoders #-}++-- Product: constructor with parameters+instance (GEncoders a, GEncoders b) => GEncoders (a :*: b) where+ gencoders (x :*: y) !l = gencoders y (gencoders x l)+ {-# INLINE gencoders #-}++class (KnownNat code, KnownNat numBits) =>+ GEncodeSum (numBits:: Nat) (code :: Nat) (f :: * -> *) where+ gencodeSum :: f a -> Proxy numBits -> Proxy code -> Encoding++instance (GEncodeSum (n+1) (m*2) a,GEncodeSum (n+1) (m*2+1) b, KnownNat n,KnownNat m)+ => GEncodeSum n m (a :+: b) where+ gencodeSum !x _ _ = case x of+ L1 l -> gencodeSum l (Proxy :: Proxy (n+1)) (Proxy :: Proxy (m*2))+ R1 r -> gencodeSum r (Proxy :: Proxy (n+1)) (Proxy :: Proxy (m*2+1))+ {-# INLINE gencodeSum #-}++instance (GEncoders a, KnownNat n,KnownNat m) => GEncodeSum n m (C1 c a) where+ {-# INLINE gencodeSum #-}+ gencodeSum !x _ _ = encodersS $ gencoders x (eBits numBits code:) []+ where+ numBits = fromInteger (natVal (Proxy :: Proxy n))+ code = fromInteger (natVal (Proxy :: Proxy m))++-- |Calculate number of constructors+type family NumConstructors (a :: * -> *) :: Nat where+ NumConstructors (C1 c a) = 1+ NumConstructors (x :+: y) = NumConstructors x + NumConstructors y++-- 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+ gget = K1 <$> decode+ {-# INLINE gget #-}++-- Build constructor representation as single tag+instance (GDecode a, GDecode b) => GDecode (a :+: b) where+ gget = do+ !tag <- dBool+ !r <- if tag then R1 <$> gget else L1 <$> gget+ return r+ {-# INLINE gget #-}++-- |Calculate the size of a value in bits+class GSize f where gsize :: NumBits -> f a -> NumBits++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 #-}++instance Flat a => GSize (K1 i a) where+ gsize !n x = size (unK1 x) n+ {-# INLINE gsize #-}++instance (GSize a, GSize b) => GSize (a :*: b) where+ gsize !n (x :*: y) = gsize (gsize n x) y+ {-# INLINE gsize #-}++instance (NumConstructors (a :+: b) <= 255, GSizeSum 0 (a :+: b)) => GSize (a :+: b) where+ gsize !n x = gsizeSum n x (Proxy :: Proxy 0)+ {-# INLINE gsize #-}++-- |Calculate size in bits of constructor+class KnownNat n => GSizeSum (n :: Nat) (f :: * -> *) where gsizeSum :: NumBits -> f a -> Proxy n -> NumBits++instance (GSizeSum (n + 1) a, GSizeSum (n + 1) b, KnownNat n)+ => GSizeSum n (a :+: b) where+ gsizeSum !n x _ = case x of+ L1 !l -> gsizeSum n l (Proxy :: Proxy (n+1))+ R1 !r -> gsizeSum n r (Proxy :: Proxy (n+1))+ {-# INLINE gsizeSum #-}++instance (GSize a, KnownNat n) => GSizeSum n (C1 c a) where+ {-# INLINE gsizeSum #-}+ gsizeSum !n !x _ = gsize (constructorSize + n) x+ where+ constructorSize = fromInteger (natVal (Proxy :: Proxy n))++unused :: forall a . a+unused = error $ "Now, now, you could not possibly have meant this.."
+ src/Data/Flat/Decoder.hs view
@@ -0,0 +1,36 @@+-- |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,+ ) where++import Data.Flat.Decoder.Prim+import Data.Flat.Decoder.Strict+import Data.Flat.Decoder.Types
+ src/Data/Flat/Decoder/Prim.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |Strict Decoder Primitives+module Data.Flat.Decoder.Prim (+ dBool,+ dWord8,+ dFloat,+ dDouble,+ getChunksInfo,+ dByteString_,+ dLazyByteString_,+ dByteArray_+ ) 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.Memory+import Data.FloatCast+import Data.Word+import Foreign+import System.Endian++{-# INLINE dBool #-}+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 `shiftR` usedBits s))+ -- let b = testBit w (7-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 dWord8 #-}+dWord8 :: Get Word8+dWord8 = Get $ \endPtr s -> do+ ensureBits endPtr s 8+ !w <- if usedBits s == 0+ then peek (currPtr s)+ else do+ !w1 <- peek (currPtr s)+ !w2 <- peek (currPtr s `plusPtr` 1)+ return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w++{-# INLINE ensureBits #-}+ensureBits :: Ptr Word8 -> S -> Int -> IO ()+ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s++-- {-# INLINE incBits #-}+-- incBits :: Int -> S -> S+-- incBits 1 s = if usedBits s == 7+-- then s {currPtr=currPtr s `plusPtr` 1,usedBits=0}+-- else s {usedBits=usedBits s+1}++-- incBits 8 s = s {currPtr=currPtr s `plusPtr` 1}++{-# INLINE dFloat #-}+dFloat :: Get Float+dFloat = Get $ \endPtr s -> do+ ensureBits endPtr s 32+ !w <- if usedBits s == 0+ then toBE32 <$> peek (castPtr $ currPtr s)+ else do+ !w1 <- toBE32 <$> peek (castPtr $ currPtr s)+ !(w2::Word8) <- peek (currPtr s `plusPtr` 4)+ return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) (wordToFloat w)++{-# INLINE dDouble #-}+dDouble :: Get Double+dDouble = Get $ \endPtr s -> do+ ensureBits endPtr s 64+ !w <- if usedBits s == 0+ then toBE64 <$> peek (castPtr $ currPtr s)+ else do+ !w1 <- toBE64 <$> peek (castPtr $ currPtr s)+ !(w2::Word8) <- peek (currPtr s `plusPtr` 8)+ return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) (wordToDouble w)++dLazyByteString_ :: Get L.ByteString+dLazyByteString_ = L.fromStrict <$> dByteString_++dByteString_ :: Get B.ByteString+dByteString_ = chunksToByteString <$> getChunksInfo++dByteArray_ :: Get (ByteArray,Int)+dByteArray_ = chunksToByteArray <$> getChunksInfo++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+ (currPtr',ns) <- getChunks (currPtr s) id+ return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns)
+ src/Data/Flat/Decoder/Strict.hs view
@@ -0,0 +1,245 @@+{-# 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_
+ src/Data/Flat/Decoder/Types.hs view
@@ -0,0 +1,130 @@+{-# 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)++-- 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 = getException+ -- {-# 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+ 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 -> IO a+badEncoding endPtr s = throwIO $ BadEncoding (endPtr,s)++instance Exception DecodeException++
+ src/Data/Flat/Encoder.hs view
@@ -0,0 +1,66 @@+module Data.Flat.Encoder (+ Encoding,+ (<>),+ NumBits,+ encodersS,+ mempty,+ strictEncoder,+ eTrueF,+ eFalseF,+ eFloat,+ eDouble,+ eInteger,+ eNatural,+ eWord16,+ eWord32,+ eWord64,+ eWord8,+ eBits,+ 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
+ src/Data/Flat/Encoder/Prim.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UnboxedTuples #-}+-- |Encoding Primitives+module Data.Flat.Encoder.Prim (+ 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,+ ) 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.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 System.Endian++-- 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 `shiftR` 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 (fromIntegral w `shiftL` 24 .|. t `shiftR` o) >> return (S (plusPtr op 4) (fromIntegral t `shiftL` (8-o)) o)++{-# INLINE eWord64E #-}+eWord64E :: (Word64 -> Word64) -> Word64 -> Prim+eWord64E conv t (S op w o) | o==0 = pokeW conv op t >> skipBytes op 8+ | otherwise = pokeW conv op (fromIntegral w `shiftL` 56 .|. t `shiftR` o) >> return (S (plusPtr op 8) (fromIntegral t `shiftL` (8-o)) o)++{-# 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 `shiftR` 7) .&. 0x7F)++ {-# INLINE varWord3_ #-}+ varWord3_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `shiftR` 7) .|. 0x80) >>= writeByte (fromIntegral (t `shiftR` 14) .&. 0x7F)++-- {-# INLINE varWordN #-}+varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim+varWordN_ writeByte = go+ where+ go !v !st =+ let !l = low7 v+ !v' = v `shiftR` 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+++{-+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+-}+-- CHECK: might get rid of this altogether and in Class encode in terms of eTrue/eFalse only+-- |Encode up to 8 bits.+{-# INLINE eBitsF #-}+eBitsF :: NumBits -> Word8 -> Prim+eBitsF 1 0 = eFalseF+eBitsF 1 1 = eTrueF+eBitsF 2 0 = eFalseF >=> eFalseF+eBitsF 2 1 = eFalseF >=> eTrueF+eBitsF 2 2 = eTrueF >=> eFalseF+eBitsF 2 3 = eTrueF >=> eTrueF+eBitsF n t = \(S op w o) ->+ let o' = o + n -- used bits+ f = 8 - o' -- remaining free bits+ in if | f > 0 -> return $ S op (w .|. (t `shiftL` f)) o'+ | f == 0 -> pokeWord op (w .|. t)+ | otherwise -> let o'' = -f+ in poke op (w .|. (t `shiftR` o'')) >> return (S (plusPtr op 1) (t `shiftL` (8-o'')) o'')++{-# 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 (setBit w (7-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 `shiftR` o)) >> return (S (plusPtr op 1) (t `shiftL` (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 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)
+ src/Data/Flat/Encoder/Size.hs view
@@ -0,0 +1,178 @@+{-# 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)
+ src/Data/Flat/Encoder/Strict.hs view
@@ -0,0 +1,242 @@+{-# 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.Memory+import Data.Flat.Encoder.Prim+import qualified Data.Flat.Encoder.Size as S+import Data.Flat.Encoder.Types+import Data.Flat.Types+import Data.Foldable+import Data.Monoid++-- |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 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+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
+ src/Data/Flat/Encoder/Types.hs view
@@ -0,0 +1,25 @@+-- |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+
+ src/Data/Flat/Filler.hs view
@@ -0,0 +1,58 @@+{-# 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 dec = do+ v <- dec+ _::Filler <- decode+ return (postAligned v)
+ src/Data/Flat/Instances.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+-- |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)++-- Do not provide this to 'force' users to declare instances of concrete list types+instance {-# OVERLAPPABLE #-} Flat a => Flat [a]+instance {-# OVERLAPPING #-} Flat [Char]++-- instance 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 (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
+ src/Data/Flat/Memory.hs view
@@ -0,0 +1,81 @@+{-# 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+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 (sourcePtr,lens) =+ BS.unsafeCreate (sum lens) $ \destPtr -> void $ foldM (\(destPtr,sourcePtr) sourceLength -> BS.memcpy destPtr sourcePtr sourceLength >> return (destPtr `plusPtr` sourceLength,sourcePtr `plusPtr` (sourceLength+1))) (destPtr,sourcePtr) lens++chunksToByteArray :: (Ptr Word8,[Int]) -> (ByteArray,Int)+chunksToByteArray (sourcePtr,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,sourcePtr) 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 #-}
+ src/Data/Flat/Run.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+-- |Encoding and decoding functions+module Data.Flat.Run (+ flat,+ flatStrict,+ unflat,+ unflatStrict,+ unflatWith,+ unflatRaw,+ --unflatRawWith,+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Flat.Class+import Data.Flat.Decoder+import qualified Data.Flat.Encoder as E+import Data.Flat.Filler++-- |Strictly encode padded value.+flatStrict :: Flat a => a -> B.ByteString+flatStrict = flat++-- |Encode padded value.+flat :: (FlatRaw (PostAligned a) c, Flat a) => a -> c+flat = flatRaw . postAligned++unflatStrict :: Flat a => B.ByteString -> Decoded a+unflatStrict = unflat++-- |Decode padded value.+unflat :: (FlatRaw (PostAligned a) b, Flat a) => b -> Decoded a+unflat = unflatWith decode++-- |Decode padded value, using the provided decoder.+unflatWith :: FlatRaw (PostAligned a) b => Get (PostAligned a) -> b -> Decoded a+unflatWith dec bs = postValue <$> unflatRawWith dec bs++-- |Decode (unpadded) value.+unflatRaw :: (FlatRaw a b, Flat a) => b -> Decoded a+unflatRaw = unflatRawWith decode++class FlatRaw a b where+ -- |Encode (unpadded) value+ flatRaw :: Flat a => a -> b++ -- |Unflat (unpadded) value, using provided decoder+ unflatRawWith :: Get a -> b -> Decoded a++instance Flat a => FlatRaw a B.ByteString where+ flatRaw a = E.strictEncoder (getSize a) (encode a)++ unflatRawWith = strictDecoder++instance Flat a => FlatRaw a L.ByteString where+ flatRaw = L.fromStrict . flatRaw+ unflatRawWith dec = unflatRawWith dec . L.toStrict
+ src/Data/Flat/Types.hs view
@@ -0,0 +1,29 @@+{-# 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++-- ?FIX: Should be Int64 or Word64+-- |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)
+ src/Data/FloatCast.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+-- | Primitives to convert between Float/Double and Word32/Word64+-- | This code was copied from `binary`+-- | This module was written based on+-- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.+--+-- Implements casting via a 1-element STUArray, as described in+-- <http://stackoverflow.com/a/7002812/263061>.+module Data.FloatCast+ ( floatToWord+ , wordToFloat+ , doubleToWord+ , wordToDouble+ ) where++import Data.Word (Word32, Word64)+import Data.Array.ST (newArray, readArray, MArray, STUArray)+import Data.Array.Unsafe (castSTUArray)+import GHC.ST (runST, ST)++-- | Reinterpret-casts a `Float` to a `Word32`.+floatToWord :: Float -> Word32+floatToWord x = runST (cast x)+{-# INLINE floatToWord #-}++-- | Reinterpret-casts a `Double` to a `Word64`.+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+{-# INLINE doubleToWord #-}++-- | Reinterpret-casts a `Word32` to a `Float`.+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}++-- | Reinterpret-casts a `Word64` to a `Double`.+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast x)+{-# INLINE wordToDouble #-}++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 #-}
+ src/Data/ZigZag.hs view
@@ -0,0 +1,66 @@+module Data.ZigZag(zzEncode,zzEncodeInteger,zzDecode8,zzDecode16,zzDecode32,zzDecode64,zzDecodeInteger,zzDecode) where++import Data.Word+import Data.Int+import Data.Bits++{-# 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)))++--{-# INLINE zzEncode8 #-}+--zzEncode8 :: Int8 -> Word8+-- zzEncode8 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 7))++-- {-# INLINE zzEncode16 #-}+-- zzEncode16 :: Int16 -> Word16+-- zzEncode16 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 15))++-- {-# INLINE zzEncode32 #-}+-- zzEncode32 :: Int32 -> Word32+-- zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 31))++-- {-# INLINE zzEncode64 #-}+-- zzEncode64 :: Int64 -> Word64+-- zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63))++{-# INLINE zzEncodeInteger #-}+zzEncodeInteger :: Integer -> Integer+zzEncodeInteger x | x>=0 = x `shiftL` 1+ | otherwise = negate (x `shiftL` 1) - 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 #-}++{-# 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)))++{-# INLINE zzDecode8 #-}+zzDecode8 :: Word8 -> Int8+zzDecode8 = zzDecode++{-# INLINE zzDecode16 #-}+zzDecode16 :: Word16 -> Int16+zzDecode16 = zzDecode++{-# INLINE zzDecode32 #-}+zzDecode32 :: Word32 -> Int32+zzDecode32 = zzDecode++{-# INLINE zzDecode64 #-}+zzDecode64 :: Word64 -> Int64+zzDecode64 = zzDecode++{-# INLINE zzDecodeInteger #-}+zzDecodeInteger :: Integer -> Integer+zzDecodeInteger = zzDecode++
+ stack.yaml view
@@ -0,0 +1,26 @@+# pvp-bounds: lower++flags:+ binary-serialise-cbor:+ newtime15: true+extra-package-dbs: []+packages:+- '.'++- location:+ git: https://github.com/well-typed/binary-serialise-cbor+ commit: 5e2f20c0a2d8fd750f431af9a17ba116a6f31cf0+ extra-dep: true++# ghc-7.10.3+resolver: lts-6.30+extra-deps:+- mono-traversable-1.0.2+- store-0.4.1+- store-core-0.4+- binary-0.8.5.1+- cereal-0.5.4.0+- th-utilities-0.2.0.1+- criterion-1.1.4.0+- optparse-applicative-0.13.0.0+
+ stack801.yaml view
@@ -0,0 +1,22 @@+flags:+ binary-serialise-cbor:+ newtime15: true++extra-package-dbs: []++packages:+- '.'++- location:+ git: https://github.com/well-typed/binary-serialise-cbor+ commit: 5e2f20c0a2d8fd750f431af9a17ba116a6f31cf0+ extra-dep: true+ +# 8.0.1+resolver: lts-7.20+extra-deps:+- store-0.4.1+- store-core-0.4+- binary-0.8.5.1+- criterion-1.1.4.0+- optparse-applicative-0.13.2.0
+ stack802.yaml view
@@ -0,0 +1,23 @@+flags:+ binary-serialise-cbor:+ newtime15: true++extra-package-dbs: []++packages:+- '.'++- location:+ git: https://github.com/well-typed/binary-serialise-cbor+ commit: 5e2f20c0a2d8fd750f431af9a17ba116a6f31cf0+ extra-dep: true+ +# 8.0.2 - doesn't compile heavily mutually recursive data types.+# low performance on certain tests as encoder RULES are not applied+resolver: lts-8.5+extra-deps:+- store-0.4.1+- store-core-0.4+- binary-0.8.5.1+- derive-2.6.2+
+ test/Spec.hs view
@@ -0,0 +1,365 @@+{-# 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 qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS+import Data.Char+import Data.DeriveTH+import Data.Either+import Data.Flat+import Data.Flat.Bits+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.Arch+import System.Endian+import System.Exit+import Test.Data+import Test.Data.Arbitrary+import Test.Data.Flat+import Test.Data.Values+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC++main = do+ printInfo+ mainTest+-- main = mainShow++printInfo = do+ print getSystemArch+ print getSystemEndianness++mainShow = do+ mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1..10]+ exitFailure++mainTest = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [properties+ ,unitTests+ ]++properties = testGroup "Properties"+ [ rt "()" (prop_Flat_roundtrip:: RT ())+ ,rt "Bool" (prop_Flat_roundtrip::RT Bool)+ ,rt "(Bool,Word8,Bool)" (prop_Flat_roundtrip:: RT (Bool,Word8,Bool))+ ,rt "Word8" (prop_Flat_Large_roundtrip:: RTL Word8)+ ,rt "Word16" (prop_Flat_Large_roundtrip:: RTL Word16)+ ,rt "Word32" (prop_Flat_Large_roundtrip:: RTL Word32)+ ,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 "(Bool,Integer)" (prop_Flat_roundtrip:: RT (Bool,Integer))+ ,rt "Float" (prop_Flat_roundtrip:: RT Float)+ ,rt "(Bool,Float)" (prop_Flat_roundtrip:: RT (Bool,Float))+ ,rt "Double" (prop_Flat_roundtrip:: RT Double)+ ,rt "(Bool,Double)" (prop_Flat_roundtrip:: RT (Bool,Double))+ ,rt "Char" (prop_Flat_roundtrip:: RT Char)+ ,rt "(Bool,Char)" (prop_Flat_roundtrip:: RT (Bool,Char))+ --,rt "ASCII" (prop_Flat_roundtrip:: RT ASCII)+ ,rt "Unit" (prop_Flat_roundtrip:: RT Unit)+ ,rt "Un" (prop_Flat_roundtrip:: RT Un )+ ,rt "N" (prop_Flat_roundtrip:: RT N )+ ,rt "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)+ ,rt "Short ByteString" (prop_Flat_roundtrip:: RT SBS.ShortByteString)+ ]+ where rt n = QC.testProperty (unwords ["round trip",n])++instance Flat [Int16]+instance Flat [Word8]+instance Flat [Bool]++unitTests = testGroup "De/Serialisation Unit tests" $ concat [+ sz () 0+ ,sz True 1+ ,sz One 2+ ,sz Two 2+ ,sz Three 2+ ,sz Four 3+ ,sz Five 3+ ,sz 'a' 8+ ,sz 'à' 16+ ,sz '经' 24+ ,sz (0::Word8) 8+ ,sz (1::Word8) 8+ ,concat $ map (uncurry sz) $ ns+ ,concat $ map (uncurry sz) $ nsI+ ,concat $ map (uncurry sz) $ nsII+ ,sz (1.1::Float) 32+ ,sz (1.1::Double) 64+ ,sz "" 1+ ,sz "abc" (4+3*8)+ ,sz ((),(),Unit) 0+ ,sz (True,False,One,Five) 7+ ,sz map1 7+ ,sz bs (4+3*8)+ ,sz stBS bsSize+ ,sz lzBS bsSize+ ,sz shBS bsSize+ ,sz tx utf8Size+ ,sz (UTF8Text tx) utf8Size+ ,sz (UTF16Text tx) utf16Size+ ,errDec (Proxy::Proxy Bool) [] -- no data+ ,errDec (Proxy::Proxy Bool) [128] -- no filler+ ,errDec (Proxy::Proxy Bool) [128+1,1,2,4,8] -- additional bytes+ ,s () []+ ,s ((),(),Unit) []+ ,s (Unit,'a',Unit,'a',Unit,'a',Unit) [97,97,97]+ ,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]+ ,s (True,False,True,True) [128+32+16]+ ,s ((True,True,False,True,False),(False,False,True,False,True,True)) [128+64+16+1,64+32]+ ,s ('\0','\1','\127') [0,1,127]+ ,s (33::Word32,44::Word32) [33,44]+ --,s (Elem True) [64]+ --,s (NECons True (NECons False (Elem True))) [128+64+32+4]+ ,s (0::Word8) [0]+ ,s (1::Word8) [1]+ ,s (255::Word8) [255]+ ,s (0::Word16) [0]+ ,s (1::Word16) [1]+ ,s (255::Word16) [255,1]+ ,s (256::Word16) [128,2]+ ,s (65535::Word16) [255,255,3]+ ,s (127::Word32) [127]+ ,s (128::Word32) [128,1]+ ,s (129::Word32) [129,1]+ ,s (255::Word32) [255,1]+ ,s (16383::Word32) [255,127]+ ,s (16384::Word32) [128,128,1]+ ,s (16385::Word32) [129,128,1]+ ,s (32767::Word32) [255,255,1]+ ,s (32768::Word32) [128,128,2]+ ,s (32769::Word32) [129,128,2]+ ,s (65535::Word32) [255,255,3]+ ,s (2097151::Word32) [255,255,127]+ ,s (2097152::Word32) [128,128,128,1]+ ,s (2097153::Word32) [129,128,128,1]+ ,s (4294967295::Word32) [255,255,255,255,15]+ ,s (255::Word64) [255,1]+ ,s (65535::Word64) [255,255,3]+ ,s (4294967295::Word64) [255,255,255,255,15]+ ,s (18446744073709551615::Word64) [255,255,255,255,255,255,255,255,255,1]+ ,s (255::Word) [255,1]+ ,s (65535::Word) [255,255,3]+ ,s (4294967295::Word) [255,255,255,255,15]+ ,tstI [0::Int8,2,-2]+ ,s (127::Int8) [254]+ ,s (-128::Int8) [255]+ ,tstI [0::Int16,2,-2,127,-128]+ ,tstI [0::Int32,2,-2,127,-128]+ ,tstI [0::Int64,2,-2,127,-128]+ ,s (-1024::Int64) [255,15]+ ,s (maxBound::Word64) [255,255,255,255,255,255,255,255,255,1]+ ,s (minBound::Int64) [255,255,255,255,255,255,255,255,255,1]+ ,s (maxBound::Int64) [254,255,255,255,255,255,255,255,255,1]+ ,tstI [0::Int,2,-2,127,-128]+ ,tstI [0::Integer,2,-2,127,-128,-256,-512]+ ,s (-1024::Integer) [255,15]+ ,s (-0.15625::Float) [0b10111110,0b00100000,0,0]+ ,s (-0.15625::Double) [0b10111111,0b11000100,0,0,0,0,0,0]+ ,s (-123.2325E-23::Double) [0b10111011,0b10010111,0b01000111,0b00101000,0b01110101,0b01111011,0b01000111,0b10111010]+ ,map trip [maxBound::Word16]+ ,map trip [maxBound::Word32]+ ,map trip [maxBound::Word64]+ ,map trip [minBound::Int8,maxBound::Int8]+ ,map trip [minBound::Int16,maxBound::Int16]+ ,map trip [minBound::Int32,maxBound::Int32]+ ,map trip [minBound::Int64,maxBound::Int64]+ ,map trip [0::Float,-0::Float,0/0::Float,1/0::Float]+ ,map trip [0::Double,-0::Double,0/0::Double,1/0::Double]+ ,s '\0' [0]+ ,s '\1' [1]+ ,s '\127' [127]+ ,s 'a' [97]+ ,s 'à' [224,1]+ ,s '经' [207,253,1]+ ,[trip [chr 0x10FFFF]]+ ,s Unit []+ ,s (Un False) [0]+ ,s (One,Two,Three) [16+8]+ ,s (Five,Five,Five) [255,128]+ --,s (NECons True (Elem True)) [128+64+16]+ ,s "" [0]+#ifdef LIST_BIT+ ,s "abc" [176,216,172,96]+ ,s [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)+ ,s map1 [0b10111000]+ ,s (B.pack $ csb 3) (bsl c3)+ ,s (B.pack $ csb 600) (bsl s600)+ ,s (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 unicodeText,trip unicodeTextUTF8T,trip unicodeTextUTF16T]+ ,[trip longBS,trip longLBS,trip longSBS]+ ,[trip longSeq]+ ,[trip mapV]+ ,[trip map1]+ ]+ where+ map1 = M.fromList [(False,True),(True,False)]++ ns :: [(Word64, Int)]+ ns = [( (-) (2 ^(i*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]++ nsI :: [(Int64, Int)]+ nsI = nsI_+ nsII :: [(Integer, Int)]+ nsII = nsI_+ nsI_ = [( (-) (2 ^(((-) i 1)*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]++ --al = (1:) -- prealign+ bsl = id -- noalign+ s3 = [3,97,98,99,0]+ c3a = [3,99,99,99,0] -- Array Word8+ c3 = pre c3a+ s600 = pre s600a+ pre = (1:)+ tx = T.pack "txt"+ utf8Size = 8+8+3*32+8+ utf16Size = 8+8+3*16+8+ shBS = SBS.toShort stBS+ lzBS = L.pack bs+ stBS = B.pack bs+ bs = [32,32,32::Word8]+ bsSize = 8+8+3*8+8+ s600a = concat [[255],csb 255,[255],csb 255,[90],csb 90,[0]]+ s600B = concat [[55],csb 55,[255],csb 255,[90],csb 90,[200],csb 200,[0]]+ longSeq :: Seq.Seq Word8+ longSeq = Seq.fromList lbs+ longSBS = SBS.toShort longBS+ longBS = B.pack lbs+ longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]+ lbs = concat $ replicate 100 [234,123,255,0]+ tstI = map ti++ ti v | v >= 0 = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral v ::Word64)+ | otherwise = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral (-v) - 1 ::Word64)++ teq a b = ser a @?= ser b++ sz v e = [testCase (unwords ["size of",sshow v]) $ getSize v @?= e]++ s v e = [testCase (unwords ["flat raw",sshow v]) $ serRaw v @?= e]+ --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v]++ -- Aligned values unflat to the original value, modulo the added filler.+ a v e = [testCase (unwords ["flat",sshow v]) $ ser v @?= e+ ,testCase (unwords ["unflat",sshow v]) $ let Right v' = des e in v @?= v']+ -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e+ -- ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']+ cs n = replicate n 'c' -- take n $ cycle ['a'..'z']+ csb = map (fromIntegral . ord) . cs+ sshow = take 80 . show++ trip :: forall a .(Show a,Flat a) => a -> TestTree+ trip v = testCase (unwords ["roundtrip",sshow v]) $ show (unflat (flat v::B.ByteString)::Decoded a) @?= show (Right v::Decoded a) -- we use show to get Right NaN == Right NaN++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]++uc = map ord "\x4444\x5555\x10001\xD800"++ser :: Flat a => a -> [Word8]+ser = L.unpack . flat++des :: Flat a => [Word8] -> Decoded a+des = unflat . L.pack++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 = rtrip2++prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool+prop_Flat_Large_roundtrip (Large x) = rtrip2 x++rtrip x = unflat (flat x::B.ByteString) == Right x+rtrip2 x = rtrip x && rtrip (True,x,False)++{-+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])))+
+ test/Test/Data.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-}+{-+ A collection of data types used for testing.+-}+module Test.Data where++import Control.Exception+import Data.Char+import Data.Int+import Data.Word++import Data.Typeable+import Data.Data+import GHC.Generics+import Data.Data+import qualified Test.Data2 as D2+import Data.Foldable+import GHC.Exts hiding (toList)++data Void deriving Generic++data X = X X deriving 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 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)++-- Enumeration+data N3 = N1 | N2 | N3+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Enum)++data N = One+ | Two+ | Three+ | Four+ | Five+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum)++-- 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))++toForest2 :: Forest a -> Forest2 a+toForest2 (Forest f) = Forest2 (ForestD $ fmap toTr f)++toTr :: Tr a -> TrD (Forest2 a) a+toTr (Tr a f) = TrD a (toForest2 f)++toTr2 :: Tr a -> Tr2 a+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)++-- 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)++-- 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 Words = Words Word8 Word16 Word32 Word64+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Ints = Ints Int8 Int16 Int32 Int64+ 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))+ | 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)++-- Phantom type+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}+ | 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 List a = C a (List a)+ | N+ 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)++-- 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 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)+-- 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)++-- 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 Pr f g a = Pr (f a (g a))++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)++-- 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)++-- recursive sets:+-- Prob: ghc will just explode on this+-- data MM1 = MM1 MM2 MM4 MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM0 = MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM2 = MM2 MM3 Bool deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM3 = MM3 MM4 Bool deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- 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)++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 Stream a = Stream a (Stream a)+ 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)++-- 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 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 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 Engine = Engine {+ capacity :: Word16+ ,numCylinders:: Word8+ ,maxRpm:: Word16 -- constant 9000+ ,manufacturerCode :: String+ ,fuel::String -- constant Petrol+ } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+
+ test/Test/Data/Arbitrary.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+module Test.Data.Arbitrary where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS+import Data.DeriveTH+import qualified Data.Text as T+import Test.Data+import Test.Tasty.QuickCheck++-- xxx = generate (arbitrary :: Gen (Large (Int)))++instance Arbitrary SBS.ShortByteString where arbitrary = fmap SBS.pack arbitrary++instance Arbitrary B.ByteString where arbitrary = fmap B.pack arbitrary++instance Arbitrary L.ByteString where arbitrary = fmap L.pack arbitrary++instance Arbitrary T.Text where arbitrary = fmap T.pack arbitrary++-- instance Arbitrary a => Arbitrary (List a) where arbitrary = fmap l2L arbitrary++derive makeArbitrary ''N++derive makeArbitrary ''Tree++derive makeArbitrary ''List++derive makeArbitrary ''Unit++derive makeArbitrary ''Un++derive makeArbitrary ''A++derive makeArbitrary ''B++-- instance Arbitrary Word7 where arbitrary = toEnum <$> choose (0, 127)+-- derive makeArbitrary ''ASCII+
+ test/Test/Data/Flat.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UndecidableInstances ,DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts ,FlexibleInstances ,LambdaCase ,StandaloneDeriving #-}+module Test.Data.Flat(module Test.Data) where+import Data.Flat+import Data.Flat.Encoder+import Data.Flat.Decoder+import Test.Data+import Test.Data2.Flat()+import Data.Word+--import Data.Flat.Poke+import Data.Foldable+import Data.Int+import GHC.Generics++{-+Compilation times:+ encoderS specials cases |+| 7.10.3 | NO | 0:44 |+| 7.10.3 | YES | 0:39 |+| 8.0.1 | NO | 1:30 |+| 8.0.1 | YES | 1:30 |+| 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,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)++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++-- -50%+-- instance {-# OVERLAPPING #-} Flat (N,N,N) where+-- {-# INLINE encode #-}+-- encode (n1,n2,n3) = wprim $ (Step 9) (encodeN n1 >=> encodeN n2 >=> encodeN n3)+-- {-# INLINE encodeN #-}+-- encodeN = \case+-- One -> eBitsF 2 0+-- Two -> eBitsF 2 1+-- 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)++{-+ |+ |+One Two |+ Three |+ Four Five+ -}+-- 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 #-}+-- encode = \case+-- One -> eBits 2 0+-- Two -> eBits 2 1+-- 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++-- 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++-- 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++-- size (Node t1 t2) = 1 + size t1 + size t2+-- size (Leaf a) = 1 + size a++--instance Flat N+++
+ test/Test/Data/Values.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module Test.Data.Values where++import Control.DeepSeq+import Control.Exception+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.Int+import Data.List+import qualified Data.Text as T+import Data.Word+import Test.Data+import qualified Test.Data2 as D2+import qualified Data.ByteString.Short.Internal as SBS+import Data.Foldable+import qualified Data.Sequence as Seq+import qualified Data.Map as M+import Data.Flat++instance NFData Various+instance NFData a => NFData (List a)+instance NFData a => NFData (D2.List a)+instance NFData N+instance NFData a => NFData (ListS a)+instance NFData a => NFData (Stream a)+instance NFData a => NFData (Tree a)+instance NFData Car+instance NFData Engine+instance NFData OptionalExtra+instance NFData CarModel+instance NFData Consumption+instance NFData Acceleration++floatT = ("float",-234.123123::Float)+doubleT = ("double",-1.91237::Double)++a01 = A0 B1 (B0 (C0 (A1 N N D2.Nil2 D2.Nil2))) (D0 E1)++ab0 = A (B (A (BB 'g')))++pe1 :: PerfectF Maybe Bool+pe1 = ConsP True (ConsP (Just False) (ConsP (Just (Just True)) NilP))++pr1 :: Pr Either List Int+pr1 = Pr (Right (C 3 N))+f1,f2,f3:: Free [] Int+f1 = Pure 1+f2 = Roll [Pure 1,Pure 2]+f3 = Roll [Roll [Pure 3],Pure 4]++rr1 :: RR Char () Int8+rr1 = RAB 'a' (RN 11 () 'b') ()++-- h = from Three+infList :: List Bool+infList = C True infList++hl1 = [1,3..111::Word]+hl2 = [1,3..111::Int]+hl3 = [False,True,True,False,True,True,True,True,False,True,True,True,True,False,True,False]++b1 = B.pack [99,173,186,44,187,124,87,186,104,99,138,202,53,137,22,5,44,244,234,7,159,119,22,234]+b2 = B.pack . concat . replicate 100 $ [235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236,235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236,235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236]++lb1 = L.pack . B.unpack $ b1+lb2 = L.fromChunks $ replicate 100 $ B.replicate 400 33++s1 = "a"+s2 = "中文版本"+s3 = ['A'..'z']+s4 = Prelude.concatMap show [1..400]++t1 = T.pack s1+t2 = T.pack s2+t3 = T.pack s3+t4 = T.pack s4+++p1 :: Phantom Char+p1 = Phantom++--toList N = []+--toList (C h t) = h : (toList t)++l2L [] = N+l2L (x:xs) = C x (l2L xs)++l1 = l2L $ take 11 [11::Word8,22..33]++lBool :: List Bool+lBool = l2L $ map odd [1..99]++lBool2 :: List Bool+lBool2 = l2L $ map odd [1..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))))))))))))))++lN0 = C Three (C One N)++lN = C Three (C Three (C One (C One (C Three (C Four (C One (C Five (C Two (C Three (C Four (C Two (C Five (C Five (C Two (C Four (C Three (C One (C Four (C Five (C Two (C Five (C One (C Five (C Two (C One (C One (C Two (C Four N))))))))))))))))))))))))))))++largeSize = 1000000++couples :: [(Word32,N)]+couples = zip [1..] $ ns 1000++lN2 :: List N+lN2 = lnx 1000++lN3 = lnx (largeSize*5)++lnx = l2L . ns++ns n = map asN [1..n]++asN = toN . (`mod` 5)++toN :: Integer -> N+toN 1 = One+toN 2 = Two+toN 3 = Three+toN 4 = Four+toN _ = Five++asN3 = toN3 . (`mod` 5)+toN3 :: Integer -> (N,N,N)+toN3 1 = (One,Two,Three)+toN3 2 = (Two,Three,Four)+toN3 3 = (Three,Four,Five)+toN3 4 = (Four,Five,One)+toN3 _ = (Four,Five,Two)++t33T =("Tuple of Tuple",t33)+t33 = asN33 4++asN33 :: Integer -> ((N, N, N), (N, N, N), (N, N, N))+asN33 n = (asN3 n,asN3 (n+1),asN3 (n+2))++treeNLarge :: Tree N+treeNLarge = mkTree asN largeSize++treeNNNLarge :: Tree (N,N,N)+treeNNNLarge = mkTree asN3 largeSize++treeN33Large :: Tree ((N,N,N),(N,N,N),(N,N,N))+treeN33Large = mkTree asN33 largeSize++treeVarious = mkTree (const v2) 100++mkTree mk = mkTree_ 1+ where+ mkTree_ p 1 = Leaf $ mk p+ mkTree_ p n = let (d,m) = n `divMod` 2+ in Node (mkTree_ p d) (mkTree_ (p+d) (d+m))++tree1 :: Tree String+tree1 = Node (Leaf "a leaf") (Node (Leaf "and") (Leaf "more"))++tree2 :: Tree Word64+tree2 = Node (Leaf 17) (Node (Leaf 23) (Leaf 45))++-- ss = take 5 . toList $ stream1++-- stream1 = Stream True stream1++car1 = Car 2343 1965 True ModelB [18,234] "1234" [SunRoof,CruiseControl] (Engine 1200 3 9000 "Fiat" "Petrol") [Consumption 40 18,Consumption 60 23,Consumption 80 25] [(90,[Acceleration 40 12]),(110,[Acceleration 50 11])] "Fiat" "500"++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.")++unicodeTextUTF8T = ("unicodeTextUTF8",UTF8Text unicodeText)+unicodeTextUTF16T = ("unicodeTextUTF16",UTF16Text unicodeText)++unicodeTextT = ("unicodeText",unicodeText)+unicodeText = T.pack unicodeStr++unicodeStrT = ("unicodeStr",unicodeStr)++unicodeStr = longS 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周年大会上重要讲话在国际社会引起热烈反响"++longS = take 1000000 . concat . repeat++arr0 = ("[Bool]",map (odd . ord) $ unicodeStr :: [Bool])++arr1 = ("[Word]",map (fromIntegral . ord) $ unicodeStr :: [Word])++arr2 = ("ByteString from String",B.pack . map (fromIntegral . ord) $ unicodeStr)+sbs = ("StrictByteString",b2)+lbs = ("LazyByteString",lb2)+shortbs = ("ShortByteString",SBS.toShort b2)++mapT = ("map",mapV)+mapV = M.fromList couples+mapListT = ("mapList",couples)++lN2T = ("List N",lN2)+lN3T = ("Large List N",lN3)+nativeListT = ("Large [N]",nativeList)+nativeList = toList lN3+seqNT = ("Seq N",Seq.fromList . toList $ lN2) -- nativeList)+treeNT = ("treeN",treeN)+treeNLargeT = ("treeNLarge",treeNLarge)+treeNNNLargeT = ("treeNNNLarge",treeNNNLarge)+treeN33LargeT = ("treeN33Large",treeN33Large)+treeVariousT = ("Tree Various",treeVarious)+tuple0T = ("block-tuple",(False,(),(3::Word64,33::Word,(True,(),False))))+tupleT = ("tuple",(Two,One,(Five,Three,(Three,(),Two))))+tupleBools = ("tupleBools",(False,(True,False),((True,False,True),(True,False,True))))+oneT = ("One",One)+tupleWords = ("tupleWord",(18::Word,623723::Word,(8888::Word,823::Word)))+word8T = ("Word8",34::Word8)+word64T = ("Word64",34723823923::Word64)+carT = ("car",car1)+wordsT = ("words",wordsV)+wordsV = (18::Word,33::Word8,1230::Word16,9990::Word32,1231232::Word64)+words0T = ("words0",words0V)+words0V = (0::Word,0::Word8,0::Word16,0::Word32,0::Word64)+intsT = ("ints",(444::Int,123::Int8,-8999::Int16,-123823::Int32,-34723823923::Int64))+floatsT = ("floats",floats)+floatsUnaT = ("floats unaligned",(Three,floats))+floats = (3.43::Float,44.23E+23::Double,0.1::Double)+int8T = ("Int8",-34::Int8)+int64T = ("Int64",-34723823923::Int64)+integerT = ("Integer",-3472382392399239230123123::Integer)+charT = ("Char",'a')+unicharT = ("Unicode char", '世')+v1T = ("V1",v1)+v1 = V1 (Just False)+v2T = ("V2",v2)+--v2 = V2 True (Right Nothing) (One,Two,Three)+v2 = V2 True (Right Nothing)+vfT = ("v floats",VF 3.43 44.23E+23 0.1)+vwT = ("v words",vw)+vw = VW 18 33 1230 9990 1231232+-- vw = VW 0 0 0 0 0+viT = ("v ints",VI 444 123 (-8999) (-123823) (-34723823923))+viiT = ("v integers",VII 444 8888 (-34723823923))++-- Copied from binary-typed-0.3/benchmark/Criterion.hs+-- | Data with a normal form.+data NF = forall a. NFData a => NF a++-- | Evaluate 'NF' data to normal form.+force' :: NF -> ()+force' (NF x) = x `deepseq` ()++forceCafs :: IO ()+forceCafs = mapM_ (evaluate . force') cafs++-- | List of all data that should be fully evaluated before the benchmark is+-- run.+cafs :: [NF]+cafs = [+ NF carT+ , NF charT+ , NF unicharT+ , NF wordsT+ , NF words0T+ , NF intsT+ , NF floatT+ , NF doubleT+ , NF floatsT+ , NF floatsUnaT+ , NF tupleT+ , NF tuple0T+ , NF treeNLargeT+ , NF treeNNNLargeT+ , NF treeN33LargeT+ , NF treeNT+ , NF lN2T+ , NF lN3T+ , NF mapT+ , NF mapListT+ , NF nativeListT+ , NF seqNT+ , NF arr1+ , NF arr0+ , NF longS+ , NF unicodeStr+ , NF asciiStrT+ , NF unicodeStrT+ , NF unicodeTextT+ --, NF unicodeTextUTF8T+ --, NF unicodeTextUTF16T+ , NF couples+ , NF v1T+ , NF v2T+ , NF vfT+ , NF vwT+ , NF viT+ , NF viiT+ , NF treeVariousT+ , NF sbs+ , NF lbs+ , NF shortbs+ ]
+ test/Test/Data2.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-}+module Test.Data2 where++import Data.Typeable+import Data.Data+import GHC.Generics++-- A definition with the same name of a definition in Test.Data, used to test for name clashes.a+data List a = Cons2 a (List a)+ | Nil2+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic ,Generic1)+
+ test/Test/Data2/Flat.hs view
@@ -0,0 +1,5 @@+module Test.Data2.Flat(module Test.Data2) where+import Data.Flat+import Test.Data2++instance Flat a => Flat (List a)