diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,11 @@ Significant and compatibility-breaking changes. + +Version 0.6: + - [**breaking**] Renamed Repr to AsBin and SizeOf to AsSize + - Faster AsBin implementation + - Fixed AsSize implementation (SizeOf worked only for types with custom size implementation and returned max size, not actual size) + Version 0.5.2: - Fixed https://github.com/Quid2/flat/issues/28 that could cause an undetected overflow when decoding out of range Int/Word values - Added UTF16Text and Data.ByteString.Short support for ghcjs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -78,10 +78,11 @@ Tested with: -* [GHC](https://www.haskell.org/ghc/) 7.10.3 to 9.4.2 (x64) +* [GHC](https://www.haskell.org/ghc/) 7.10.3 to 9.4.3 (x64) * [GHCJS](https://github.com/ghcjs/ghcjs) version 8.6.0.1 (GHC 8.6.2) + ### Known Bugs and Infelicities diff --git a/flat.cabal b/flat.cabal --- a/flat.cabal +++ b/flat.cabal @@ -1,16 +1,29 @@ cabal-version: >=1.10 name: flat -version: 0.5.2 +version: 0.6 homepage: http://quid2.org synopsis: Principled and efficient bit-oriented binary serialization. -description: Reference implementation of `flat`, a principled and efficient binary serialization format. +description: + Reference implementation of `flat`, a principled and efficient binary serialization format. + category: Data,Parsing,Serialization license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2016-2022 Pasqualino `Titto` Assini maintainer: tittoassini@gmail.com author: Pasqualino `Titto` Assini -tested-with: GHC ==7.10.3 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 +tested-with: + GHC ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.4 + || ==9.4.3 + build-type: Simple extra-source-files: stack.yaml @@ -27,6 +40,8 @@ Data.FloatCast Data.ZigZag Flat + Flat.AsBin + Flat.AsSize Flat.Bits Flat.Class Flat.Decoder @@ -56,7 +71,6 @@ Flat.Instances.Vector Flat.Memory Flat.Run - Flat.Repr Flat.Tutorial Flat.Types @@ -84,11 +98,12 @@ ghc-options: -Wall -O2 -funbox-strict-fields -fno-warn-orphans -fno-warn-name-shadowing - -- -Werror - -- Stan options - -- -fwrite-ide-info -hiedir=.hie + -- -Werror + -- Stan options + -- -fwrite-ide-info -hiedir=.hie + if impl(eta -any) build-depends: array ==0.5.2.0 @@ -120,32 +135,34 @@ , deepseq >=1.4 , dlist >=0.6 , ghc-prim + , list-t >1 , mono-traversable , pretty >=1.1.2 , primitive , text , unordered-containers , vector - , list-t > 1 - + if impl(ghc <8) - build-depends: - semigroups < 0.19 - , hashable >=1.2.4.0 && <=1.2.7.0 - else - build-depends: hashable >= 1.4.0.1 + build-depends: + hashable >=1.2.4.0 && <=1.2.7.0 + , semigroups >=0 && <0.19 + else + build-depends: hashable >=1.4.0.1 + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs cpp-options: -DLIST_BIT -DTEST_DECBITS -- if impl(ghc <8.6) - cpp-options: -DENUM_LARGE + cpp-options: -DENUM_LARGE -- -DETA_VERSION -Dghcjs_HOST_OS - ghc-options: -O0 + ghc-options: -O0 + if impl(ghc >8) ghc-options: -Wno-unused-top-binds -Wno-type-defaults -Wno-missing-signatures @@ -173,7 +190,7 @@ , text if impl(ghc <8) - build-depends: semigroups < 0.19 + build-depends: semigroups <0.19 if impl(eta -any) build-depends: @@ -196,9 +213,9 @@ , deepseq , filepath , mono-traversable + , QuickCheck >=2.14.2 , tasty , text - , QuickCheck >= 2.14.2 -- dynamic doctests and generation of static doctests -- Usable only with recent versions of ghc (no ghcjs or eta) @@ -211,10 +228,10 @@ -- build-depends: -- base -- , directory --- , doctest ==0.16.3.1 --- , filemanip >=0.3.6.3 +-- , doctest ==0.16.3.1 +-- , filemanip >=0.3.6.3 +-- , QuickCheck >=2.14.2 -- , text --- , QuickCheck >= 2.14.2 -- static doctests (faster, useful for test coverage and to test ghcjs and eta) test-suite doc-static @@ -225,22 +242,23 @@ DocTest DocTest.Data.FloatCast DocTest.Data.ZigZag + DocTest.Flat.AsBin + DocTest.Flat.AsSize DocTest.Flat.Bits DocTest.Flat.Decoder.Prim + DocTest.Flat.Encoder.Prim DocTest.Flat.Endian - DocTest.Flat.Repr DocTest.Flat.Instances.Array DocTest.Flat.Instances.Base DocTest.Flat.Instances.ByteString DocTest.Flat.Instances.Containers DocTest.Flat.Instances.DList + DocTest.Flat.Instances.Extra DocTest.Flat.Instances.Mono DocTest.Flat.Instances.Text DocTest.Flat.Instances.Unordered DocTest.Flat.Instances.Vector DocTest.Flat.Tutorial - DocTest.Flat.Encoder.Prim - DocTest.Flat.Instances.Extra default-language: Haskell2010 build-depends: @@ -251,31 +269,31 @@ , dlist , flat , pretty + , QuickCheck >=2.14.2 , tasty , tasty-hunit , tasty-quickcheck , text , unordered-containers , vector - , QuickCheck >= 2.14.2 if impl(ghc <8) build-depends: semigroups <0.19 --- Test for Flat.Repr -test-suite repr +-- Test for Flat.AsBin Flat.AsSize and listTDecoder +test-suite big type: exitcode-stdio-1.0 - main-is: FlatRepr.hs + main-is: Big.hs hs-source-dirs: test default-language: Haskell2010 build-depends: base , bytestring , flat - , timeit , list-t + , timeit - ghc-options: -rtsopts + ghc-options: -rtsopts -- test-suite text -- type: exitcode-stdio-1.0 diff --git a/src/Flat.hs b/src/Flat.hs --- a/src/Flat.hs +++ b/src/Flat.hs @@ -11,9 +11,11 @@ ) where +import Flat.AsBin as X +import Flat.AsSize as X import Flat.Class import Flat.Decoder import Flat.Filler -import Flat.Instances as X -import Flat.Run as X -import Flat.Types ( ) +import Flat.Instances as X +import Flat.Run as X +import Flat.Types () diff --git a/src/Flat/AsBin.hs b/src/Flat/AsBin.hs new file mode 100644 --- /dev/null +++ b/src/Flat/AsBin.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | Wrapper type to decode a value to its flat serialisation. + +See <../test/Big.hs> for an example of use. + +See also 'Flat.Decoder.listTDecoder' and "Flat.AsSize" for other ways to handle large decoded values. + +In 0.5.X this type was called @Repr@. + +@since 0.6 +-} +module Flat.AsBin(AsBin,unbin) where + +import qualified Data.ByteString as B +import Flat.Bits (bits, fromBools, toBools) +import Flat.Class (Flat (..)) +import Flat.Decoder.Prim (binOf) +import Flat.Decoder.Types (Get (Get, runGet), + GetResult (GetResult), + S (S, currPtr, usedBits)) +import Flat.Run (unflatRawWithOffset) +import Foreign (plusPtr) +import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), + prettyShow, text) + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> import Flat.Instances.Base +-- >>> import Flat.Instances.Text +-- >>> import Flat.Decoder.Types +-- >>> import Flat.Types +-- >>> import Flat.Run +-- >>> import Data.Word +-- >>> import qualified Data.Text as T +-- >>> import Text.PrettyPrint.HughesPJClass + +{- | + +When the flat serialisation of a value takes a lot less memory than the value itself, it can be convenient to keep the value in its encoded representation and decode it on demand. + +To do so, just decode a value `a` as a `AsBin a`. + +Examples: + +Encode a list of Ints and then decode it to a list of AsBin Int: + +>>> unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int]) +Right [AsBin {repr = "\129A", offsetBits = 1},AsBin {repr = "A ", offsetBits = 2},AsBin {repr = " \193", offsetBits = 3}] + +To decode an `AsBin a` to an `a`, use `unbin`: + +>>> unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char)) +Right 'a' + +Keep the values of a list of Ints encoded and decode just one on demand: + +>>> let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2) +3 + +Show exactly how values are encoded: + +>>> let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t +"(0, _0000001 1, _1)" + +Ten bits in total spread over two bytes: + +@ +0 +_0000001 1 + _1 += +00000001 11 +@ + +Tests: + +>>> unflat (flat ()) :: Decoded (AsBin ()) +Right (AsBin {repr = "", offsetBits = 0}) + +>>> unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool) +Right (False,AsBin {repr = "A", offsetBits = 1}) + +>>> unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8) +Right (False,False,AsBin {repr = "?\193", offsetBits = 2}) + +>>> let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3) +(False,False,255,True) +-} + +data AsBin a = AsBin { + repr :: B.ByteString -- ^ Flat encoding of the value (encoding starts after offset bits in the first byte and ends in an unspecified position in the last byte) + ,offsetBits :: Int -- ^ First byte offset: number of unused most significant bits in the first byte + } deriving Show + +instance Flat a => Pretty (AsBin a) where + pPrint :: AsBin a -> Doc + pPrint r = let n = replicate (offsetBits r) in text $ n '_' ++ (drop (offsetBits r) . prettyShow . fromBools . (n False ++) . toBools . bits $ unbin r) + +-- | Decode a value +unbin :: Flat a => AsBin a -> a +unbin a = + case unflatRawWithOffset dec (repr a) (offsetBits a) of + Right a -> a + Left e -> error (show e) -- impossible, as it is a valid encoding + where + dec = Get $ \end s -> do + GetResult s' a <- runGet decode end s + let s'' = S (currPtr s' `plusPtr` if usedBits s' == 0 then 0 else 1) 0 + return $ GetResult s'' a + +instance Flat a => Flat (AsBin a) where + size = error "unused" + + encode = error "unused" + + decode :: Flat a => Get (AsBin a) + decode = uncurry AsBin <$> binOf (decode :: Get a) diff --git a/src/Flat/AsSize.hs b/src/Flat/AsSize.hs new file mode 100644 --- /dev/null +++ b/src/Flat/AsSize.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Wrapper type to decode a value to its size in bits. + +See also "Flat.AsBin". + +In 0.5.X this type was called @SizeOf@. + +@since 0.6 +-} +module Flat.AsSize(AsSize(..)) where + +import Flat.Class (Flat (..)) +import Flat.Decoder.Prim (sizeOf) +import Flat.Decoder.Types (Get) +import Flat.Types (NumBits) + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> import Flat.Instances.Base +-- >>> import Flat.Instances.Text +-- >>> import Flat.Decoder.Types +-- >>> import Flat.Types +-- >>> import Flat.Run +-- >>> import Data.Word +-- >>> import qualified Data.Text as T + +{- | +Useful to skip unnecessary values and to check encoding sizes. + +Examples: + +Ignore the second and fourth component of a tuple: + +>>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool) +Right ('a',AsSize 28,'z',AsSize 1) + +Notice the variable size encoding of Words: + +>>> unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64) +Right (AsSize 8,AsSize 8) + +Text: + +>>> unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text) +Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40) + +Various encodings: + +>>> unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char) +Right (AsSize 1,AsSize 96,AsSize 8) +-} +newtype AsSize a = AsSize NumBits deriving (Eq,Ord,Show) + +instance Flat a => Flat (AsSize a) where + size :: Flat a => AsSize a -> NumBits -> NumBits + size = error "unused" + + encode = error "unused" + + decode :: Flat a => Get (AsSize a) + decode = AsSize <$> sizeOf (decode :: Get a) diff --git a/src/Flat/Class.hs b/src/Flat/Class.hs --- a/src/Flat/Class.hs +++ b/src/Flat/Class.hs @@ -21,7 +21,6 @@ , getSize , module GHC.Generics , GFlatEncode,GFlatDecode,GFlatSize - , SizeOf(..) ) where @@ -31,7 +30,6 @@ consClose, consOpen, dBool) import Flat.Decoder.Types (Get) import Flat.Encoder (Encoding, NumBits, eBits16, mempty) -import GHC.Base (Any) import GHC.Generics import GHC.TypeLits (Nat, type (+), type (<=)) import Prelude hiding (mempty) @@ -102,21 +100,6 @@ {-# NOINLINE decode #-} {-# NOINLINE encode #-} #endif - --- | Skip a value, return its size in bits -skip :: forall a. (GFlatSize (Rep a),GFlatDecode (Rep a)) => Get (SizeOf a) -skip = SizeOf . (gsize 0 :: Rep a Any -> NumBits) <$> (gget :: Get (Rep a Any)) -{-# INLINE skip #-} - --- | Decode to the size in bits of a value rather than to the value itself (see "Flat.Repr") -newtype SizeOf a = SizeOf NumBits deriving Show - -instance (GFlatSize (Rep a),GFlatDecode (Rep a)) => Flat (SizeOf a) where - size = error "unused" - encode = error "unused" - - decode = skip - -- |Generic Encoder class GFlatEncode f where gencode :: f a -> Encoding diff --git a/src/Flat/Decoder/Prim.hs b/src/Flat/Decoder/Prim.hs --- a/src/Flat/Decoder/Prim.hs +++ b/src/Flat/Decoder/Prim.hs @@ -22,7 +22,9 @@ dLazyByteString_, dByteArray_, - ConsState(..),consOpen,consClose,consBool,consBits + ConsState(..),consOpen,consClose,consBool,consBits, + + sizeOf,binOf ) where import Control.Monad (when) @@ -30,11 +32,13 @@ import qualified Data.ByteString.Lazy as L import Data.FloatCast (wordToDouble, wordToFloat) import Data.Word (Word16, Word32, Word64, Word8) -import Flat.Decoder.Types (Get (Get), GetResult (..), S (..), - badEncoding, badOp, notEnoughSpace) +import Flat.Decoder.Types (Get (Get, runGet), GetResult (..), + S (..), badEncoding, badOp, + notEnoughSpace) import Flat.Endian (toBE16, toBE32, toBE64) import Flat.Memory (ByteArray, chunksToByteArray, - chunksToByteString, minusPtr) + chunksToByteString, minusPtr, + peekByteString) import Foreign (Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)), FiniteBits (finiteBitSize), Ptr, Storable (peek), castPtr, plusPtr, @@ -410,3 +414,26 @@ when (usedBits s /=0) $ badEncoding endPtr s "usedBits /= 0" (currPtr',ns) <- getChunks (currPtr s) id return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns) + +{- | Given a value's decoder, returns the size in bits of the encoded value + +@since 0.6 +-} +sizeOf :: Get a -> Get Int +sizeOf g = + Get $ \end s -> do + GetResult s' _ <- runGet g end s + return $ GetResult s' $ (currPtr s' `minusPtr` currPtr s) * 8 - usedBits s + usedBits s' + +{- | Given a value's decoder, returns the value's bit encoding. + +The encoding starts at the returned bit position in the return bytestring's first byte +and ends in an unspecified bit position in its final byte + +@since 0.6 +-} +binOf :: Get a -> Get (B.ByteString,Int) +binOf g = + Get $ \end s -> do + GetResult s' _ <- runGet g end s + return $ GetResult s' (peekByteString (currPtr s) (currPtr s' `minusPtr` currPtr s + if usedBits s' == 0 then 0 else 1),usedBits s) diff --git a/src/Flat/Decoder/Run.hs b/src/Flat/Decoder/Run.hs --- a/src/Flat/Decoder/Run.hs +++ b/src/Flat/Decoder/Run.hs @@ -10,10 +10,10 @@ import ListT (ListT (..)) import System.IO.Unsafe (unsafePerformIO) --- | Given a decoder and an input buffer returns either the decoded value or an error (if the input buffer is not fully consumed) -strictDecoder :: Get a -> B.ByteString -> Either DecodeException a -strictDecoder get bs = - strictDecoder_ get bs $ \(GetResult s'@(S ptr' o') a) endPtr -> +-- | Given a decoder and an input buffer returns either the decoded value or an error (if the input buffer is not fully consumed) +strictDecoder :: Get a -> B.ByteString -> Int -> Either DecodeException a +strictDecoder get bs usedBits= + strictDecoder_ get bs usedBits $ \(GetResult s'@(S ptr' o') a) endPtr -> if ptr' /= endPtr || o' /= 0 then tooMuchSpace endPtr s' else return a @@ -22,14 +22,15 @@ Exception e => Get a1 -> BS.ByteString + -> Int -> (GetResult a1 -> Ptr b -> IO a) -> Either e a -strictDecoder_ get (BS.PS base off len) check = +strictDecoder_ get (BS.PS base off len) usedBits check = unsafePerformIO . try $ withForeignPtr base $ \base0 -> let ptr = base0 `plusPtr` off endPtr = ptr `plusPtr` len - in do res <- runGet get endPtr (S ptr 0) + in do res <- runGet get endPtr (S ptr usedBits) check res endPtr {-# NOINLINE strictDecoder_ #-} @@ -43,12 +44,14 @@ -- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0) -- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o') -{-| +{-| Decode a list of values, one value at a time. Useful in case that the decoded values takes a lot more memory than the encoded ones. -See test/FlatRepr.hs for a test and an example of use. +See <../test/Big.hs> for a test and an example of use. + +See also "Flat.AsBin". @since 0.5 -} diff --git a/src/Flat/Instances/Mono.hs b/src/Flat/Instances/Mono.hs --- a/src/Flat/Instances/Mono.hs +++ b/src/Flat/Instances/Mono.hs @@ -168,6 +168,12 @@ decodeList :: (IsSequence b, Flat (Element b)) => Get b decodeList = S.fromList <$> decodeListWith decode +{-| +Sets are saved as lists of values. + +>>> tstBits $ AsSet (Data.Set.fromList ([False,True,False]::[Bool])) +(True,5,"10110") +-} newtype AsSet a = AsSet { unSet :: a diff --git a/src/Flat/Memory.hs b/src/Flat/Memory.hs --- a/src/Flat/Memory.hs +++ b/src/Flat/Memory.hs @@ -15,29 +15,25 @@ , pokeByteString , unsafeCreateUptoN' , minusPtr - --, peekByteString + , peekByteString ) where -import Control.Monad ( foldM_, when ) -import Control.Monad.Primitive ( PrimMonad(..) ) -import qualified Data.ByteString.Internal as BS -import Data.Primitive.ByteArray ( MutableByteArray(..) - , ByteArray# - , ByteArray - , newByteArray - , unsafeFreezeByteArray - ) -import Foreign ( Word8, Ptr, withForeignPtr, minusPtr, plusPtr ) -import GHC.Prim ( copyAddrToByteArray# - , copyByteArrayToAddr# - ) -import GHC.Ptr ( Ptr(..) ) -import GHC.Types ( IO(..) - , Int(..) - ) -import System.IO.Unsafe ( unsafeDupablePerformIO, unsafePerformIO ) -import qualified Data.ByteString as B +import Control.Monad (foldM_, when) +import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BS +import Data.Primitive.ByteArray (ByteArray, ByteArray#, + MutableByteArray (..), newByteArray, + unsafeFreezeByteArray) +import Foreign (Ptr, Word8, minusPtr, plusPtr, + withForeignPtr) +import GHC.Prim (copyAddrToByteArray#, + copyByteArrayToAddr#) +import GHC.Ptr (Ptr (..)) +import GHC.Types (IO (..), Int (..)) +import System.IO.Unsafe (unsafeDupablePerformIO, + unsafePerformIO) unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a) unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f) @@ -65,10 +61,16 @@ sourceLength return (destPointer `plusPtr` sourceLength) --- Create a new bytestring, copying from sourcePtr sourceLength number of bytes --- peekByteString :: Ptr Word8 -> Int -> BS.ByteString --- peekByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength +{-| Create a new bytestring, copying sourceLen bytes from sourcePtr +@since 0.6 +-} +peekByteString :: + Ptr Word8 -- ^ sourcePtr + -> Int -- ^ sourceLen + -> BS.ByteString +peekByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength + -- |Copy ByteArray to given pointer, returns new pointer pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8) pokeByteArray sourceArr sourceOffset len dest = do @@ -115,7 +117,7 @@ -- | Wrapper around @copyAddrToByteArray#@ primop. --- +-- -- Copied from the store-core package copyAddrToByteArray :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () diff --git a/src/Flat/Repr.hs b/src/Flat/Repr.hs deleted file mode 100644 --- a/src/Flat/Repr.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Flat.Repr where - -import qualified Data.ByteString as B -import Flat.Class (Flat (..)) -import Flat.Decoder.Types (Get) -import Flat.Run (flat, unflat) - --- $setup --- >>> :set -XScopedTypeVariables --- >>> import Flat.Instances.Base --- >>> import Flat.Decoder.Types --- >>> import Flat.Types --- >>> import Flat.Run --- >>> import Flat.Class - -{- | Flat representation of a value - -== Repr -It is occasionally useful to keep a decoded value, or part of it, in its encoded binary representation and decode it later on demand. - -To do so, just decode a value `a` to a `Repr a`. - -For example, we encode a list of Ints and then decode it to a list of Repr Int: - ->>> unflat (flat [1::Int .. 5]) :: Decoded ([Repr Int]) -Right [Repr {repr = "\STX\SOH"},Repr {repr = "\EOT\SOH"},Repr {repr = "\ACK\SOH"},Repr {repr = "\b\SOH"},Repr {repr = "\n\SOH"}] - -To decode a `Repr a` to an `a`, we use `unrepr`: - ->>> let Right l = unflat (flat [1..5]) :: Decoded [Repr Int] in unrepr (l !! 2) -3 - -See "test/FlatRepr.hs" for a test and a longer example of use. - -== SizeOf -If a decoded value is not required, it can be skipped completely using `SizeOf a`. - -For example, to ignore the second and fourth component of the following tuple, it can be decoded as: - ->>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,SizeOf String,Char,SizeOf Bool) -Right ('a',SizeOf 28,'z',SizeOf 1) - -The unused values have not been decoded and instead their size (in bits) is returned. --} - -newtype Repr a = Repr {repr :: B.ByteString} deriving Show - --- Get the underlying value -unrepr :: Flat a => Repr a -> a -unrepr (Repr bs)= - case unflat bs of - Right a -> a - Left _ -> error "impossible" - -instance Flat a => Flat (Repr a) where - size = error "unused" - encode = error "unused" - - -- To create the representation we just re 'flat' the parsed value (this could be optimised by copying directly the parsed representation) - decode = Repr . flat <$> (decode :: Get a) diff --git a/src/Flat/Run.hs b/src/Flat/Run.hs --- a/src/Flat/Run.hs +++ b/src/Flat/Run.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- |Encoding and decoding functions @@ -11,14 +11,16 @@ unflatWith, unflatRaw, unflatRawWith, + unflatRawWithOffset, ) where -import qualified Data.ByteString as B -import Data.ByteString.Convert (AsByteString (..)) -import Flat.Class (Flat (decode, encode), getSize) -import Flat.Decoder (Decoded, Get, strictDecoder) -import qualified Flat.Encoder as E -import Flat.Filler (postAligned, postAlignedDecoder) +import qualified Data.ByteString as B +import Data.ByteString.Convert (AsByteString (..)) +import Flat.Class (Flat (decode, encode), getSize) +import Flat.Decoder (Decoded, Get, strictDecoder) +import Flat.Encoder (NumBits) +import qualified Flat.Encoder as E +import Flat.Filler (postAligned, postAlignedDecoder) -- |Encode padded value. flat :: Flat a => a -> B.ByteString @@ -38,7 +40,16 @@ -- |Unflat unpadded value, using provided decoder unflatRawWith :: AsByteString b => Get a -> b -> Decoded a -unflatRawWith dec = strictDecoder dec . toByteString +unflatRawWith dec bs = unflatRawWithOffset dec bs 0 + +unflatRawWithOffset :: AsByteString b => Get a -> b -> NumBits -> Decoded a +unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs) + +-- unflatRawWith :: AsByteString b => Get a -> b -> Decoded a +-- unflatRawWith dec bs = unflatRawWithOffset dec bs 0 + +-- unflatRawWithOffset :: AsByteString b => Get a -> b -> Int -> Decoded a +-- unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs) -- |Encode unpadded value flatRaw :: (Flat a, AsByteString b) => a -> b diff --git a/src/Flat/Tutorial.hs b/src/Flat/Tutorial.hs --- a/src/Flat/Tutorial.hs +++ b/src/Flat/Tutorial.hs @@ -56,7 +56,7 @@ A pecularity of Flat is that it uses an optimal bit-encoding rather than the usual byte-oriented one. -One bit is all we need for a 'Result' or for an empty 'List' value: +One bit is sufficient to encode a 'Result' or an empty 'List': >>> flatBits Good "1" @@ -64,7 +64,7 @@ >>> flatBits (Nil::List Direction) "0" -Two or three bits suffice for a 'Direction' value: +Two or three bits suffice for a 'Direction': >>> flatBits South "01" @@ -100,6 +100,17 @@ >>> flatBits $ Just True "11" + +=== Wrapper Types + +There are a few wrapper types that modify the way encoding and/or decoding occur. + +* "Flat.AsBin" and "Flat.AsSize" decode to a value's flat binary representation or size in bits respectively. + +* 'Flat.Instances.Mono.AsArray' and 'Flat.Instances.Mono.AsList' encode/decode a sequence as a List or Array respectively, see "Flat.Instances.Mono" for details. + +* 'Flat.Instances.Text.UTF8Text' and 'Flat.Instances.Text.UTF16Text' encode/decode a Text as UTF8 or UTF16 respectively. + -} diff --git a/src/Flat/Types.hs b/src/Flat/Types.hs --- a/src/Flat/Types.hs +++ b/src/Flat/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -- |Common Types module Flat.Types ( NumBits, diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -39,4 +39,5 @@ # - Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459 # - parsec-3.1.15.0@sha256:a162d4cc8884014ba35192545cad293af0529fe11497aad8834bbaaa3dfffc26,4429 # - hashable-1.4.1.0@sha256:50b2f002c68fe67730ee7a3cd8607486197dd99b084255005ad51ecd6970a41b,5019 + allow-newer: true diff --git a/test/Big.hs b/test/Big.hs new file mode 100644 --- /dev/null +++ b/test/Big.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +Test different ways of handlings a data type that has large values and a small encoding. + +To run with limited memory: cabal run big -- +RTS -M2g +-} + +module Main where +import qualified Data.ByteString as B +import Data.List (foldl') +import Flat (Decoded, Flat (..), flat, unflat, unflatWith) +import Flat.AsBin (AsBin, unbin) +import Flat.AsSize +import Flat.Decoder (Get, listTDecoder) +import qualified ListT as L +import System.TimeIt (timeIt) + +-- Big is a type that has a small encoded representation but a very large in-memory footprint. +-- It is a very large bytestring whose bytes are all set to 0 +newtype Big = Big B.ByteString + +newBig :: Int -> Big +newBig gigas = Big $ B.replicate (gigas*giga) 0 + +-- length of Big in gigas +gigas :: Big -> Int +gigas (Big b) = B.length b `div` giga + +giga :: Int +giga = 1000000000 + +instance Show Big where show b = "Big of " ++ show (gigas b) ++ "Gbytes" + +instance Flat Big where + -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros) + size big = size (gigas big) + encode big = encode (gigas big) + + -- The decoded form is massive + decode = newBig <$> decode + +main :: IO () +main = tbig + +tbig = do + let numOfBigs = 5 + + -- A serialised list of Big values + let bigsFile = flat $ replicate numOfBigs $ newBig 1 + print "Encoding Time" + timeIt $ print $ B.length bigsFile + + tstAsSize bigsFile + + tstAsBin bigsFile + + tstListT bigsFile + + tstBig bigsFile + +-- If we unserialise a list of Bigs and then process them (e.g. print them out) we end up in trouble, too much memory is required. +tstBig :: B.ByteString -> IO () +tstBig bigsFile = timeIt $ do + print "Decode to [Big]:" + let Right (bs :: [Big]) = unflat bigsFile + mapM_ print bs + +-- So instead we unserialise them to a list of their flat representations, to be unflatted on demand later on +tstAsBin :: B.ByteString -> IO () +tstAsBin bigsFile = timeIt $ do + print "Decode to [AsBin Big]:" + let Right (bsR :: [AsBin Big]) = unflat bigsFile + let bs = map unbin bsR + mapM_ print bs + +tstAsSize :: B.ByteString -> IO () +tstAsSize bigsFile = timeIt $ do + print "Decode to [AsSize Big]:" + let Right (bs :: [AsSize Big]) = unflat bigsFile + mapM_ print bs + +-- Or: we extract one element at the time via a ListT +-- See http://hackage.haskell.org/package/list-t-1.0.4/docs/ListT.html +tstListT :: B.ByteString -> IO () +tstListT bigsFile = timeIt $ do + print "Decode to ListT IO Big:" + stream :: L.ListT IO Big <- listTDecoder decode bigsFile + L.traverse_ print stream diff --git a/test/DocTest/Flat/AsBin.hs b/test/DocTest/Flat/AsBin.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/AsBin.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ScopedTypeVariables#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.AsBin where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.AsBin +import Flat.Instances.Base +import Flat.Instances.Text +import Flat.Decoder.Types +import Flat.Types +import Flat.Run +import Data.Word +import qualified Data.Text as T +import Text.PrettyPrint.HughesPJClass + +tests :: IO TestTree +tests = testGroup "Flat.AsBin" <$> sequence [ DocTest.test "src/Flat/AsBin.hs:50" "[ExpectedLine [LineChunk \"Right [AsBin {repr = \\\"\\\\129A\\\", offsetBits = 1},AsBin {repr = \\\"A \\\", offsetBits = 2},AsBin {repr = \\\" \\\\193\\\", offsetBits = 3}]\"]]" (DocTest.asPrint( unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int]) )), DocTest.test "src/Flat/AsBin.hs:55" "[ExpectedLine [LineChunk \"Right 'a'\"]]" (DocTest.asPrint( unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char)) )), DocTest.test "src/Flat/AsBin.hs:60" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2) )), DocTest.test "src/Flat/AsBin.hs:65" "[ExpectedLine [LineChunk \"\\\"(0, _0000001 1, _1)\\\"\"]]" (DocTest.asPrint( let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t )), DocTest.test "src/Flat/AsBin.hs:80" "[ExpectedLine [LineChunk \"Right (AsBin {repr = \\\"\\\", offsetBits = 0})\"]]" (DocTest.asPrint( unflat (flat ()) :: Decoded (AsBin ()) )), DocTest.test "src/Flat/AsBin.hs:83" "[ExpectedLine [LineChunk \"Right (False,AsBin {repr = \\\"A\\\", offsetBits = 1})\"]]" (DocTest.asPrint( unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool) )), DocTest.test "src/Flat/AsBin.hs:86" "[ExpectedLine [LineChunk \"Right (False,False,AsBin {repr = \\\"?\\\\193\\\", offsetBits = 2})\"]]" (DocTest.asPrint( unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8) )), DocTest.test "src/Flat/AsBin.hs:89" "[ExpectedLine [LineChunk \"(False,False,255,True)\"]]" (DocTest.asPrint( let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3) ))] diff --git a/test/DocTest/Flat/AsSize.hs b/test/DocTest/Flat/AsSize.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Flat/AsSize.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ScopedTypeVariables#-} + +{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} +module DocTest.Flat.AsSize where +import qualified DocTest +import Test.Tasty(TestTree,testGroup) +import Flat.AsSize +import Flat.Instances.Base +import Flat.Instances.Text +import Flat.Decoder.Types +import Flat.Types +import Flat.Run +import Data.Word +import qualified Data.Text as T + +tests :: IO TestTree +tests = testGroup "Flat.AsSize" <$> sequence [ DocTest.test "src/Flat/AsSize.hs:38" "[ExpectedLine [LineChunk \"Right ('a',AsSize 28,'z',AsSize 1)\"]]" (DocTest.asPrint( let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool) )), DocTest.test "src/Flat/AsSize.hs:43" "[ExpectedLine [LineChunk \"Right (AsSize 8,AsSize 8)\"]]" (DocTest.asPrint( unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64) )), DocTest.test "src/Flat/AsSize.hs:48" "[ExpectedLine [LineChunk \"Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40)\"]]" (DocTest.asPrint( unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text) )), DocTest.test "src/Flat/AsSize.hs:53" "[ExpectedLine [LineChunk \"Right (AsSize 1,AsSize 96,AsSize 8)\"]]" (DocTest.asPrint( unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char) ))] diff --git a/test/DocTest/Flat/Decoder/Prim.hs b/test/DocTest/Flat/Decoder/Prim.hs --- a/test/DocTest/Flat/Decoder/Prim.hs +++ b/test/DocTest/Flat/Decoder/Prim.hs @@ -12,4 +12,4 @@ import Text.PrettyPrint.HughesPJClass (Pretty (pPrint)) tests :: IO TestTree -tests = testGroup "Flat.Decoder.Prim" <$> sequence [ DocTest.test "src/Flat/Decoder/Prim.hs:194" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 )), DocTest.test "src/Flat/Decoder/Prim.hs:197" "[ExpectedLine [LineChunk \"Left (BadOp \\\"read8: cannot read 9 bits\\\")\"]]" (DocTest.asPrint( unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] )), DocTest.test "src/Flat/Decoder/Prim.hs:210" "[ExpectedLine [LineChunk \"Right 00000101 10111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] )), DocTest.test "src/Flat/Decoder/Prim.hs:215" "[ExpectedLine [LineChunk \"Right 00000111 11111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] ))] +tests = testGroup "Flat.Decoder.Prim" <$> sequence [ DocTest.test "src/Flat/Decoder/Prim.hs:198" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 )), DocTest.test "src/Flat/Decoder/Prim.hs:201" "[ExpectedLine [LineChunk \"Left (BadOp \\\"read8: cannot read 9 bits\\\")\"]]" (DocTest.asPrint( unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] )), DocTest.test "src/Flat/Decoder/Prim.hs:214" "[ExpectedLine [LineChunk \"Right 00000101 10111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] )), DocTest.test "src/Flat/Decoder/Prim.hs:219" "[ExpectedLine [LineChunk \"Right 00000111 11111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] ))] diff --git a/test/DocTest/Flat/Repr.hs b/test/DocTest/Flat/Repr.hs deleted file mode 100644 --- a/test/DocTest/Flat/Repr.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables#-} - -{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-} -module DocTest.Flat.Repr where -import qualified DocTest -import Test.Tasty(TestTree,testGroup) -import Flat.Repr -import Flat.Instances.Base -import Flat.Decoder.Types -import Flat.Types -import Flat.Run -import Flat.Class - -tests :: IO TestTree -tests = testGroup "Flat.Repr" <$> sequence [ DocTest.test "src/Flat/Repr.hs:27" "[ExpectedLine [LineChunk \"Right [Repr {repr = \\\"\\\\STX\\\\SOH\\\"},Repr {repr = \\\"\\\\EOT\\\\SOH\\\"},Repr {repr = \\\"\\\\ACK\\\\SOH\\\"},Repr {repr = \\\"\\\\b\\\\SOH\\\"},Repr {repr = \\\"\\\\n\\\\SOH\\\"}]\"]]" (DocTest.asPrint( unflat (flat [1::Int .. 5]) :: Decoded ([Repr Int]) )), DocTest.test "src/Flat/Repr.hs:32" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( let Right l = unflat (flat [1..5]) :: Decoded [Repr Int] in unrepr (l !! 2) )), DocTest.test "src/Flat/Repr.hs:42" "[ExpectedLine [LineChunk \"Right ('a',SizeOf 28,'z',SizeOf 1)\"]]" (DocTest.asPrint( let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,SizeOf String,Char,SizeOf Bool) ))] diff --git a/test/DocTests.hs b/test/DocTests.hs --- a/test/DocTests.hs +++ b/test/DocTests.hs @@ -1,23 +1,6 @@ module Main where import Test.Tasty import Test.Tasty.HUnit -import qualified DocTest.Flat.Bits -import qualified DocTest.Flat.Repr -import qualified DocTest.Flat.Instances.Array -import qualified DocTest.Flat.Instances.ByteString -import qualified DocTest.Flat.Instances.DList -import qualified DocTest.Flat.Instances.Extra -import qualified DocTest.Flat.Instances.Containers -import qualified DocTest.Flat.Instances.Base -import qualified DocTest.Flat.Instances.Unordered -import qualified DocTest.Flat.Instances.Vector -import qualified DocTest.Flat.Instances.Mono -import qualified DocTest.Flat.Instances.Text -import qualified DocTest.Flat.Encoder.Prim -import qualified DocTest.Flat.Tutorial -import qualified DocTest.Flat.Decoder.Prim -import qualified DocTest.Flat.Endian -import qualified DocTest.Data.ZigZag -import qualified DocTest.Data.FloatCast +import qualified DocTest.Flat.AsBin -main = (testGroup "DocTests" <$> sequence [DocTest.Flat.Bits.tests,DocTest.Flat.Repr.tests,DocTest.Flat.Instances.Array.tests,DocTest.Flat.Instances.ByteString.tests,DocTest.Flat.Instances.DList.tests,DocTest.Flat.Instances.Extra.tests,DocTest.Flat.Instances.Containers.tests,DocTest.Flat.Instances.Base.tests,DocTest.Flat.Instances.Unordered.tests,DocTest.Flat.Instances.Vector.tests,DocTest.Flat.Instances.Mono.tests,DocTest.Flat.Instances.Text.tests,DocTest.Flat.Encoder.Prim.tests,DocTest.Flat.Tutorial.tests,DocTest.Flat.Decoder.Prim.tests,DocTest.Flat.Endian.tests,DocTest.Data.ZigZag.tests,DocTest.Data.FloatCast.tests]) >>= defaultMain +main = (testGroup "DocTests" <$> sequence [DocTest.Flat.AsBin.tests]) >>= defaultMain diff --git a/test/FlatRepr.hs b/test/FlatRepr.hs deleted file mode 100644 --- a/test/FlatRepr.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Main where -import qualified Data.ByteString as B -import Data.List (foldl') -import Flat (Decoded, Flat (..), flat, unflat, unflatWith) -import Flat.Decoder (Get, listTDecoder) -import Flat.Repr (Repr, unrepr) -import qualified ListT as L -import System.TimeIt (timeIt) - --- Big is a type that has a small encoded representation but a very large in-memory footprint. --- It is a very large bytestring whose bytes are all set to 0 -newtype Big = Big B.ByteString - -newBig :: Int -> Big -newBig gigas = Big $ B.replicate (gigas*giga) 0 - --- length of Big in gigas -gigas :: Big -> Int -gigas (Big b) = B.length b `div` giga - -giga :: Int -giga = 1000000000 - -instance Show Big where show b = "Big of " ++ show (gigas b) ++ "Gbytes" - -instance Flat Big where - -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros) - size big = size (gigas big) - encode big = encode (gigas big) - - -- The decoded form is massive - decode = newBig <$> decode - --- Run this as: cabal run FlatRepr -- +RTS -M2g -main :: IO () -main = tbig - -tbig = do - let numOfBigs = 5 - - -- A serialised list of Big values - let bigsFile = flat $ replicate numOfBigs $ newBig 1 - timeIt $ print $ B.length bigsFile - - -- tstSize bigsFile - - tstListT bigsFile - - tstRepr bigsFile - - tstBig bigsFile - --- If we unserialise a list of Bigs and then process them (e.g. print them out) we end up in trouble, too much memory is required. -tstBig :: B.ByteString -> IO () -tstBig bigsFile = timeIt $ do - print "Decode to [Big]:" - let Right (bs :: [Big]) = unflat bigsFile - mapM_ print bs - --- So instead we unserialise them to a list of their flat representations, to be unflatted on demand later on -tstRepr :: B.ByteString -> IO () -tstRepr bigsFile = timeIt $ do - print "Decode to [FlatRepl Big]:" - let Right (bsR :: [Repr Big]) = unflat bigsFile - let bs = map unrepr bsR - mapM_ print bs - --- Or: we extract one element at the time via a ListT --- See http://hackage.haskell.org/package/list-t-1.0.4/docs/ListT.html -tstListT :: B.ByteString -> IO () -tstListT bigsFile = timeIt $ do - print "Decode to ListT IO Big:" - stream :: L.ListT IO Big <- listTDecoder decode bigsFile - L.traverse_ print stream