diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,31 +1,201 @@ -Copyright (c) Warlock -Copyright (c) Lennart Kolmodin + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ -All rights reserved. + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: + 1. Definitions. -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. -2. 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. + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. -THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright {yyyy} {name of copyright owner} + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,26 +0,0 @@ -# binary-ext package # - -An alternate with typed errors for ``Data.Binary.Get`` monad from ``binary`` library. - -## Building binary-ext ## - -Here's how to get the latest version of the repository and build. - - $ git clone https://github.com/A1-Triard/binary-ext.git - $ cd binary-ext - $ stack build - -Run the test suite. - - $ stack test - -## Using binary-ext ## - -First: - - import Data.Binary.Put - import Data.Binary.Get.Ext - -and then use the ``Get`` and ``Put`` monads to serialize/deserialize. - -More information in the haddock documentation. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/binary-ext.cabal b/binary-ext.cabal --- a/binary-ext.cabal +++ b/binary-ext.cabal @@ -1,88 +1,104 @@ -name: binary-ext -version: 1.0.8.5.1 -license: BSD3 -license-file: LICENSE -author: Warlock -maintainer: Warlock -homepage: https://github.com/A1-Triard/binary-ext -description: An alternate with typed errors for Data.Binary.Get monad from 'binary' library. -synopsis: An alternate with typed errors for Data.Binary.Get monad from 'binary' library. -category: Data, Parsing -stability: provisional -build-type: Simple -cabal-version: >= 1.8 -tested-with: GHC == 8.0.2 -extra-source-files: - README.md - -source-repository head - type: git - location: git://github.com/A1-Triard/binary-ext.git +name: binary-ext +version: 2.0 +synopsis: An alternate with strong-typed errors for `Data.Binary.Get` monad from `binary` package. +description: An alternate with strong-typed errors for `Data.Binary.Get` monad from `binary` package. +homepage: https://github.com/A1-Triard/binary-ext#readme +license: Apache +license-file: LICENSE +author: Warlock +maintainer: Warlock +copyright: 2017 Warlock +category: Data, Parsing +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 library - build-depends: base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array - , binary - hs-source-dirs: src - exposed-modules: Data.Binary.Get.Ext - , Data.Binary.Get.Ext.Internal - - other-modules: Data.Binary.Internal, - Data.Binary.FloatCast - if impl(ghc <= 7.6) - -- prior to ghc-7.4 generics lived in ghc-prim - build-depends: ghc-prim - - ghc-options: -O2 -Wall -fliberate-case-threshold=1000 - - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - --- Due to circular dependency, we cannot make any of the test-suites or --- benchmark depend on the binary library. Instead, for each test-suite and --- benchmark, we include the source directory of binary and build-depend on all --- the dependencies binary has. - -test-suite qc - type: exitcode-stdio-1.0 - hs-source-dirs: src tests - main-is: QC.hs - other-modules: Action - , Arbitrary - , Data.Binary.Get.Ext - , Data.Binary.Get.Ext.Internal - , Data.Binary.Internal - , Data.Binary.FloatCast - build-depends: base >= 4.5.0.0 && < 5 + hs-source-dirs: src + exposed-modules: Control.Monad.Error.Map + , Data.Conduit.Parsers + , Data.Conduit.Parsers.GetC + , Data.Conduit.Parsers.PutS + , Data.Conduit.Parsers.Binary + , Data.Conduit.Parsers.Binary.ByteOffset + , Data.Conduit.Parsers.Binary.Get + , Data.Conduit.Parsers.Binary.Put + , Data.Conduit.Parsers.Text + , Data.Conduit.Parsers.Text.Gen + , Data.Conduit.Parsers.Text.Parser + , Data.Conduit.Parsers.Text.TextOffset + build-depends: base >= 4.7 && < 5 + , attoparsec , binary - , bytestring >= 0.10.2 - , random>=1.0.1.0 - , test-framework - , test-framework-quickcheck2 >= 0.3 - , QuickCheck - - -- build dependencies from using binary source rather than depending on the library - build-depends: array, containers - ghc-options: -Wall -O2 -threaded - if impl(ghc <= 7.6) - -- prior to ghc-7.4 generics lived in ghc-prim - build-depends: ghc-prim - + , bytestring + , conduit >= 1.2.12 + , conduit-combinators + , data-binary-ieee754 + , errors + , exceptions + , monad-control + , monad-loops + , mono-traversable + , mtl + , scientific + , text + , transformers + , transformers-base + default-extensions: BangPatterns + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , StandaloneDeriving + , RankNTypes + , TupleSections + , TypeFamilies + , UndecidableInstances + ghc-options: -fmax-pmcheck-iterations=100000000 -Wall -fprint-potential-instances -fsimpl-tick-factor=110 + default-language: Haskell2010 -test-suite read-write-file - type: exitcode-stdio-1.0 - hs-source-dirs: src tests - main-is: File.hs - build-depends: base >= 4.5.0.0 && < 5 - , bytestring >= 0.10.2 - , Cabal - , binary - , directory - , filepath +test-suite binary-ext-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Data.Conduit.Parsers.Binary.Get.Spec + , Data.Conduit.Parsers.Binary.Put.Spec + , Data.Conduit.Parsers.Text.Parser.Spec + build-depends: base , HUnit + , binary-ext + , attoparsec + , binary + , bytestring + , conduit >= 1.2.12 + , conduit-combinators + , data-binary-ieee754 + , errors + , exceptions + , monad-control + , monad-loops + , mono-traversable + , mtl + , scientific + , text + , transformers + , transformers-base + default-extensions: BangPatterns + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , OverloadedStrings + , StandaloneDeriving + , RankNTypes + , TupleSections + , TypeFamilies + , UndecidableInstances + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fmax-pmcheck-iterations=100000000 -Wall -fprint-potential-instances -fsimpl-tick-factor=110 + default-language: Haskell2010 - -- build dependencies from using binary source rather than depending on the library - build-depends: array, containers - ghc-options: -Wall -Wno-unused-imports - if impl(ghc <= 7.6) - -- prior to ghc-7.4 generics lived in ghc-prim - build-depends: ghc-prim +source-repository head + type: git + location: https://github.com/A1-Triard/binary-ext diff --git a/src/Control/Monad/Error/Map.hs b/src/Control/Monad/Error/Map.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Error/Map.hs @@ -0,0 +1,180 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Control.Monad.Error.Map + ( MonadMapError (..) + , (?=>>) + , (?>>) + , option'' + , many'' + , many1'' + , manyTill'' + , sepBy'' + , sepBy1'' + , skipMany'' + , skipMany1'' + ) where + +import Prelude hiding (head, tail, init, last, minimum) +import Control.Monad +import Control.Monad.Error.Class +import Control.Monad.Trans.Except +import Data.Conduit +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Void + +class (MonadError e m_e, MonadError e' m_e') => MonadMapError e m_e e' m_e' | m_e -> e, m_e' -> e', m_e e' -> m_e', m_e' e -> m_e where + mapError :: (e -> e') -> m_e a -> m_e' a + +instance MonadMapError e (Either e) e' (Either e') where + mapError f = either (Left . f) Right + {-# INLINE mapError #-} + +instance Monad m => MonadMapError e (ExceptT e m) e' (ExceptT e' m) where + mapError f = ExceptT . (mapError f <$>) . runExceptT + {-# INLINE mapError #-} + +instance MonadMapError e m_e e' m_e' => MonadMapError e (ConduitM i o m_e) e' (ConduitM i o m_e') where + mapError f = transPipe (mapError f) + {-# INLINE mapError #-} + +infixl 1 ?=>> +(?=>>) :: + ( MonadMapError e m_e (Either e e') m_Either_e_e' + , MonadMapError Void m_Void (Either e e') m_Either_e_e' + , MonadMapError (Either e e') m_Either_e_e' e' m_e' + ) => m_e a -> (e -> m_Void e') -> m_e' a +(?=>>) action mapper = + mapError (either (error "?=>>") id) + $ catchError (mapError Left action) + $ ((throwError . Right) =<<) . mapError absurd . mapper . either id (error "?=>>") +{-# INLINE (?=>>) #-} + +infixl 1 ?>> +(?>>) :: + ( MonadMapError () m_Unit (Maybe e) m_Maybe_e + , MonadMapError Void m_Void (Maybe e) m_Maybe_e + , MonadMapError (Maybe e) m_Maybe_e e m_e + ) => m_Unit a -> m_Void e -> m_e a +(?>>) action mapper = + mapError (fromMaybe (error "?>>")) + $ catchError (mapError (const Nothing) action) + $ const $ (throwError . Just) =<< mapError absurd mapper +{-# INLINE (?>>) #-} + +option'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e' m_e' + ) => m_e a -> m_e' (Maybe a) +option'' !x = mapError (error "Control.Monad.Error.Map.option''") $ mapError (const ()) (Just <$> x) `mplus` return Nothing +{-# INLINE option'' #-} + +many'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e' m_e' + ) => m_e a -> m_e' [a] +many'' !x = + reverse <$> go [] + where + go !r = do + !n <- option'' x + case n of + Nothing -> return r + Just !c -> go (c : r) +{-# INLINE many'' #-} + +many1'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e m_e + ) => m_e a -> m_e (NonEmpty a) +many1'' !x = do + !h <- x + !t <- many'' x + return $ h :| t +{-# INLINE many1'' #-} + +manyTill'' :: + ( MonadPlus m_Unit + , MonadMapError e' m_e' () m_Unit + , MonadMapError () m_Unit e m_e + ) => m_e a -> m_e' b -> m_e [a] +manyTill'' !x !end = + reverse <$> go [] + where + go !r = do + !n <- option'' end + case n of + Just _ -> return r + Nothing -> do + !c <- x + go (c : r) +{-# INLINE manyTill'' #-} + +sepBy'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e'' m_e'' + , MonadMapError e' m_e' () m_Unit + , MonadMapError () m_Unit () m_Unit + ) => m_e a -> m_e' s -> m_e'' [a] +sepBy'' !x !sep = do + !h <- option'' x + case h of + Nothing -> return [] + Just c -> do + !t <- many'' (mapError (const ()) sep >> mapError (const ()) x) + return $ c : t +{-# INLINE sepBy'' #-} + +sepBy1'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e m_e + , MonadMapError e' m_e' () m_Unit + , MonadMapError () m_Unit () m_Unit + ) => m_e a -> m_e' s -> m_e (NonEmpty a) +sepBy1'' !x !sep = do + !h <- x + !t <- many'' (mapError (const ()) sep >> mapError (const ()) x) + return $ h :| t +{-# INLINE sepBy1'' #-} + +skipMany'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e' m_e' + ) => m_e a -> m_e' () +skipMany'' !x = + go + where + go = do + n <- option'' x + case n of + Nothing -> return () + Just _ -> go +{-# INLINE skipMany'' #-} + +skipMany1'' :: + ( MonadPlus m_Unit + , MonadMapError e m_e () m_Unit + , MonadMapError () m_Unit e m_e + ) => m_e a -> m_e () +skipMany1'' !x = x >> skipMany'' x +{-# INLINE skipMany1'' #-} diff --git a/src/Data/Binary/FloatCast.hs b/src/Data/Binary/FloatCast.hs deleted file mode 100644 --- a/src/Data/Binary/FloatCast.hs +++ /dev/null @@ -1,45 +0,0 @@ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} - --- | This module was written based on --- . --- --- Implements casting via a 1-elemnt STUArray, as described in --- . -module Data.Binary.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 `Word32` to a `Float`. -wordToFloat :: Word32 -> Float -wordToFloat x = runST (cast x) -{-# INLINE wordToFloat #-} - --- | Reinterpret-casts a `Double` to a `Word64`. -doubleToWord :: Double -> Word64 -doubleToWord x = runST (cast x) -{-# INLINE doubleToWord #-} - --- | 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 #-} diff --git a/src/Data/Binary/Get/Ext.hs b/src/Data/Binary/Get/Ext.hs deleted file mode 100644 --- a/src/Data/Binary/Get/Ext.hs +++ /dev/null @@ -1,524 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-} -{-# LANGUAGE Trustworthy #-} - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.Binary.Get.Ext ( - -- * The Get monad - Get - - -- * The lazy input interface - -- $lazyinterface - , runGetOrFail - , ByteOffset - - -- * The incremental input interface - -- $incrementalinterface - , Decoder(..) - , runGetIncremental - - -- ** Providing input - , pushChunk - , pushChunks - , pushEndOfInput - - -- * Decoding - , skip - , isEmpty - , bytesRead - , totalBytesRead - , isolate - , lookAhead - , lookAheadM - , lookAheadE - , label - , onError - , withError - , failG - - -- ** ByteStrings - , getByteString - , getLazyByteString - , getLazyByteStringNul - , getRemainingLazyByteString - - -- ** Decoding Words - , getWord8 - - -- *** Big-endian decoding - , getWord16be - , getWord32be - , getWord64be - - -- *** Little-endian decoding - , getWord16le - , getWord32le - , getWord64le - - -- *** Host-endian, unaligned decoding - , getWordhost - , getWord16host - , getWord32host - , getWord64host - - -- ** Decoding Ints - , getInt8 - - -- *** Big-endian decoding - , getInt16be - , getInt32be - , getInt64be - - -- *** Little-endian decoding - , getInt16le - , getInt32le - , getInt64le - - -- *** Host-endian, unaligned decoding - , getInthost - , getInt16host - , getInt32host - , getInt64host - - -- ** Decoding Floats/Doubles - , getFloatbe - , getFloatle - , getFloathost - , getDoublebe - , getDoublele - , getDoublehost - - ) where -#if ! MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -import Foreign -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L - -import Data.Binary.Get.Ext.Internal hiding ( Decoder(..), runGetIncremental ) -import qualified Data.Binary.Get.Ext.Internal as I - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) --- needed for (# unboxing #) with magic hash -import GHC.Base -import GHC.Word -#endif - --- needed for casting words to float/double -import Data.Binary.FloatCast (wordToFloat, wordToDouble) - --- $lazyinterface --- The lazy interface consumes a single lazy 'L.ByteString'. It's the easiest --- interface to get started with, but it doesn't support interleaving I\/O and --- parsing, unless lazy I/O is used. --- --- There is no way to provide more input other than the initial data. To be --- able to incrementally give more data, see the incremental input interface. - --- $incrementalinterface --- The incremental interface gives you more control over how input is --- provided during parsing. This lets you e.g. interleave parsing and --- I\/O. --- --- The incremental interface consumes a strict 'B.ByteString' at a time, each --- being part of the total amount of input. If your decoder needs more input to --- finish it will return a 'Partial' with a continuation. --- If there is no more input, provide it 'Nothing'. --- --- 'Fail' will be returned if it runs into an error, together with a message, --- the position and the remaining input. --- If it succeeds it will return 'Done' with the resulting value, --- the position and the remaining input. - --- | A decoder procuced by running a 'Get' monad. -data Decoder e a = Fail !B.ByteString {-# UNPACK #-} !ByteOffset (Either String e) - -- ^ The decoder ran into an error. The decoder either used - -- 'fail' or was not provided enough input. Contains any - -- unconsumed input and the number of bytes consumed. - | Partial (Maybe B.ByteString -> Decoder e a) - -- ^ The decoder has consumed the available input and needs - -- more to continue. Provide 'Just' if more input is available - -- and 'Nothing' otherwise, and you will get a new 'Decoder'. - | Done !B.ByteString {-# UNPACK #-} !ByteOffset a - -- ^ The decoder has successfully finished. Except for the - -- output value you also get any unused input as well as the - -- number of bytes consumed. - --- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing --- input, handling decoder errors and to get the output value. --- Hint: Use the helper functions 'pushChunk', 'pushChunks' and --- 'pushEndOfInput'. -runGetIncremental :: ByteOffset -> Get e a -> Decoder e a -runGetIncremental base_offset = calculateOffset base_offset . I.runGetIncremental base_offset - -calculateOffset :: ByteOffset -> I.Decoder e a -> Decoder e a -calculateOffset base_offset r0 = go r0 0 - where - go r !acc = case r of - I.Done inp a -> Done inp (base_offset + (acc - fromIntegral (B.length inp))) a - I.Fail inp s -> Fail inp (base_offset + (acc - fromIntegral (B.length inp))) s - I.Partial k -> - Partial $ \ms -> - case ms of - Nothing -> go (k Nothing) acc - Just i -> go (k ms) (acc + fromIntegral (B.length i)) - I.BytesRead unused k -> - go (k $! (acc - unused)) acc - -takeHeadChunk :: L.ByteString -> Maybe B.ByteString -takeHeadChunk lbs = - case lbs of - (L.Chunk bs _) -> Just bs - _ -> Nothing - -dropHeadChunk :: L.ByteString -> L.ByteString -dropHeadChunk lbs = - case lbs of - (L.Chunk _ lbs') -> lbs' - _ -> L.Empty - --- | Run a 'Get' monad and return 'Left' on failure and 'Right' on --- success. In both cases any unconsumed input and the number of bytes --- consumed is returned. In the case of failure, a human-readable --- error message is included as well. -runGetOrFail :: ByteOffset -> Get e a -> L.ByteString - -> Either (L.ByteString, ByteOffset, Either String e) (L.ByteString, ByteOffset, a) -runGetOrFail ge g lbs0 = feedAll (runGetIncremental ge g) lbs0 - where - feedAll (Done bs pos x) lbs = Right (L.chunk bs lbs, pos, x) - feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs) - feedAll (Fail x pos msg) xs = Left (L.chunk x xs, pos, msg) - --- | An offset, counted in bytes. -type ByteOffset = Int64 - --- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it --- will add the input to 'B.ByteString' of unconsumed input. --- --- @ --- 'runGetIncremental' myParser \`pushChunk\` myInput1 \`pushChunk\` myInput2 --- @ -pushChunk :: Decoder e a -> B.ByteString -> Decoder e a -pushChunk r inp = - case r of - Done inp0 p a -> Done (inp0 `B.append` inp) p a - Partial k -> k (Just inp) - Fail inp0 p s -> Fail (inp0 `B.append` inp) p s - - --- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it --- will add the input to 'ByteString' of unconsumed input. --- --- @ --- 'runGetIncremental' myParser \`pushChunks\` myLazyByteString --- @ -pushChunks :: Decoder e a -> L.ByteString -> Decoder e a -pushChunks r0 = go r0 . L.toChunks - where - go r [] = r - go (Done inp pos a) xs = Done (B.concat (inp:xs)) pos a - go (Fail inp pos s) xs = Fail (B.concat (inp:xs)) pos s - go (Partial k) (x:xs) = go (k (Just x)) xs - --- | Tell a 'Decoder' that there is no more input. This passes 'Nothing' to a --- 'Partial' decoder, otherwise returns the decoder unchanged. -pushEndOfInput :: Decoder e a -> Decoder e a -pushEndOfInput r = - case r of - Done _ _ _ -> r - Partial k -> k Nothing - Fail _ _ _ -> r - --- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. -skip :: Int -> Get () () -skip n = withInputChunks (fromIntegral n) consumeBytes (const ()) failOnEOF - --- | An efficient get method for lazy ByteStrings. Fails if fewer than @n@ --- bytes are left in the input. -getLazyByteString :: Int64 -> Get () L.ByteString -getLazyByteString n0 = withInputChunks n0 consumeBytes L.fromChunks failOnEOF - -consumeBytes :: Consume Int64 -consumeBytes n str - | fromIntegral (B.length str) >= n = Right (B.splitAt (fromIntegral n) str) - | otherwise = Left (n - fromIntegral (B.length str)) - -consumeUntilNul :: Consume () -consumeUntilNul _ str = - case B.break (==0) str of - (want, rest) | B.null rest -> Left () - | otherwise -> Right (want, B.drop 1 rest) - -consumeAll :: Consume () -consumeAll _ _ = Left () - -resumeOnEOF :: [B.ByteString] -> Get e L.ByteString -resumeOnEOF = return . L.fromChunks - --- | Get a lazy ByteString that is terminated with a NUL byte. --- The returned string does not contain the NUL byte. Fails --- if it reaches the end of input without finding a NUL. -getLazyByteStringNul :: Get () L.ByteString -getLazyByteStringNul = withInputChunks () consumeUntilNul L.fromChunks failOnEOF - --- | Get the remaining bytes as a lazy ByteString. --- Note that this can be an expensive function to use as it forces reading --- all input and keeping the string in-memory. -getRemainingLazyByteString :: Get e L.ByteString -getRemainingLazyByteString = withInputChunks () consumeAll L.fromChunks resumeOnEOF - ------------------------------------------------------------------------- --- Primtives - --- helper, get a raw Ptr onto a strict ByteString copied out of the --- underlying lazy byteString. - -getPtr :: Storable a => Int -> Get () a -getPtr n = readNWith n peek -{-# INLINE getPtr #-} - --- | Read a Word8 from the monad state -getWord8 :: Get () Word8 -getWord8 = readN 1 B.unsafeHead -{-# INLINE[2] getWord8 #-} - --- | Read an Int8 from the monad state -getInt8 :: Get () Int8 -getInt8 = fromIntegral <$> getWord8 -{-# INLINE getInt8 #-} - - --- force GHC to inline getWordXX -{-# RULES -"getWord8/readN" getWord8 = readN 1 B.unsafeHead -"getWord16be/readN" getWord16be = readN 2 word16be -"getWord16le/readN" getWord16le = readN 2 word16le -"getWord32be/readN" getWord32be = readN 4 word32be -"getWord32le/readN" getWord32le = readN 4 word32le -"getWord64be/readN" getWord64be = readN 8 word64be -"getWord64le/readN" getWord64le = readN 8 word64le #-} - --- | Read a Word16 in big endian format -getWord16be :: Get () Word16 -getWord16be = readN 2 word16be - -word16be :: B.ByteString -> Word16 -word16be = \s -> - (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. - (fromIntegral (s `B.unsafeIndex` 1)) -{-# INLINE[2] getWord16be #-} -{-# INLINE word16be #-} - --- | Read a Word16 in little endian format -getWord16le :: Get () Word16 -getWord16le = readN 2 word16le - -word16le :: B.ByteString -> Word16 -word16le = \s -> - (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. - (fromIntegral (s `B.unsafeIndex` 0) ) -{-# INLINE[2] getWord16le #-} -{-# INLINE word16le #-} - --- | Read a Word32 in big endian format -getWord32be :: Get () Word32 -getWord32be = readN 4 word32be - -word32be :: B.ByteString -> Word32 -word32be = \s -> - (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|. - (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. - (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. - (fromIntegral (s `B.unsafeIndex` 3) ) -{-# INLINE[2] getWord32be #-} -{-# INLINE word32be #-} - --- | Read a Word32 in little endian format -getWord32le :: Get () Word32 -getWord32le = readN 4 word32le - -word32le :: B.ByteString -> Word32 -word32le = \s -> - (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|. - (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. - (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. - (fromIntegral (s `B.unsafeIndex` 0) ) -{-# INLINE[2] getWord32le #-} -{-# INLINE word32le #-} - --- | Read a Word64 in big endian format -getWord64be :: Get () Word64 -getWord64be = readN 8 word64be - -word64be :: B.ByteString -> Word64 -word64be = \s -> - (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|. - (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|. - (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|. - (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|. - (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|. - (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. - (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. - (fromIntegral (s `B.unsafeIndex` 7) ) -{-# INLINE[2] getWord64be #-} -{-# INLINE word64be #-} - --- | Read a Word64 in little endian format -getWord64le :: Get () Word64 -getWord64le = readN 8 word64le - -word64le :: B.ByteString -> Word64 -word64le = \s -> - (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|. - (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|. - (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|. - (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|. - (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|. - (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. - (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. - (fromIntegral (s `B.unsafeIndex` 0) ) -{-# INLINE[2] getWord64le #-} -{-# INLINE word64le #-} - - --- | Read an Int16 in big endian format. -getInt16be :: Get () Int16 -getInt16be = fromIntegral <$> getWord16be -{-# INLINE getInt16be #-} - --- | Read an Int32 in big endian format. -getInt32be :: Get () Int32 -getInt32be = fromIntegral <$> getWord32be -{-# INLINE getInt32be #-} - --- | Read an Int64 in big endian format. -getInt64be :: Get () Int64 -getInt64be = fromIntegral <$> getWord64be -{-# INLINE getInt64be #-} - - --- | Read an Int16 in little endian format. -getInt16le :: Get () Int16 -getInt16le = fromIntegral <$> getWord16le -{-# INLINE getInt16le #-} - --- | Read an Int32 in little endian format. -getInt32le :: Get () Int32 -getInt32le = fromIntegral <$> getWord32le -{-# INLINE getInt32le #-} - --- | Read an Int64 in little endian format. -getInt64le :: Get () Int64 -getInt64le = fromIntegral <$> getWord64le -{-# INLINE getInt64le #-} - - ------------------------------------------------------------------------- --- Host-endian reads - --- | /O(1)./ Read a single native machine word. The word is read in --- host order, host endian form, for the machine you're on. On a 64 bit --- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. -getWordhost :: Get () Word -getWordhost = getPtr (sizeOf (undefined :: Word)) -{-# INLINE getWordhost #-} - --- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. -getWord16host :: Get () Word16 -getWord16host = getPtr (sizeOf (undefined :: Word16)) -{-# INLINE getWord16host #-} - --- | /O(1)./ Read a Word32 in native host order and host endianness. -getWord32host :: Get () Word32 -getWord32host = getPtr (sizeOf (undefined :: Word32)) -{-# INLINE getWord32host #-} - --- | /O(1)./ Read a Word64 in native host order and host endianess. -getWord64host :: Get () Word64 -getWord64host = getPtr (sizeOf (undefined :: Word64)) -{-# INLINE getWord64host #-} - --- | /O(1)./ Read a single native machine word in native host --- order. It works in the same way as 'getWordhost'. -getInthost :: Get () Int -getInthost = getPtr (sizeOf (undefined :: Int)) -{-# INLINE getInthost #-} - --- | /O(1)./ Read a 2 byte Int16 in native host order and host endianness. -getInt16host :: Get () Int16 -getInt16host = getPtr (sizeOf (undefined :: Int16)) -{-# INLINE getInt16host #-} - --- | /O(1)./ Read an Int32 in native host order and host endianness. -getInt32host :: Get () Int32 -getInt32host = getPtr (sizeOf (undefined :: Int32)) -{-# INLINE getInt32host #-} - --- | /O(1)./ Read an Int64 in native host order and host endianess. -getInt64host :: Get () Int64 -getInt64host = getPtr (sizeOf (undefined :: Int64)) -{-# INLINE getInt64host #-} - - ------------------------------------------------------------------------- --- Double/Float reads - --- | Read a 'Float' in big endian IEEE-754 format. -getFloatbe :: Get () Float -getFloatbe = wordToFloat <$> getWord32be -{-# INLINE getFloatbe #-} - --- | Read a 'Float' in little endian IEEE-754 format. -getFloatle :: Get () Float -getFloatle = wordToFloat <$> getWord32le -{-# INLINE getFloatle #-} - --- | Read a 'Float' in IEEE-754 format and host endian. -getFloathost :: Get () Float -getFloathost = wordToFloat <$> getWord32host -{-# INLINE getFloathost #-} - --- | Read a 'Double' in big endian IEEE-754 format. -getDoublebe :: Get () Double -getDoublebe = wordToDouble <$> getWord64be -{-# INLINE getDoublebe #-} - --- | Read a 'Double' in little endian IEEE-754 format. -getDoublele :: Get () Double -getDoublele = wordToDouble <$> getWord64le -{-# INLINE getDoublele #-} - --- | Read a 'Double' in IEEE-754 format and host endian. -getDoublehost :: Get () Double -getDoublehost = wordToDouble <$> getWord64host -{-# INLINE getDoublehost #-} - ------------------------------------------------------------------------- --- Unchecked shifts - -shiftl_w16 :: Word16 -> Int -> Word16 -shiftl_w32 :: Word32 -> Int -> Word32 -shiftl_w64 :: Word64 -> Int -> Word64 - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) -shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) - -#else -shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) -#endif - -#else -shiftl_w16 = shiftL -shiftl_w32 = shiftL -shiftl_w64 = shiftL -#endif diff --git a/src/Data/Binary/Get/Ext/Internal.hs b/src/Data/Binary/Get/Ext/Internal.hs deleted file mode 100644 --- a/src/Data/Binary/Get/Ext/Internal.hs +++ /dev/null @@ -1,428 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns, TypeFamilies #-} - --- CPP C style pre-precessing, the #if defined lines --- RankNTypes forall r. statement --- MagicHash the (# unboxing #), also needs GHC.primitives - -module Data.Binary.Get.Ext.Internal ( - - -- * The Get e type - Get - , runCont - , Decoder(..) - , runGetIncremental - - , readN - , readNWith - - -- * Parsing - , bytesRead - , totalBytesRead - , isolate - - -- * With input chunks - , withInputChunks - , Consume - , failOnEOF - - , get - , put - , ensureN - - -- * Utility - , isEmpty - , failG - , lookAhead - , lookAheadM - , lookAheadE - , label - , onError - , withError - - -- ** ByteStrings - , getByteString - - ) where - -import Foreign -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - -import Data.Binary.Internal ( accursedUnutterablePerformIO ) - --- Kolmodin 20100427: at zurihac we discussed of having partial take a --- "Maybe ByteString" and implemented it in this way. --- The reasoning was that you could accidently provide an empty bytestring, --- and it should not terminate the decoding (empty would mean eof). --- However, I'd say that it's also a risk that you get stuck in a loop, --- where you keep providing an empty string. Anyway, no new input should be --- rare, as the RTS should only wake you up if you actually have some data --- to read from your fd. - --- | A decoder produced by running a 'Get' monad. -data Decoder e a = Fail !B.ByteString (Either String e) - -- ^ The decoder ran into an error. The decoder either used - -- 'fail' or was not provided enough input. - | Partial (Maybe B.ByteString -> Decoder e a) - -- ^ The decoder has consumed the available input and needs - -- more to continue. Provide 'Just' if more input is available - -- and 'Nothing' otherwise, and you will get a new 'Decoder'. - | Done !B.ByteString a - -- ^ The decoder has successfully finished. Except for the - -- output value you also get the unused input. - | BytesRead {-# UNPACK #-} !Int64 (Int64 -> Decoder e a) - -- ^ The decoder needs to know the current position in the input. - -- Given the number of bytes remaning in the decoder, the outer - -- decoder runner needs to calculate the position and - -- resume the decoding. - --- unrolled codensity/state monad -newtype Get e a = C { runCont :: forall r. Int64 -> B.ByteString -> Success e a r -> Decoder e r } - -type Success e a r = B.ByteString -> a -> Decoder e r - -instance Monad (Get e) where - return = pure - (>>=) = bindG -#if MIN_VERSION_base(4,9,0) - fail = Fail.fail - -instance Fail.MonadFail (Get e) where -#endif - fail = failG_ - -bindG :: Get e a -> (a -> Get e b) -> Get e b -bindG (C c) f = C $ \ge i ks -> c ge i (\i' a -> (runCont (f a)) ge i' ks) -{-# INLINE bindG #-} - -failG_ :: String -> Get e a -failG_ str = C $ \_ i _ks -> Fail i $ Left str - -failG :: e -> Get e a -failG err = C $ \_ i _ks -> Fail i $ Right err - -apG :: Get e (a -> b) -> Get e a -> Get e b -apG d e = do - b <- d - a <- e - return (b a) -{-# INLINE [0] apG #-} - -fmapG :: (a -> b) -> Get e a -> Get e b -fmapG f m = C $ \ge i ks -> runCont m ge i (\i' a -> ks i' (f a)) -{-# INLINE fmapG #-} - -instance Applicative (Get e) where - pure = \x -> C $ \_ s ks -> ks s x - {-# INLINE [0] pure #-} - (<*>) = apG - {-# INLINE (<*>) #-} - -instance MonadPlus (Get e) where - mzero = empty - mplus = (<|>) - -instance Functor (Get e) where - fmap = fmapG - -instance Functor (Decoder e) where - fmap f (Done s a) = Done s (f a) - fmap f (Partial k) = Partial (fmap f . k) - fmap _ (Fail s err) = Fail s err - fmap f (BytesRead b k) = BytesRead b (fmap f . k) - -instance (Show e, Show a) => Show (Decoder e a) where - show (Fail _ err) = "Fail: " ++ show err - show (Partial _) = "Partial _" - show (Done _ a) = "Done: " ++ show a - show (BytesRead _ _) = "BytesRead" - --- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing --- input, handling decoding errors and to get the output value. -runGetIncremental :: Int64 -> Get e a -> Decoder e a -runGetIncremental ge g = noMeansNo $ - runCont g ge B.empty (\i a -> Done i a) - --- | Make sure we don't have to pass Nothing to a Partial twice. --- This way we don't need to pass around an EOF value in the Get e monad, it --- can safely ask several times if it needs to. -noMeansNo :: Decoder e a -> Decoder e a -noMeansNo r0 = go r0 - where - go r = - case r of - Partial k -> Partial $ \ms -> - case ms of - Just _ -> go (k ms) - Nothing -> neverAgain (k ms) - BytesRead n k -> BytesRead n (go . k) - Done _ _ -> r - Fail _ _ -> r - neverAgain r = - case r of - Partial k -> neverAgain (k Nothing) - BytesRead n k -> BytesRead n (neverAgain . k) - Fail _ _ -> r - Done _ _ -> r - -prompt :: B.ByteString -> Decoder e a -> (B.ByteString -> Decoder e a) -> Decoder e a -prompt inp kf ks = prompt' kf (\inp' -> ks (inp `B.append` inp')) - -prompt' :: Decoder e a -> (B.ByteString -> Decoder e a) -> Decoder e a -prompt' kf ks = - let loop = - Partial $ \sm -> - case sm of - Just s | B.null s -> loop - | otherwise -> ks s - Nothing -> kf - in loop - -getBaseOffset :: Get e Int64 -getBaseOffset = C $ \ge s ks -> ks s ge - --- | Get e the total number of bytes read to this point. -totalBytesRead :: Get e Int64 -totalBytesRead = do - base_offset <- getBaseOffset - offset <- bytesRead - return $ base_offset + offset - --- | Get e the total number of bytes read to this point. -bytesRead :: Get e Int64 -bytesRead = C $ \_ inp k -> BytesRead (fromIntegral $ B.length inp) (k inp) - --- | Isolate a decoder to operate with a fixed number of bytes, and fail if --- fewer bytes were consumed, or more bytes were attempted to be consumed. --- If the given decoder fails, 'isolate' will also fail. --- Offset from 'bytesRead' will be relative to the start of 'isolate', not the --- absolute of the input. -isolate :: Int -- ^ The number of bytes that must be consumed - -> Get e a -- ^ The decoder to isolate - -> (Int -> e) -- ^ The error if fewer bytes were consumed - -> Get e a -isolate n0 act err - | n0 < 0 = fail "isolate: negative size" - | otherwise = do - ge <- getBaseOffset - offset <- bytesRead - go n0 (runCont act (ge + offset) B.empty Done) - where - go !n (Done left x) - | n == 0 && B.null left = return x - | otherwise = do - pushFront left - let consumed = n0 - n - B.length left - failG $ err consumed - go 0 (Partial resume) = go 0 (resume Nothing) - go n (Partial resume) = do - inp <- C $ \_ inp k -> do - let takeLimited str = - let (inp', out) = B.splitAt n str in - k out (Just inp') - case not (B.null inp) of - True -> takeLimited inp - False -> prompt inp (k B.empty Nothing) takeLimited - case inp of - Nothing -> go n (resume Nothing) - Just str -> go (n - B.length str) (resume (Just str)) - go _ (Fail bs (Right ferr)) = pushFront bs >> failG ferr - go _ (Fail bs (Left ferr)) = pushFront bs >> failG_ ferr - go n (BytesRead r resume) = - go n (resume $! fromIntegral n0 - fromIntegral n - r) - -type Consume s = s -> B.ByteString -> Either s (B.ByteString, B.ByteString) - -withInputChunks :: s -> Consume s -> ([B.ByteString] -> b) -> ([B.ByteString] -> Get e b) -> Get e b -withInputChunks initS consume onSucc onFail = go initS [] - where - go state acc = C $ \ge inp ks -> - case consume state inp of - Left state' -> do - let acc' = inp : acc - prompt' - (runCont (onFail (reverse acc')) ge B.empty ks) - (\str' -> runCont (go state' acc') ge str' ks) - Right (want,rest) -> do - ks rest (onSucc (reverse (want:acc))) - -failOnEOF :: [B.ByteString] -> Get () a -failOnEOF bs = C $ \_ _ _ -> Fail (B.concat bs) $ Right () - --- | Test whether all input has been consumed, i.e. there are no remaining --- undecoded bytes. -isEmpty :: Get e Bool -isEmpty = C $ \_ inp ks -> - if B.null inp - then prompt inp (ks inp True) (\inp' -> ks inp' False) - else ks inp False - -instance Alternative (Get e) where - empty = C $ \_ inp _ks -> Fail inp $ Left "Data.Binary.Get(Alternative).empty" - {-# INLINE empty #-} - (<|>) f g = do - (decoder, bs) <- runAndKeepTrack f - case decoder of - Done inp x -> C $ \_ _ ks -> ks inp x - Fail _ _ -> pushBack bs >> g - _ -> error "Binary: impossible" - {-# INLINE (<|>) #-} - some p = (:) <$> p <*> many p - {-# INLINE some #-} - many p = do - v <- (Just <$> p) <|> pure Nothing - case v of - Nothing -> pure [] - Just x -> (:) x <$> many p - {-# INLINE many #-} - --- | Run a decoder and keep track of all the input it consumes. --- Once it's finished, return the final decoder (always 'Done' or 'Fail'), --- and unconsume all the the input the decoder required to run. --- Any additional chunks which was required to run the decoder --- will also be returned. -runAndKeepTrack :: Get e a -> Get e (Decoder e a, [B.ByteString]) -runAndKeepTrack g = C $ \ge inp ks -> - let r0 = runCont g ge inp (\inp' a -> Done inp' a) - go !acc r = case r of - Done inp' a -> ks inp (Done inp' a, reverse acc) - Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp) - Fail inp' s -> ks inp (Fail inp' s, reverse acc) - BytesRead unused k -> BytesRead unused (go acc . k) - in go [] r0 -{-# INLINE runAndKeepTrack #-} - -pushBack :: [B.ByteString] -> Get e () -pushBack [] = C $ \_ inp ks -> ks inp () -pushBack bs = C $ \_ inp ks -> ks (B.concat (inp : bs)) () -{-# INLINE pushBack #-} - -pushFront :: B.ByteString -> Get e () -pushFront bs = C $ \_ inp ks -> ks (B.append bs inp) () -{-# INLINE pushFront #-} - --- | Run the given decoder, but without consuming its input. If the given --- decoder fails, then so will this function. --- --- /Since: 0.7.0.0/ -lookAhead :: Get e a -> Get e a -lookAhead g = do - (decoder, bs) <- runAndKeepTrack g - case decoder of - Done _ a -> pushBack bs >> return a - Fail inp s -> C $ \_ _ _ -> Fail inp s - _ -> error "Binary: impossible" - --- | Run the given decoder, and only consume its input if it returns 'Just'. --- If 'Nothing' is returned, the input will be unconsumed. --- If the given decoder fails, then so will this function. --- --- /Since: 0.7.0.0/ -lookAheadM :: Get e (Maybe a) -> Get e (Maybe a) -lookAheadM g = do - let g' = maybe (Left ()) Right <$> g - either (const Nothing) Just <$> lookAheadE g' - --- | Run the given decoder, and only consume its input if it returns 'Right'. --- If 'Left' is returned, the input will be unconsumed. --- If the given decoder fails, then so will this function. -lookAheadE :: Get e (Either a b) -> Get e (Either a b) -lookAheadE g = do - (decoder, bs) <- runAndKeepTrack g - case decoder of - Done _ (Left x) -> pushBack bs >> return (Left x) - Done inp (Right x) -> C $ \_ _ ks -> ks inp (Right x) - Fail inp s -> C $ \_ _ _ -> Fail inp s - _ -> error "Binary: impossible" - ---- | Label a decoder. If the decoder fails, the label will be appended on ---- a new line to the error message string. -label :: String -> Get String a -> Get String a -label msg = onError (\x -> x ++ "\n" ++ msg) - --- | Convert decoder error. If the decoder fails, the given function will be applied --- to the error message. -onError :: (e -> e') -> Get e a -> Get e' a -onError msg decoder = C $ \ge inp ks -> - let r0 = runCont decoder ge inp (\inp' a -> Done inp' a) - go r = case r of - Done inp' a -> ks inp' a - Partial k -> Partial (go . k) - Fail inp' (Left s) -> Fail inp' $ Left s - Fail inp' (Right s) -> Fail inp' $ Right $ msg s - BytesRead u k -> BytesRead u (go . k) - in go r0 - --- | Set decoder error. If the decoder fails, the given error will be used --- as the error message. -withError :: Get () a -> e -> Get e a -withError decoder msg = onError (const msg) decoder - ------------------------------------------------------------------------- --- ByteStrings --- - --- | An efficient get method for strict ByteStrings. Fails if fewer than @n@ --- bytes are left in the input. If @n <= 0@ then the empty string is returned. -getByteString :: Int -> Get () B.ByteString -getByteString n | n > 0 = readN n (B.unsafeTake n) - | otherwise = return B.empty -{-# INLINE getByteString #-} - --- | Get e the current chunk. -get :: Get e B.ByteString -get = C $ \_ inp ks -> ks inp inp - --- | Replace the current chunk. -put :: B.ByteString -> Get e () -put s = C $ \_ _inp ks -> ks s () - --- | Return at least @n@ bytes, maybe more. If not enough data is available --- the computation will escape with 'Partial'. -readN :: Int -> (B.ByteString -> a) -> Get () a -readN !n f = ensureN n >> unsafeReadN n f -{-# INLINE [0] readN #-} - -{-# RULES - -"readN/readN merge" forall n m f g. - apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs)) #-} - --- | Ensure that there are at least @n@ bytes available. If not, the --- computation will escape with 'Partial'. -ensureN :: Int -> Get () () -ensureN !n0 = C $ \ge inp ks -> do - if B.length inp >= n0 - then ks inp () - else runCont (withInputChunks n0 enoughChunks onSucc onFail >>= put) ge inp ks - where -- might look a bit funny, but plays very well with GHC's inliner. - -- GHC won't inline recursive functions, so we make ensureN non-recursive - enoughChunks n str - | B.length str >= n = Right (str,B.empty) - | otherwise = Left (n - B.length str) - -- Sometimes we will produce leftovers lists of the form [B.empty, nonempty] - -- where `nonempty` is a non-empty ByteString. In this case we can avoid a copy - -- by simply dropping the empty prefix. In principle ByteString might want - -- to gain this optimization as well - onSucc = B.concat . dropWhile B.null - onFail bss = C $ \_ _ _ -> Fail (B.concat bss) $ Right () -{-# INLINE ensureN #-} - -unsafeReadN :: Int -> (B.ByteString -> a) -> Get () a -unsafeReadN !n f = C $ \_ inp ks -> do - ks (B.unsafeDrop n inp) $! f inp -- strict return - --- | @readNWith n f@ where @f@ must be deterministic and not have side effects. -readNWith :: Int -> (Ptr a -> IO a) -> Get () a -readNWith n f = do - -- It should be safe to use accursedUnutterablePerformIO here. - -- The action must be deterministic and not have any external side effects. - -- It depends on the value of the ByteString so the value dependencies look OK. - readN n $ \s -> accursedUnutterablePerformIO $ B.unsafeUseAsCString s (f . castPtr) -{-# INLINE readNWith #-} diff --git a/src/Data/Binary/Internal.hs b/src/Data/Binary/Internal.hs deleted file mode 100644 --- a/src/Data/Binary/Internal.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Data.Binary.Internal - ( accursedUnutterablePerformIO ) where - -#if MIN_VERSION_bytestring(0,10,6) -import Data.ByteString.Internal( accursedUnutterablePerformIO ) -#else -import Data.ByteString.Internal( inlinePerformIO ) - -{-# INLINE accursedUnutterablePerformIO #-} --- | You must be truly desperate to come to me for help. -accursedUnutterablePerformIO :: IO a -> a -accursedUnutterablePerformIO = inlinePerformIO -#endif diff --git a/src/Data/Conduit/Parsers.hs b/src/Data/Conduit/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers.hs @@ -0,0 +1,123 @@ +module Data.Conduit.Parsers + ( choice + , count + , option'' + , many'' + , many1'' + , manyTill'' + , sepBy'' + , sepBy1'' + , skipMany'' + , skipMany1'' + , eitherP + , Chunk (..) + , DecodingElemsRead (..) + , elemsRead + , endOfInput + , skip + , isolate + , matchP + , tryP + ) where + +import Control.Monad.Error.Class +import Data.Attoparsec.Text hiding (skip, endOfInput, match, try, option) +import qualified Data.ByteString as S (ByteString) +import qualified Data.ByteString as SB hiding (ByteString, head, last, init, tail) +import Data.Conduit +import qualified Data.Conduit.Combinators as N +import Data.Conduit.Lift +import Data.MonoTraversable +import qualified Data.Text as S (Text) +import qualified Data.Text as ST hiding (Text, head, last, tail, init) +import Data.Word +import Control.Monad.Error.Map +import Data.Conduit.Parsers.GetC + +class MonoFoldable c => Chunk c where + osplitAt :: Int -> c -> (c, c) + +instance Chunk S.ByteString where + osplitAt = SB.splitAt + {-# INLINE osplitAt #-} + +instance Chunk S.Text where + osplitAt = ST.splitAt + {-# INLINE osplitAt #-} + +class DecodingElemsRead s where + decodingElemsRead :: s -> Word64 + +instance (DecodingState s, DecodingElemsRead s) => DecodingElemsRead (Decoding s i) where + decodingElemsRead = decodingElemsRead . decodingRead + {-# INLINE decodingElemsRead #-} + +-- | Get the total number of bytes read to this point. +elemsRead :: (DecodingState s, DecodingElemsRead s, Monad m) => GetM s i o e m Word64 +elemsRead = getC $ \ !x -> return (Right $ decodingElemsRead x, x) +{-# INLINE elemsRead #-} + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: (DecodingState s, Chunk (DecodingToken s), Monad m) => Word64 -> GetM s (DecodingToken s) o () m () +skip !n = getC $ + go 0 + where + go !consumed !decoding + | consumed > n = error "Data.Binary.Conduit.Get.skip" + | consumed == n = return (Right (), decoding) + | otherwise = do + !mi <- await + case mi of + Nothing -> return (Left (), decoding) + Just !i -> do + let !gap = n - consumed + if gap >= fromIntegral (olength i) + then do + go (consumed + fromIntegral (olength i)) (decoded i decoding) + else do + let (!got, !rest) = osplitAt (fromIntegral gap) i + leftover rest + return (Right (), decoded got decoding) +{-# INLINE skip #-} + +-- | Isolate a decoder to operate with a fixed number of bytes, and fail if +-- fewer bytes were consumed, or if fewer bytes are left in the input. +-- Unlike 'S.isolate' from binary package, +-- offset from 'bytesRead' will NOT be relative to the start of @isolate@. +isolate :: (DecodingState s, Chunk (DecodingToken s), DecodingElemsRead s, Monad m) + => Word64 -- ^ The number of bytes that must be consumed. + -> GetM s (DecodingToken s) o e m a -- ^ The decoder to isolate. + -> GetM s (DecodingToken s) o (Either (Maybe Word64) e) m a +isolate !n !g = do + !o1 <- elemsRead + !r <- getC $ flip runStateC $ runExceptC $ fuseLeftovers id (go 0) (exceptC $ stateC $ flip runGetC $ mapError Right g) + !o2 <- elemsRead + if o2 - o1 < n + then throwError $ Left $ Just $ o2 - o1 + else return r + where + go consumed + | consumed > n = error "Data.Binary.Conduit.Get.isolate" + | consumed == n = return () + | otherwise = do + !i <- maybe (throwError $ Left Nothing) return =<< await + let !gap = n - consumed + if gap >= fromIntegral (olength i) + then do + yield i + go $ consumed + fromIntegral (olength i) + else do + let (!h, !t) = osplitAt (fromIntegral gap) i + leftover t + yield h +{-# INLINE isolate #-} + +endOfInput :: (DecodingState s, MonoFoldable (DecodingToken s), Monad m) => GetM s (DecodingToken s) o () m () +endOfInput = do + end <- N.nullE + if end then return () else throwError () +{-# INLINE endOfInput #-} + +matchP :: (DecodingState s, Monoid (DecodingToken s), Monad m) => GetM s (DecodingToken s) o e m a -> GetM s (DecodingToken s) o e m (DecodingToken s, a) +matchP !p = (\(!t, !r) -> (foldl (flip mappend) mempty t, r)) <$> mapError snd (trackP p) +{-# INLINE matchP #-} diff --git a/src/Data/Conduit/Parsers/Binary.hs b/src/Data/Conduit/Parsers/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Binary.hs @@ -0,0 +1,32 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | This module provides the 'GetC' monad transformer, +-- and all functions, which could not be defined using 'GetC' public interface only. + +module Data.Conduit.Parsers.Binary + ( EncodingBytesWrote (..) + ) where + +import Data.Word +import Data.Conduit.Parsers.PutS + +class EncodingBytesWrote s where + encodingBytesWrote :: s -> Word64 + +instance (EncodingBytesWrote s) => EncodingBytesWrote (Encoding s m) where + encodingBytesWrote = encodingBytesWrote . encodingWrote + {-# INLINE encodingBytesWrote #-} diff --git a/src/Data/Conduit/Parsers/Binary/ByteOffset.hs b/src/Data/Conduit/Parsers/Binary/ByteOffset.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Binary/ByteOffset.hs @@ -0,0 +1,57 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | At the first look, Data.Binary.Conduit.Get module is very similar with Data.Binary.Get. +-- The main differences between them are the following. +-- While the 'S.Get' from binary is a very custom monad, +-- the local 'Get' is 'ConduitM', which leads to easy integration in complicated format parsing. +-- The Data.Binary.Get module does not have a function to create custom 'S.Get' monad, +-- this module provides 'getC'. +-- Unlike 'isolate' from binary, local 'isolate' does not "cut" bytes counter. +-- While the binary's 'S.Get' is 'MonadFail', which leads to very ugly errors handling +-- in complicated cases, local 'Get' is 'MonadError'. + +module Data.Conduit.Parsers.Binary.ByteOffset + ( ByteOffset (..) + ) where + +import qualified Data.ByteString as S (ByteString) +import qualified Data.ByteString as SB hiding (ByteString, head, last, init, tail) +import Data.Word +import Data.Conduit.Parsers +import Data.Conduit.Parsers.Binary +import Data.Conduit.Parsers.GetC +import Data.Conduit.Parsers.PutS + +newtype ByteOffset = ByteOffset Word64 deriving Show + +instance DecodingState ByteOffset where + type DecodingToken ByteOffset = S.ByteString + decoded !i (ByteOffset !s) = ByteOffset (s + fromIntegral (SB.length i)) + {-# INLINE decoded #-} + +instance DecodingElemsRead ByteOffset where + decodingElemsRead (ByteOffset !s) = s + {-# INLINE decodingElemsRead #-} + +instance EncodingState ByteOffset where + type EncodingToken ByteOffset = Word64 + encoded !w (ByteOffset !s) = ByteOffset (s + w) + {-# INLINE encoded #-} + +instance EncodingBytesWrote ByteOffset where + encodingBytesWrote (ByteOffset !s) = s + {-# INLINE encodingBytesWrote #-} diff --git a/src/Data/Conduit/Parsers/Binary/Get.hs b/src/Data/Conduit/Parsers/Binary/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Binary/Get.hs @@ -0,0 +1,356 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | At the first look, Data.Binary.Conduit.Get module is very similar with Data.Binary.Get. +-- The main differences between them are the following. +-- While the 'S.Get' from binary is a very custom monad, +-- the local 'Get' is 'ConduitM', which leads to easy integration in complicated format parsing. +-- The Data.Binary.Get module does not have a function to create custom 'S.Get' monad, +-- this module provides 'getC'. +-- Unlike 'isolate' from binary, local 'isolate' does not "cut" bytes counter. +-- While the binary's 'S.Get' is 'MonadFail', which leads to very ugly errors handling +-- in complicated cases, local 'Get' is 'MonadError'. + +module Data.Conduit.Parsers.Binary.Get + ( MonadMapError (..) + , (?=>>) + , (?>>) + , DefaultDecodingState + , GetM + , Get + , runGet + , bytesRead + , castGet + , skip + , isolate + , getByteString + , getLazyByteString + , getLazyByteStringNul + , getRemainingLazyByteString + , getWord8 + , getInt8 + , getWord16be + , getWord32be + , getWord64be + , getWord16le + , getWord32le + , getWord64le + , getWordhost + , getWord16host + , getWord32host + , getWord64host + , getInt16be + , getInt32be + , getInt64be + , getInt16le + , getInt32le + , getInt64le + , getInthost + , getInt16host + , getInt32host + , getInt64host + , getFloatbe + , getFloatle + , getFloathost + , getDoublebe + , getDoublele + , getDoublehost + , endOfInput + ) where + +import qualified Data.Binary.Get as S +import Data.Binary.IEEE754 (wordToFloat, wordToDouble) +import qualified Data.Binary.IEEE754 as S hiding (floatToWord, wordToFloat, doubleToWord, wordToDouble) +import qualified Data.ByteString as S (ByteString) +import qualified Data.ByteString as SB hiding (ByteString, head, last, init, tail) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as B hiding (ByteString, head, last, init, tail) +import Data.Conduit +import Data.Int +import Data.Maybe +import Data.Semigroup hiding (Option) +import Data.Word +import Control.Monad.Error.Map +import Data.Conduit.Parsers +import Data.Conduit.Parsers.Binary () +import Data.Conduit.Parsers.Binary.ByteOffset +import Data.Conduit.Parsers.GetC + +class (DecodingState s, DecodingToken s ~ S.ByteString, DecodingElemsRead s) => DefaultDecodingState s where + +instance (DecodingState s, DecodingToken s ~ S.ByteString, DecodingElemsRead s) => DefaultDecodingState s where + +-- | The shortening of 'GetM' for the most common use case. +type Get e a = forall s o m. (DefaultDecodingState s, Monad m) => GetM s S.ByteString o e m a + +-- | Run a decoder presented as a 'Get' monad. +-- Returns decoder result and consumed bytes count. +runGet :: Monad m => GetM ByteOffset i o e m a -> ConduitM i o m (Either e a) +runGet !g = fst <$> runGetC (startDecoding $ ByteOffset 0) g +{-# INLINE runGet #-} + +-- | Get the total number of bytes read to this point. +bytesRead :: (DecodingState s, DecodingElemsRead s, Monad m) => GetM s i o e m Word64 +bytesRead = elemsRead +{-# INLINE bytesRead #-} + +-- | Run the given 'S.Get' monad from binary package +-- and convert result into 'Get'. +castGet :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => S.Get a -> GetM s S.ByteString o String m a +castGet !g = getC $ + go (S.runGetIncremental g) SB.empty + where + go (S.Done !rest _ !result) !chunk !decoding = + if SB.null rest + then return (Right result, decoded chunk decoding) + else leftover rest >> return (Right result, decoded (SB.take (SB.length chunk - SB.length rest) chunk) decoding) + go (S.Fail _ _ !err) !chunk !decoding = return (Left err, decoded chunk decoding) + go (S.Partial !continue) !chunk !decoding = do + next <- await + go (continue next) (fromMaybe SB.empty next) (decoded chunk decoding) +{-# INLINE castGet #-} + +voidError :: Monad m => GetM s i o e m a -> GetM s i o () m a +voidError = mapError (const ()) +{-# INLINE voidError #-} + +-- | An efficient get method for strict 'S.ByteString's. Fails if fewer than @n@ +-- bytes are left in the input. If @n <= 0@ then the empty string is returned. +getByteString :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => Int -> GetM s S.ByteString o () m S.ByteString +getByteString !n = getC $ + go SB.empty 0 + where + go consumed !consumed_length !decoding + | consumed_length >= n = return (Right consumed, decoding) + | otherwise = do + !mi <- await + case mi of + Nothing -> return (Left (), decoding) + Just !i -> do + let !gap = n - consumed_length + if gap >= SB.length i + then do + go (consumed <> i) (consumed_length + fromIntegral (SB.length i)) (decoded i decoding) + else do + let (!got, !rest) = SB.splitAt gap i + leftover rest + return (Right (consumed <> got), decoded got decoding) +{-# INLINE getByteString #-} + +-- | An efficient get method for lazy 'ByteString's. Fails if fewer than @n@ +-- bytes are left in the input. If @n <= 0@ then the empty string is returned. +getLazyByteString :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => Int64 -> GetM s S.ByteString o () m ByteString +getLazyByteString n = getC $ + go B.empty 0 + where + go consumed !consumed_length !decoding + | consumed_length >= n = return (Right consumed, decoding) + | otherwise = do + !mi <- await + case mi of + Nothing -> return (Left (), decoding) + Just !i -> do + let !gap = n - consumed_length + if gap >= fromIntegral (SB.length i) + then do + go (consumed <> B.fromStrict i) (consumed_length + fromIntegral (SB.length i)) (decoded i decoding) + else do + let (!got, !rest) = SB.splitAt (fromIntegral gap) i + leftover rest + return (Right (consumed <> B.fromStrict got), decoded got decoding) +{-# INLINE getLazyByteString #-} + +-- | Get a lazy 'ByteString' that is terminated with a NUL byte. +-- The returned string does not contain the NUL byte. +-- Fails if it reaches the end of input without finding a NUL. +getLazyByteStringNul :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m ByteString +getLazyByteStringNul = getC $ + go B.empty + where + go consumed !decoding = do + !mi <- await + case mi of + Nothing -> return (Left (), decoding) + Just !i -> do + let (!h, !t) = SB.span (/= 0) i + let r = consumed <> B.fromStrict h + let !d = decoded h decoding + if SB.length t == 0 + then go r d + else do + let (!z, !zt) = SB.splitAt 1 t + leftover zt + return (Right r, decoded z $ decoded h decoding) +{-# INLINE getLazyByteStringNul #-} + +-- | Get the remaining bytes as a lazy 'ByteString'. +-- Note that this can be an expensive function to use as it +-- forces reading all input and keeping the string in-memory. +getRemainingLazyByteString :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o e m ByteString +getRemainingLazyByteString = getC $ + go B.empty + where + go consumed !decoding = do + !mi <- await + case mi of + Nothing -> return (Right consumed, decoding) + Just !i -> go (consumed <> B.fromStrict i) (decoded i decoding) + +voidCastGet :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => S.Get a -> GetM s S.ByteString o () m a +voidCastGet = voidError . castGet +{-# INLINE voidCastGet #-} + +-- | Read a 'Word8' from the monad state. +getWord8 :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word8 +getWord8 = voidCastGet S.getWord8 +{-# INLINE getWord8 #-} + +-- | Read an 'Int8' from the monad state. +getInt8 :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int8 +getInt8 = voidCastGet S.getInt8 +{-# INLINE getInt8 #-} + +-- | Read a 'Word16' in big endian format. +getWord16be :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word16 +getWord16be = voidCastGet S.getWord16be +{-# INLINE getWord16be #-} + +-- | Read a 'Word32' in big endian format. +getWord32be :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word32 +getWord32be = voidCastGet S.getWord32be +{-# INLINE getWord32be #-} + +-- | Read a 'Word64' in big endian format. +getWord64be :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word64 +getWord64be = voidCastGet S.getWord64be +{-# INLINE getWord64be #-} + +-- | Read a 'Word16' in little endian format. +getWord16le :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word16 +getWord16le = voidCastGet S.getWord16le +{-# INLINE getWord16le #-} + +-- | Read a 'Word32' in little endian format. +getWord32le :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word32 +getWord32le = voidCastGet S.getWord32le +{-# INLINE getWord32le #-} + +-- | Read a 'Word64' in little endian format. +getWord64le :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word64 +getWord64le = voidCastGet S.getWord64le +{-# INLINE getWord64le #-} + +-- | Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordhost :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word +getWordhost = voidCastGet S.getWordhost +{-# INLINE getWordhost #-} + +-- | Read a 2 byte 'Word16' in native host order and host endianness. +getWord16host :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word16 +getWord16host = voidCastGet S.getWord16host +{-# INLINE getWord16host #-} + +-- | Read a 4 byte 'Word32' in native host order and host endianness. +getWord32host :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word32 +getWord32host = voidCastGet S.getWord32host +{-# INLINE getWord32host #-} + +-- | Read a 8 byte 'Word64' in native host order and host endianness. +getWord64host :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Word64 +getWord64host = voidCastGet S.getWord64host +{-# INLINE getWord64host #-} + +-- | Read an 'Int16' in big endian format. +getInt16be :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int16 +getInt16be = voidCastGet S.getInt16be +{-# INLINE getInt16be #-} + +-- | Read an 'Int32' in big endian format. +getInt32be :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int32 +getInt32be = voidCastGet S.getInt32be +{-# INLINE getInt32be #-} + +-- | Read an 'Int64' in big endian format. +getInt64be :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int64 +getInt64be = voidCastGet S.getInt64be +{-# INLINE getInt64be #-} + +-- | Read an 'Int16' in little endian format. +getInt16le :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int16 +getInt16le = voidCastGet S.getInt16le +{-# INLINE getInt16le #-} + +-- | Read an 'Int32' in little endian format. +getInt32le :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int32 +getInt32le = voidCastGet S.getInt32le +{-# INLINE getInt32le #-} + +-- | Read an 'Int64' in little endian format. +getInt64le :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int64 +getInt64le = voidCastGet S.getInt64le +{-# INLINE getInt64le #-} + +-- | Read a single native machine word. It works in the same way as 'getWordhost'. +getInthost :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int +getInthost = voidCastGet S.getInthost +{-# INLINE getInthost #-} + +-- | Read a 2 byte 'Int16' in native host order and host endianness. +getInt16host :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int16 +getInt16host = voidCastGet S.getInt16host +{-# INLINE getInt16host #-} + +-- | Read a 4 byte 'Int32' in native host order and host endianness. +getInt32host :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int32 +getInt32host = voidCastGet S.getInt32host +{-# INLINE getInt32host #-} + +-- | Read a 8 byte 'Int64' in native host order and host endianness. +getInt64host :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Int64 +getInt64host = voidCastGet S.getInt64host +{-# INLINE getInt64host #-} + +-- | Read a 'Float' in big endian IEEE-754 format. +getFloatbe :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Float +getFloatbe = voidCastGet S.getFloat32be +{-# INLINE getFloatbe #-} + +-- | Read a 'Float' in little endian IEEE-754 format. +getFloatle :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Float +getFloatle = voidCastGet S.getFloat32le +{-# INLINE getFloatle #-} + +-- | Read a 'Float' in IEEE-754 format and host endian. +getFloathost :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Float +getFloathost = wordToFloat <$> voidCastGet S.getWord32host +{-# INLINE getFloathost #-} + +-- | Read a 'Double' in big endian IEEE-754 format. +getDoublebe :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Double +getDoublebe = voidCastGet S.getFloat64be +{-# INLINE getDoublebe #-} + +-- | Read a 'Double' in little endian IEEE-754 format. +getDoublele :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Double +getDoublele = voidCastGet S.getFloat64le +{-# INLINE getDoublele #-} + +-- | Read a 'Double' in IEEE-754 format and host endian. +getDoublehost :: (DecodingState s, DecodingToken s ~ S.ByteString, Monad m) => GetM s S.ByteString o () m Double +getDoublehost = wordToDouble <$> voidCastGet S.getWord64host +{-# INLINE getDoublehost #-} diff --git a/src/Data/Conduit/Parsers/Binary/Put.hs b/src/Data/Conduit/Parsers/Binary/Put.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Binary/Put.hs @@ -0,0 +1,271 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | Despite binary's 'S.Put' is fully-functional construction (unlike 'S.Get'), +-- we decided to provide this module for symmetry with 'Data.Binary.Conduit.Get'. + +module Data.Conduit.Parsers.Binary.Put + ( PutM + , DefaultEncodingState + , Put + , runPut + , bytesWrote + , castPut + , putWord8 + , putInt8 + , putByteString + , putLazyByteString + , putShortByteString + , putWord16be + , putWord32be + , putWord64be + , putInt16be + , putInt32be + , putInt64be + , putFloatbe + , putDoublebe + , putWord16le + , putWord32le + , putWord64le + , putInt16le + , putInt32le + , putInt64le + , putFloatle + , putDoublele + , putWordhost + , putWord16host + , putWord32host + , putWord64host + , putInthost + , putInt16host + , putInt32host + , putInt64host + , putFloathost + , putDoublehost + ) where + +import qualified Data.Binary.Put as S +import Data.Binary.IEEE754 (floatToWord, doubleToWord) +import qualified Data.Binary.IEEE754 as S hiding (floatToWord, wordToFloat, doubleToWord, wordToDouble) +import Data.Bits +import qualified Data.ByteString as S (ByteString) +import qualified Data.ByteString as SB hiding (ByteString, head, last, init, tail) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as B hiding (ByteString, head, last, init, tail) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as HB hiding (ShortByteString) +import Data.Conduit +import Data.Int +import Data.Word +import Data.Conduit.Parsers.Binary +import Data.Conduit.Parsers.Binary.ByteOffset +import Data.Conduit.Parsers.PutS + +class (EncodingState s, EncodingToken s ~ Word64, EncodingBytesWrote s) => DefaultEncodingState s where + +instance (EncodingState s, EncodingToken s ~ Word64, EncodingBytesWrote s) => DefaultEncodingState s where + +-- | The shortening of 'PutM' for the most common use case. +type Put = forall s i m. (DefaultEncodingState s, Monad m) => PutM s i S.ByteString m () + +-- | Run an encoder presented as a 'Put' monad. +-- Returns 'Producer'. +runPut :: PutM ByteOffset i o m () -> ConduitM i o m () +runPut !p = runEncoding $ snd $ runPutS p $ startEncoding $ ByteOffset 0 +{-# INLINE runPut #-} + +-- | Get the total number of bytes wrote to this point. +-- Can be used with 'mfix' to result bytes count prediction: +-- > putWithSize :: (DefaultEncodingState s, Monad m) => PutM s i S.ByteString m () -> PutM s i S.ByteString m () +-- > putWithSize !p = void $ mfix $ \size -> do +-- > putWord64le size +-- > before <- bytesWrote +-- > p +-- > after <- bytesWrote +-- > return $ after - before +bytesWrote :: EncodingBytesWrote s => PutM s i o m Word64 +bytesWrote = putS $ \ !s -> (encodingBytesWrote s, s) +{-# INLINE bytesWrote #-} + +-- | Run the given 'S.Put' encoder from binary package +-- producing the given bytes count +-- and convert result into a 'Put'. +castPut :: (EncodingState s, Monad m) => EncodingToken s -> S.Put -> PutM s i S.ByteString m () +castPut !n !p = putS $ \ !t -> ((), encoded (mapM_ yield $ B.toChunks $ S.runPut p, n) t) +{-# INLINE castPut #-} + +-- | Write a byte. +putWord8 :: (EncodingState s, Num (EncodingToken s), Monad m) => Word8 -> PutM s i S.ByteString m () +putWord8 = castPut 1 . S.putWord8 +{-# INLINE putWord8 #-} + +-- | Write a signed byte. +putInt8 :: (EncodingState s, Num (EncodingToken s), Monad m) => Int8 -> PutM s i S.ByteString m () +putInt8 = castPut 1 . S.putInt8 +{-# INLINE putInt8 #-} + +-- | Write a strict 'S.ByteString'. +putByteString :: (EncodingState s, Num (EncodingToken s), Monad m) => S.ByteString -> PutM s i S.ByteString m () +putByteString b = castPut (fromIntegral $ SB.length b) $ S.putByteString b +{-# INLINE putByteString #-} + +-- | Write a lazy 'ByteString'. +putLazyByteString :: (EncodingState s, Num (EncodingToken s), Monad m) => ByteString -> PutM s i S.ByteString m () +putLazyByteString b = castPut (fromIntegral $ B.length b) $ S.putLazyByteString b +{-# INLINE putLazyByteString #-} + +-- | Write a 'ShortByteString'. +putShortByteString :: (EncodingState s, Num (EncodingToken s), Monad m) => ShortByteString -> PutM s i S.ByteString m () +putShortByteString b = castPut (fromIntegral $ HB.length b) $ S.putShortByteString b +{-# INLINE putShortByteString #-} + +-- | Write a 'Word16' in big endian format. +putWord16be :: (EncodingState s, Num (EncodingToken s), Monad m) => Word16 -> PutM s i S.ByteString m () +putWord16be = castPut 2 . S.putWord16be +{-# INLINE putWord16be #-} + +-- | Write a 'Word32' in big endian format. +putWord32be :: (EncodingState s, Num (EncodingToken s), Monad m) => Word32 -> PutM s i S.ByteString m () +putWord32be = castPut 4 . S.putWord32be +{-# INLINE putWord32be #-} + +-- | Write a 'Word64' in big endian format. +putWord64be :: (EncodingState s, Num (EncodingToken s), Monad m) => Word64 -> PutM s i S.ByteString m () +putWord64be = castPut 8 . S.putWord64be +{-# INLINE putWord64be #-} + +-- | Write an 'Int16' in big endian format. +putInt16be :: (EncodingState s, Num (EncodingToken s), Monad m) => Int16 -> PutM s i S.ByteString m () +putInt16be = castPut 2 . S.putInt16be +{-# INLINE putInt16be #-} + +-- | Write an 'Int32' in big endian format. +putInt32be :: (EncodingState s, Num (EncodingToken s), Monad m) => Int32 -> PutM s i S.ByteString m () +putInt32be = castPut 4 . S.putInt32be +{-# INLINE putInt32be #-} + +-- | Write an 'Int64' in big endian format. +putInt64be :: (EncodingState s, Num (EncodingToken s), Monad m) => Int64 -> PutM s i S.ByteString m () +putInt64be = castPut 8 . S.putInt64be +{-# INLINE putInt64be #-} + +-- | Write a 'Float' in big endian IEEE-754 format. +putFloatbe :: (EncodingState s, Num (EncodingToken s), Monad m) => Float -> PutM s i S.ByteString m () +putFloatbe = castPut 4 . S.putFloat32be +{-# INLINE putFloatbe #-} + +-- | Write a 'Double' in big endian IEEE-754 format. +putDoublebe :: (EncodingState s, Num (EncodingToken s), Monad m) => Double -> PutM s i S.ByteString m () +putDoublebe = castPut 8 . S.putFloat64be +{-# INLINE putDoublebe #-} + +-- | Write a 'Word16' in little endian format. +putWord16le :: (EncodingState s, Num (EncodingToken s), Monad m) => Word16 -> PutM s i S.ByteString m () +putWord16le = castPut 2 . S.putWord16le +{-# INLINE putWord16le #-} + +-- | Write a 'Word32' in little endian format. +putWord32le :: (EncodingState s, Num (EncodingToken s), Monad m) => Word32 -> PutM s i S.ByteString m () +putWord32le = castPut 4 . S.putWord32le +{-# INLINE putWord32le #-} + +-- | Write a 'Word64' in little endian format. +putWord64le :: (EncodingState s, Num (EncodingToken s), Monad m) => Word64 -> PutM s i S.ByteString m () +putWord64le = castPut 8 . S.putWord64le +{-# INLINE putWord64le #-} + +-- | Write an 'Int16' in little endian format. +putInt16le :: (EncodingState s, Num (EncodingToken s), Monad m) => Int16 -> PutM s i S.ByteString m () +putInt16le = castPut 2 . S.putInt16le +{-# INLINE putInt16le #-} + +-- | Write an 'Int32' in little endian format. +putInt32le :: (EncodingState s, Num (EncodingToken s), Monad m) => Int32 -> PutM s i S.ByteString m () +putInt32le = castPut 4 . S.putInt32le +{-# INLINE putInt32le #-} + +-- | Write an 'Int64' in little endian format. +putInt64le :: (EncodingState s, Num (EncodingToken s), Monad m) => Int64 -> PutM s i S.ByteString m () +putInt64le = castPut 8 . S.putInt64le +{-# INLINE putInt64le #-} + +-- | Write a 'Float' in little endian IEEE-754 format. +putFloatle :: (EncodingState s, Num (EncodingToken s), Monad m) => Float -> PutM s i S.ByteString m () +putFloatle = castPut 4 . S.putFloat32le +{-# INLINE putFloatle #-} + +-- | Write a 'Double' in little endian IEEE-754 format. +putDoublele :: (EncodingState s, Num (EncodingToken s), Monad m) => Double -> PutM s i S.ByteString m () +putDoublele = castPut 8 . S.putFloat64le +{-# INLINE putDoublele #-} + +-- | Write a single native machine word. The word is written in host order, +-- host endian form, for the machine you're on. +-- On a 64 bit machine the 'Word' is an 8 byte value, on a 32 bit machine, 4 bytes. +-- Values written this way are not portable to different endian or word sized machines, without conversion. +putWordhost :: (EncodingState s, Num (EncodingToken s), Monad m) => Word -> PutM s i S.ByteString m () +putWordhost = castPut (fromIntegral $ finiteBitSize (0 :: Word)) . S.putWordhost +{-# INLINE putWordhost #-} + +-- | Write a 'Word16' in native host order and host endianness. For portability issues see 'putWordhost'. +putWord16host :: (EncodingState s, Num (EncodingToken s), Monad m) => Word16 -> PutM s i S.ByteString m () +putWord16host = castPut 2 . S.putWord16host +{-# INLINE putWord16host #-} + +-- | Write a 'Word32' in native host order and host endianness. For portability issues see 'putWordhost'. +putWord32host :: (EncodingState s, Num (EncodingToken s), Monad m) => Word32 -> PutM s i S.ByteString m () +putWord32host = castPut 4 . S.putWord32host +{-# INLINE putWord32host #-} + +-- | Write a 'Word64' in native host order On a 32 bit machine we write two host order 'Word32's, +-- in big endian form. For portability issues see 'putWordhost'. +putWord64host :: (EncodingState s, Num (EncodingToken s), Monad m) => Word64 -> PutM s i S.ByteString m () +putWord64host = castPut 8 . S.putWord64host +{-# INLINE putWord64host #-} + +-- | Write a single native machine word. The word is written in host order, host endian form, +-- for the machine you're on. +-- On a 64 bit machine the 'Int' is an 8 byte value, on a 32 bit machine, 4 bytes. +-- Values written this way are not portable to different endian or word sized machines, without conversion. +putInthost :: (EncodingState s, Num (EncodingToken s), Monad m) => Int -> PutM s i S.ByteString m () +putInthost = castPut (fromIntegral $ finiteBitSize (0 :: Int)) . S.putInthost +{-# INLINE putInthost #-} + +-- | Write an 'Int16' in native host order and host endianness. For portability issues see 'putInthost'. +putInt16host :: (EncodingState s, Num (EncodingToken s), Monad m) => Int16 -> PutM s i S.ByteString m () +putInt16host = castPut 2 . S.putInt16host +{-# INLINE putInt16host #-} + +-- | Write an 'Int32' in native host order and host endianness. For portability issues see 'putInthost'. +putInt32host :: (EncodingState s, Num (EncodingToken s), Monad m) => Int32 -> PutM s i S.ByteString m () +putInt32host = castPut 4 . S.putInt32host +{-# INLINE putInt32host #-} + +-- | Write an 'Int64' in native host order On a 32 bit machine we write two host order 'Int32's, +-- in big endian form. For portability issues see putInthost. +putInt64host :: (EncodingState s, Num (EncodingToken s), Monad m) => Int64 -> PutM s i S.ByteString m () +putInt64host = castPut 8 . S.putInt64host +{-# INLINE putInt64host #-} + +-- | Write a 'Float' in native in IEEE-754 format and host endian. +putFloathost :: (EncodingState s, Num (EncodingToken s), Monad m) => Float -> PutM s i S.ByteString m () +putFloathost = castPut 4 . S.putWord32host . floatToWord +{-# INLINE putFloathost #-} + +-- | Write a 'Double' in native in IEEE-754 format and host endian. +putDoublehost :: (EncodingState s, Num (EncodingToken s), Monad m) => Double -> PutM s i S.ByteString m () +putDoublehost = castPut 8 . S.putWord64host . doubleToWord +{-# INLINE putDoublehost #-} diff --git a/src/Data/Conduit/Parsers/GetC.hs b/src/Data/Conduit/Parsers/GetC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/GetC.hs @@ -0,0 +1,449 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | This module provides the 'GetC' monad transformer, +-- and all functions, which could not be defined using 'GetC' public interface only. + +module Data.Conduit.Parsers.GetC + ( DecodingState (..) + , Decoding + , startDecoding + , continueDecoding + , decodingRead + , GetC + , GetM + , runGetC + , getC + , trackP + , tryP + , maybeG + , runMaybeG + , exceptG + , runExceptG + , catchExceptG + , readerG + , runReaderG + , stateLG + , runStateLG + , evalStateLG + , execStateLG + , stateG + , runStateG + , evalStateG + , execStateG + , writerLG + , runWriterLG + , execWriterLG + , writerG + , runWriterG + , execWriterG + , rwsLG + , runRWSLG + , evalRWSLG + , execRWSLG + , rwsG + , runRWSG + , evalRWSG + , execRWSG + ) where + +import Control.Applicative +import Control.Monad hiding (fail) +import Control.Monad.Base +import Control.Monad.Error.Class +import Control.Monad.Error.Map +import Control.Monad.Fail +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Control.Monad.Trans.RWS.Strict +import qualified Control.Monad.Trans.RWS.Lazy as L +import Control.Monad.Trans.State.Strict +import qualified Control.Monad.Trans.State.Lazy as L +import Control.Monad.Trans.Writer.Strict +import qualified Control.Monad.Trans.Writer.Lazy as L +import Data.Conduit +import Data.Conduit.Lift +import Data.Maybe hiding (fromJust) + +class DecodingState s where + type DecodingToken s :: * + decoded :: DecodingToken s -> s -> s + +-- | 'GetC' monad state. +data Decoding s i = Decoding + { decodingRead :: !s -- ^ Get the total number of bytes read to this point. + , tracking :: !(Maybe [i]) + } + +-- | Construct 'GetC' initial state. +startDecoding :: s -> Decoding s i +startDecoding !bytes_read_before = Decoding { decodingRead = bytes_read_before, tracking = Nothing } +{-# INLINE startDecoding #-} + +continueDecoding :: s -> [i] -> Decoding s i -> Decoding s i +continueDecoding new delta old = Decoding { decodingRead = new, tracking = (delta ++) <$> tracking old } +{-# INLINE continueDecoding #-} + +instance (DecodingState s, DecodingToken s ~ i) => DecodingState (Decoding s i) where + type DecodingToken (Decoding s i) = DecodingToken s + decoded !inp !s = Decoding + { decodingRead = decoded inp (decodingRead s) + , tracking = (inp :) <$> tracking s + } + {-# INLINE decoded #-} + +-- | Internal transformers for 'Get' with error type @e@, host monad @m@ and decoder result @a@. +newtype GetC s i e m a = C { runC :: ExceptT e (StateT (Decoding s i) m) a } + +instance MonadTrans (GetC s i e) where + lift = C . lift . lift + {-# INLINE lift #-} +deriving instance Monad m => Monad (GetC s i e m) +deriving instance Functor m => Functor (GetC s i e m) +deriving instance MonadFix m => MonadFix (GetC s i e m) +deriving instance MonadFail m => MonadFail (GetC s i e m) +deriving instance (Functor m, Monad m) => Applicative (GetC s i e m) +deriving instance MonadIO m => MonadIO (GetC s i e m) +deriving instance (Functor m, Monad m, Monoid e) => Alternative (GetC s i e m) +deriving instance (Monad m, Monoid e) => MonadPlus (GetC s i e m) +deriving instance Monad m => MonadError e (GetC s i e m) + +instance MonadTransControl (GetC s i e) where + type StT (GetC s i e) a = StT (StateT (Decoding s i)) (StT (ExceptT e) a) + liftWith = defaultLiftWith2 C runC + {-# INLINE liftWith #-} + restoreT = defaultRestoreT2 C + {-# INLINE restoreT #-} + +instance MonadBase b m => MonadBase b (GetC s i e m) where + liftBase = liftBaseDefault + {-# INLINE liftBase #-} + +instance MonadBaseControl b m => MonadBaseControl b (GetC s i e m) where + type StM (GetC s i e m) a = ComposeSt (GetC s i e) m a + liftBaseWith = defaultLiftBaseWith + {-# INLINE liftBaseWith #-} + restoreM = defaultRestoreM + {-# INLINE restoreM #-} + +instance Monad m => MonadMapError e (GetC s i e m) e' (GetC s i e' m) where + mapError f = C . mapError f . runC + +-- | A 'ConduitM' with internal transformers supposed to a binary deserialization. +type GetM s i o e m = ConduitM i o (GetC s i e m) + +instance (Monoid e, Monad m) => Alternative (GetM s i o e m) where + empty = throwError mempty + {-# INLINE empty #-} + a <|> b = catchError (tryP a) $ \ !ea -> catchError (tryP b) $ \ !eb -> throwError (ea `mappend` eb) + {-# INLINE (<|>) #-} + +instance (Monoid e, Monad m) => MonadPlus (GetM s i o e m) where + mzero = empty + {-# INLINE mzero #-} + mplus a b = a <|> b + {-# INLINE mplus #-} + +-- | Leftover consumed input on error. +tryP :: Monad m => GetM s i o e m a -> GetM s i o e m a +tryP !g = getC $ \ !c -> do + (!t, !d) <- runGetC (startDecoding $ decodingRead c) $ trackP g + case t of + Right (!f, !r) -> return (Right r, continueDecoding (decodingRead d) f c) + Left (!f, !e) -> forM_ f leftover >> return (Left e, c) +{-# INLINE tryP #-} + +-- | Run a decoder, storing input stream. +trackP :: Monad m => GetM s i o e m a -> GetM s i o ([i], e) m ([i], a) +trackP !g = getC $ \ !c -> do + (!r, !f) <- runGetC (Decoding { decodingRead = decodingRead c, tracking = Just [] }) g + let !tracking_f = fromMaybe (error "Data.Conduit.Parsers.GetC.track") $ tracking f + return (either (Left . (tracking_f,)) (Right . (tracking_f,)) r, Decoding { decodingRead = decodingRead f, tracking = (tracking_f ++) <$> tracking c }) +{-# INLINE trackP #-} + +-- | Run a 'Get' monad, unwrapping all internal transformers in a reversible way. +-- @'getC' . 'flip' runGetC = 'id'@ +runGetC :: Monad m => Decoding s i -> GetM s i o e m a -> ConduitM i o m (Either e a, Decoding s i) +runGetC !decoding = runStateC decoding . runExceptC . transPipe runC +{-# INLINE runGetC #-} + +-- | Custom 'Get'. +-- @getC . 'flip' 'runGetC' = 'id'@ +-- Example: +-- > skipUntilZero :: Get e Bool +-- > skipUntilZero = getC $ flip runStateC $ untilJust $ do +-- > !m_inp <- await +-- > case m_inp of +-- > Nothing -> return $ Just $ Right False +-- > Just !inp -> do +-- > case SB.elemIndex 0 inp of +-- > Nothing -> do +-- > lift $ modify' $ decoded inp +-- > return Nothing +-- > Just !i -> do +-- > let (!h, !t) = SB.splitAt i inp +-- > leftover t +-- > lift $ modify' $ decoded h +-- > return $ Just $ Right True +getC :: Monad m => (Decoding s i -> ConduitM i o m (Either e a, Decoding s i)) -> GetM s i o e m a +getC = transPipe C . exceptC . stateC +{-# INLINE getC #-} + +-- | Wrap the base monad in `ExceptT`, pushing `Either` to a monad transformers stack. +exceptG :: Monad m => GetM s i o e' m (Either e a) -> GetM s i o e' (ExceptT (e, Decoding s i) m) a +exceptG g = + getC $ \ !x -> exceptC $ ee <$> runGetC x g + where + ee :: (Either e' (Either e a), Decoding s i) -> Either (e, Decoding s i) (Either e' a, Decoding s i) + ee (Right (Right a), b) = Right (Right a, b) + ee (Right (Left x), b) = Left (x, b) + ee (Left x, b) = Right (Left x, b) +{-# INLINE exceptG #-} + +-- | Run `ExceptT` in the base monad, pulling `Either` from a monad transformers stack. +runExceptG :: Monad m => GetM s i o e' (ExceptT (e, Decoding s i) m) a -> GetM s i o e' m (Either e a) +runExceptG g = + getC $ \ !x -> (ee <$>) $ runExceptC $ runGetC x g + where + ee :: Either (e, Decoding s i) (Either e' a, Decoding s i) -> (Either e' (Either e a), Decoding s i) + ee (Right (Right a, b)) = (Right (Right a), b) + ee (Right (Left x, b)) = (Left x, b) + ee (Left (x, b)) = (Right (Left x), b) +{-# INLINE runExceptG #-} + +-- | Catch an error in the base monad. +catchExceptG :: Monad m => GetM s i o e' (ExceptT (e, Decoding s i) m) r -> (e -> GetM s i o e' (ExceptT (e, Decoding s i) m) r) -> GetM s i o e' (ExceptT (e, Decoding s i) m) r +catchExceptG g c = + getC $ \ !x -> catchExceptC (runGetC x g) (\(e, b) -> runGetC b (c e)) +{-# INLINE catchExceptG #-} + +-- | Wrap the base monad in `ExceptT`, pushing `Maybe` to a monad transformers stack. +maybeG :: Monad m => GetM s i o e m (Maybe a) -> GetM s i o e (ExceptT (Decoding s i) m) a +maybeG g = + getC $ \ !x -> exceptC $ em <$> runGetC x g + where + em :: (Either e (Maybe a), Decoding s i) -> Either (Decoding s i) (Either e a, Decoding s i) + em (Right (Just a), b) = Right (Right a, b) + em (Right Nothing, b) = Left b + em (Left e, b) = Right (Left e, b) +{-# INLINE maybeG #-} + +-- | Run `ExceptT` in the base monad, pulling `Maybe` from a monad transformers stack. +runMaybeG :: Monad m => GetM s i o e (ExceptT (Decoding s i) m) a -> GetM s i o e m (Maybe a) +runMaybeG g = + getC $ \ !x -> (me <$>) $ runExceptC $ runGetC x g + where + me :: Either (Decoding s i) (Either e a, Decoding s i) -> (Either e (Maybe a), Decoding s i) + me (Right (Right a, b)) = (Right (Just a), b) + me (Right (Left e, b)) = (Left e, b) + me (Left b) = (Right Nothing, b) +{-# INLINE runMaybeG #-} + +-- | Wrap the base monad in `ReaderT`. +readerG :: Monad m => (r -> GetM s i o e m a) -> GetM s i o e (ReaderT r m) a +readerG g = getC $ \ !x -> readerC $ \r -> runGetC x (g r) +{-# INLINE readerG #-} + +-- | Run `ReaderT` in the base monad. +runReaderG :: Monad m => r -> GetM s i o e (ReaderT r m) a -> GetM s i o e m a +runReaderG r g = getC $ \ !x -> runReaderC r $ runGetC x g +{-# INLINE runReaderG #-} + +-- | Wrap the base monad in `L.StateT`. +stateLG :: Monad m => (t -> GetM s i o e m (a, t)) -> GetM s i o e (L.StateT t m) a +stateLG g = + getC $ \ !x -> stateLC $ \t -> st <$> runGetC x (g t) + where + st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t) + st (Right (a, t), b) = ((Right a, b), t) + st (Left e, b) = ((Left e, b), error "stateLG") +{-# INLINE stateLG #-} + +-- | Run `L.StateT` in the base monad. +runStateLG :: Monad m => t -> GetM s i o e (L.StateT t m) a -> GetM s i o e m (a, t) +runStateLG t g = + getC $ \ !x -> (ts <$>) $ runStateLC t $ runGetC x g + where + ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i) + ts ((Right a, b), r) = (Right (a, r), b) + ts ((Left e, b), _) = (Left e, b) +{-# INLINE runStateLG #-} + +-- | Evaluate `L.StateT` in the base monad. +evalStateLG :: Monad m => t -> GetM s i o e (L.StateT t m) a -> GetM s i o e m a +evalStateLG t = (fst <$>) . runStateLG t +{-# INLINE evalStateLG #-} + +-- | Execute `L.StateT` in the base monad. +execStateLG :: Monad m => t -> GetM s i o e (L.StateT t m) a -> GetM s i o e m t +execStateLG t = (snd <$>) . runStateLG t +{-# INLINE execStateLG #-} + +-- | Wrap the base monad in `StateT`. +stateG :: Monad m => (t -> GetM s i o e m (a, t)) -> GetM s i o e (StateT t m) a +stateG g = + getC $ \ !x -> stateC $ \t -> st <$> runGetC x (g t) + where + st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t) + st (Right (a, t), b) = ((Right a, b), t) + st (Left e, b) = ((Left e, b), error "stateLG") +{-# INLINE stateG #-} + +-- | Run `StateT` in the base monad. +runStateG :: Monad m => t -> GetM s i o e (StateT t m) a -> GetM s i o e m (a, t) +runStateG t g = + getC $ \ !x -> (ts <$>) $ runStateC t $ runGetC x g + where + ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i) + ts ((Right a, b), r) = (Right (a, r), b) + ts ((Left e, b), _) = (Left e, b) +{-# INLINE runStateG #-} + +-- | Evaluate `StateT` in the base monad. +evalStateG :: Monad m => t -> GetM s i o e (StateT t m) a -> GetM s i o e m a +evalStateG t = (fst <$>) . runStateG t +{-# INLINE evalStateG #-} + +-- | Execute `StateT` in the base monad. +execStateG :: Monad m => t -> GetM s i o e (StateT t m) a -> GetM s i o e m t +execStateG t = (snd <$>) . runStateG t +{-# INLINE execStateG #-} + +-- | Wrap the base monad in `L.WriterT`. +writerLG :: (Monad m, Monoid t) => GetM s i o e m (a, t) -> GetM s i o e (L.WriterT t m) a +writerLG g = + getC $ \ !x -> writerLC $ st <$> runGetC x g + where + st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t) + st (Right (a, t), b) = ((Right a, b), t) + st (Left e, b) = ((Left e, b), error "writerLG") +{-# INLINE writerLG #-} + +-- | Run `L.WriterT` in the base monad. +runWriterLG :: (Monad m, Monoid t) => GetM s i o e (L.WriterT t m) a -> GetM s i o e m (a, t) +runWriterLG g = + getC $ \ !x -> (ts <$>) $ runWriterLC $ runGetC x g + where + ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i) + ts ((Right a, b), r) = (Right (a, r), b) + ts ((Left e, b), _) = (Left e, b) +{-# INLINE runWriterLG #-} + +-- | Execute `L.WriterT` in the base monad. +execWriterLG :: (Monad m, Monoid t) => GetM s i o e (L.WriterT t m) a -> GetM s i o e m t +execWriterLG = (snd <$>) . runWriterLG +{-# INLINE execWriterLG #-} + +-- | Wrap the base monad in `WriterT`. +writerG :: (Monad m, Monoid t) => GetM s i o e m (a, t) -> GetM s i o e (WriterT t m) a +writerG g = + getC $ \ !x -> writerC $ st <$> runGetC x g + where + st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t) + st (Right (a, t), b) = ((Right a, b), t) + st (Left e, b) = ((Left e, b), error "writerG") +{-# INLINE writerG #-} + +-- | Run `WriterT` in the base monad. +runWriterG :: (Monad m, Monoid t) => GetM s i o e (WriterT t m) a -> GetM s i o e m (a, t) +runWriterG g = + getC $ \ !x -> (ts <$>) $ runWriterC $ runGetC x g + where + ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i) + ts ((Right a, b), r) = (Right (a, r), b) + ts ((Left e, b), _) = (Left e, b) +{-# INLINE runWriterG #-} + +-- | Execute `WriterT` in the base monad. +execWriterG :: (Monad m, Monoid t) => GetM s i o e (WriterT t m) a -> GetM s i o e m t +execWriterG = (snd <$>) . runWriterG +{-# INLINE execWriterG #-} + +-- | Wrap the base monad in `L.RWST`. +rwsLG :: (Monad m, Monoid w) => (r -> t -> GetM s i o e m (a, t, w)) -> GetM s i o e (L.RWST r w t m) a +rwsLG g = + getC $ \ !x -> rwsLC $ \r t -> st <$> runGetC x (g r t) + where + st :: (Either e (a, t, w), Decoding s i) -> ((Either e a, Decoding s i), t, w) + st (Right (a, t, w), b) = ((Right a, b), t, w) + st (Left e, b) = ((Left e, b), error "rwsLG.s", error "rwsLG.w") +{-# INLINE rwsLG #-} + +-- | Run `L.RWST` in the base monad. +runRWSLG :: (Monad m, Monoid w) => r -> t -> GetM s i o e (L.RWST r w t m) a -> GetM s i o e m (a, t, w) +runRWSLG r t g = + getC $ \ !x -> (ts <$>) $ runRWSLC r t $ runGetC x g + where + ts :: ((Either e a, Decoding s i), t, w) -> (Either e (a, t, w), Decoding s i) + ts ((Right a, b), x, w) = (Right (a, x, w), b) + ts ((Left e, b), _, _) = (Left e, b) +{-# INLINE runRWSLG #-} + +-- | Evaluate `L.RWST` in the base monad. +evalRWSLG :: (Monad m, Monoid w) => r -> t -> GetM s i o e (L.RWST r w t m) a -> GetM s i o e m (a, w) +evalRWSLG r t = + (res <$>) . runRWSLG r t + where + res (a, _, b) = (a, b) +{-# INLINE evalRWSLG #-} + +-- | Execute `L.RWST` in the base monad. +execRWSLG :: (Monad m, Monoid w) => r -> t -> GetM s i o e (L.RWST r w t m) a -> GetM s i o e m (t, w) +execRWSLG r t = + (res <$>) . runRWSLG r t + where + res (_, a, b) = (a, b) +{-# INLINE execRWSLG #-} + +-- | Wrap the base monad in `RWST`. +rwsG :: (Monad m, Monoid w) => (r -> t -> GetM s i o e m (a, t, w)) -> GetM s i o e (RWST r w t m) a +rwsG g = + getC $ \ !x -> rwsC $ \r t -> st <$> runGetC x (g r t) + where + st :: (Either e (a, t, w), Decoding s i) -> ((Either e a, Decoding s i), t, w) + st (Right (a, t, w), b) = ((Right a, b), t, w) + st (Left e, b) = ((Left e, b), error "rwsG.s", error "rwsG.w") +{-# INLINE rwsG #-} + +-- | Run `RWST` in the base monad. +runRWSG :: (Monad m, Monoid w) => r -> t -> GetM s i o e (RWST r w t m) a -> GetM s i o e m (a, t, w) +runRWSG r t g = + getC $ \ !x -> (ts <$>) $ runRWSC r t $ runGetC x g + where + ts :: ((Either e a, Decoding s i), t, w) -> (Either e (a, t, w), Decoding s i) + ts ((Right a, b), x, w) = (Right (a, x, w), b) + ts ((Left e, b), _, _) = (Left e, b) +{-# INLINE runRWSG #-} + +-- | Evaluate `RWST` in the base monad. +evalRWSG :: (Monad m, Monoid w) => r -> t -> GetM s i o e (RWST r w t m) a -> GetM s i o e m (a, w) +evalRWSG r t = + (res <$>) . runRWSG r t + where + res (a, _, b) = (a, b) +{-# INLINE evalRWSG #-} + +-- | Execute `RWST` in the base monad. +execRWSG :: (Monad m, Monoid w) => r -> t -> GetM s i o e (RWST r w t m) a -> GetM s i o e m (t, w) +execRWSG r t = + (res <$>) . runRWSG r t + where + res (_, a, b) = (a, b) +{-# INLINE execRWSG #-} diff --git a/src/Data/Conduit/Parsers/PutS.hs b/src/Data/Conduit/Parsers/PutS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/PutS.hs @@ -0,0 +1,102 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | This module provides the 'PutS' functor, +-- and all functions, which could not be defined using 'PutS' public interface only. + +module Data.Conduit.Parsers.PutS + ( EncodingState (..) + , VoidEncodingState (..) + , Encoding + , encodingWrote + , runEncoding + , startEncoding + , PutS + , runPutS + , putS + , PutM + ) where + +import Control.Monad.Fix +import Control.Monad.Trans.State.Strict +import Data.Conduit +import Data.Semigroup +import Data.String +import qualified Data.Text as S (Text) + +class EncodingState s where + type EncodingToken s :: * + encoded :: EncodingToken s -> s -> s + +data VoidEncodingState = VoidEncodingState + +instance EncodingState VoidEncodingState where + type EncodingToken VoidEncodingState = () + encoded () = id + {-# INLINE encoded #-} + +-- | 'PutS' functor state. +data Encoding s m = Encoding + { encodingWrote :: !s -- ^ Get the total number of bytes wrote to this point. + , runEncoding :: !(m ()) -- ^ Get the 'Producer'. + } + +instance (EncodingState s, Monad m) => EncodingState (Encoding s m) where + type EncodingToken (Encoding s m) = (m (), EncodingToken s) + encoded (!producer, !bytes_count) !s = Encoding + { encodingWrote = encoded bytes_count (encodingWrote s) + , runEncoding = runEncoding s >> producer + } + {-# INLINE encoded #-} + +-- | Construct 'PutS' initial state. +startEncoding :: Applicative m => s -> Encoding s m +startEncoding !bytes_wrote_before = Encoding + { encodingWrote = bytes_wrote_before + , runEncoding = pure () + } +{-# INLINE startEncoding #-} + +-- | Wrappers for 'Put' with inner monad @m@ and result @a@ (usually @()@). +newtype PutS s m a = S { runS :: State (Encoding s m) a } + +deriving instance Monad (PutS s m) +deriving instance Functor (PutS s m) +deriving instance MonadFix (PutS s m) +deriving instance Applicative (PutS s m) + +instance Monad m => Semigroup (PutS s m ()) where + a <> b = a >> b + {-# INLINE (<>) #-} + +-- | A 'ConduitM' with wrappers supposed to a binary serialization. +type PutM s i o m a = PutS s (ConduitM i o m) a + +instance (EncodingState s, EncodingToken s ~ (), Monad m) => IsString (PutM s i S.Text m ()) where + fromString x = putS $ \ !t -> ((), encoded (yield (fromString x), ()) t) + {-# INLINE fromString #-} + +-- | Run a 'Put' monad, unwrapping all wrappers in a reversible way. +-- @'putS' . runPutS = 'id'@ +runPutS :: PutS s m a -> Encoding s m -> (a, Encoding s m) +runPutS = runState . runS +{-# INLINE runPutS #-} + +-- | Custom 'Put'. +-- @putS . 'runPutS' = 'id'@ +putS :: (Encoding s m -> (a, Encoding s m)) -> PutS s m a +putS = S . state +{-# INLINE putS #-} diff --git a/src/Data/Conduit/Parsers/Text.hs b/src/Data/Conduit/Parsers/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Text.hs @@ -0,0 +1,46 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | This module provides the 'GetC' monad transformer, +-- and all functions, which could not be defined using 'GetC' public interface only. + +module Data.Conduit.Parsers.Text + ( DecodingLinesRead (..) + , DecodingColumnsRead (..) + , DecodingTextRead + ) where + +import Data.Word +import Data.Conduit.Parsers +import Data.Conduit.Parsers.GetC + +class DecodingLinesRead s where + decodingLinesRead :: s -> Word64 + +class DecodingColumnsRead s where + decodingColumnsRead :: s -> Word64 + +class (DecodingElemsRead s, DecodingLinesRead s, DecodingColumnsRead s) => DecodingTextRead s where + +instance (DecodingElemsRead s, DecodingLinesRead s, DecodingColumnsRead s) => DecodingTextRead s where + +instance (DecodingState s, DecodingLinesRead s) => DecodingLinesRead (Decoding s i) where + decodingLinesRead = decodingLinesRead . decodingRead + {-# INLINE decodingLinesRead #-} + +instance (DecodingState s, DecodingColumnsRead s) => DecodingColumnsRead (Decoding s i) where + decodingColumnsRead = decodingColumnsRead . decodingRead + {-# INLINE decodingColumnsRead #-} diff --git a/src/Data/Conduit/Parsers/Text/Gen.hs b/src/Data/Conduit/Parsers/Text/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Text/Gen.hs @@ -0,0 +1,92 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | Despite binary's 'S.Put' is fully-functional construction (unlike 'S.Get'), +-- we decided to provide this module for symmetry with 'Data.Binary.Conduit.Get'. + +module Data.Conduit.Parsers.Text.Gen + ( PutM + , TextGen + , runTextGen + , genString + , genLazyString + , genShow + , genDigit + , genHexDigit + , genHexByte + , genEnum + ) where + +import Data.Bits +import Data.Char +import Data.Conduit +import qualified Data.Text as S (Text) +import qualified Data.Text as ST hiding (Text, head, last, tail, init) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T hiding (Text, head, last, tail, init) +import Data.Word +import Data.Conduit.Parsers.PutS + +class (EncodingState s, EncodingToken s ~ ()) => DefaultTextGenState s where + +instance (EncodingState s, EncodingToken s ~ ()) => DefaultTextGenState s where + +-- | The shortening of 'PutM' for the most common use case. +type TextGen = forall s i m. (DefaultTextGenState s, Monad m) => PutM s i S.Text m () + +-- | Run an encoder presented as a 'Put' monad. +-- Returns 'Producer'. +runTextGen :: PutM VoidEncodingState i o m () -> ConduitM i o m () +runTextGen !p = runEncoding $ snd $ runPutS p $ startEncoding VoidEncodingState +{-# INLINE runTextGen #-} + +genString :: S.Text -> TextGen +genString !x = putS $ \ !t -> ((), encoded (yield x, ()) t) +{-# INLINE genString #-} + +genLazyString :: Text -> TextGen +genLazyString !x = putS $ \ !t -> ((), encoded (mapM_ yield $ T.toChunks x, ()) t) +{-# INLINE genLazyString #-} + +genShow :: Show a => a -> TextGen +genShow = genLazyString . T.pack . show +{-# INLINE genShow #-} + +genDigit :: Integral a => a -> TextGen +genDigit !x + | x < 0 || x >= 10 = error "genDigit" + | otherwise = genString $ ST.singleton $ chr $ ord '0' + fromIntegral x +{-# INLINE genDigit #-} + +genHexDigit :: Integral a => Bool -> a -> TextGen +genHexDigit !uppercase = + genString . ST.singleton . chr . toCharCode . fromIntegral + where + toCharCode !x + | x < 0 || x >= 16 = error "genHexDigit" + | x < 10 = ord '0' + x + | otherwise = (if uppercase then ord 'A' else ord 'a') + (x - 10) +{-# INLINE genHexDigit #-} + +genHexByte :: Bool -> Word8 -> TextGen +genHexByte !uppercase !c = do + genHexDigit uppercase $ c `shiftR` 4 + genHexDigit uppercase $ c .&. 0xF +{-# INLINE genHexByte #-} + +genEnum :: (Eq a, Ord a, Enum a, Bounded a, Show a) => Int -> a -> TextGen +genEnum !prefix = genString . ST.drop prefix . ST.pack . show +{-# INLINE genEnum #-} diff --git a/src/Data/Conduit/Parsers/Text/Parser.hs b/src/Data/Conduit/Parsers/Text/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Text/Parser.hs @@ -0,0 +1,323 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | At the first look, Data.Binary.Conduit.Get module is very similar with Data.Binary.Get. +-- The main differences between them are the following. +-- While the 'S.Get' from binary is a very custom monad, +-- the local 'Get' is 'ConduitM', which leads to easy integration in complicated format parsing. +-- The Data.Binary.Get module does not have a function to create custom 'S.Get' monad, +-- this module provides 'getC'. +-- Unlike 'isolate' from binary, local 'isolate' does not "cut" bytes counter. +-- While the binary's 'S.Get' is 'MonadFail', which leads to very ugly errors handling +-- in complicated cases, local 'Get' is 'MonadError'. + +module Data.Conduit.Parsers.Text.Parser + ( MonadMapError (..) + , (?=>>) + , (?>>) + , DefaultParsingState + , GetM + , Parser + , runParser + , charsRead + , linesRead + , columnsRead + , castParser + , pCharIs + , skipCharIs + , pChar + , pCharIsNot + , satisfy + , satisfyWith + , skip1 + , peekChar + , peekChar' + , pDigit + , pHexDigit + , pHexByte + , pLetter + , pSpace + , inClass + , notInClass + , pStringIs + , skipStringIs + , pAsciiIgnoringCaseIs + , skipSpace + , skipWhile + , scan + , runScanner + , pString + , pStringWhile + , pStringWhile1 + , pStringTill + , pRemainingString + , pRemainingLazyString + , skipEndOfLine + , isEndOfLine + , isHorizontalSpace + , pDecimal + , pHexadecimal + , pSignedDecimal + , pSignedHexadecimal + , pDouble + , pRational + , pScientific + , choice + , count + , option'' + , many'' + , many1'' + , manyTill'' + , sepBy'' + , sepBy1'' + , skipMany'' + , skipMany1'' + , eitherP + , matchP + , tryP + , pEnum + , endOfInput + ) where + +import Prelude hiding (head, take, takeWhile) +import Control.Applicative +import Control.Monad +import Data.Attoparsec.Text (inClass, notInClass, isEndOfLine, isHorizontalSpace) +import qualified Data.Attoparsec.Text as T (Parser) +import qualified Data.Attoparsec.Text as TP (parse, IResult (..)) +import qualified Data.Attoparsec.Text as Tp hiding (parse, parseOnly, Parser, Result, IResult, Done, Partial, Fail, inClass, notInClass, isEndOfLine, isHorizontalSpace) +import Data.Bits +import Data.Char +import Data.Conduit +import qualified Data.Conduit.Combinators as N +import Data.List.NonEmpty hiding (take, takeWhile) +import Data.NonNull hiding (head) +import Data.Scientific (Scientific) +import Data.Text.Lazy (Text) +import qualified Data.Text as S (Text) +import qualified Data.Text as ST hiding (Text, head, last, tail, init) +import Data.Word +import Control.Monad.Error.Map +import Data.Conduit.Parsers +import Data.Conduit.Parsers.Text +import Data.Conduit.Parsers.Text.TextOffset +import Data.Conduit.Parsers.GetC + +class (DecodingState s, DecodingToken s ~ S.Text, DecodingTextRead s) => DefaultParsingState s where + +instance (DecodingState s, DecodingToken s ~ S.Text, DecodingTextRead s) => DefaultParsingState s where + +-- | The shortening of 'GetM' for the most common use case. +type Parser e a = forall s o m. (DefaultParsingState s, Monad m) => GetM s S.Text o e m a + +-- | Run a decoder presented as a 'Get' monad. +-- Returns decoder result and consumed bytes count. +runParser :: Monad m => GetM TextOffset i o e m a -> ConduitM i o m (Either e a) +runParser !g = fst <$> runGetC (startDecoding $ TextOffset 0 0 0) g +{-# INLINE runParser #-} + +-- | Get the total number of bytes read to this point. +charsRead :: (DecodingState s, DecodingElemsRead s, Monad m) => GetM s i o e m Word64 +charsRead = elemsRead +{-# INLINE charsRead #-} + +-- | Get the total number of bytes read to this point. +linesRead :: (DecodingState s, DecodingLinesRead s, Monad m) => GetM s i o e m Word64 +linesRead = getC $ \ !x -> return (Right $ decodingLinesRead x, x) +{-# INLINE linesRead #-} + +-- | Get the total number of bytes read to this point. +columnsRead :: (DecodingState s, DecodingColumnsRead s, Monad m) => GetM s i o e m Word64 +columnsRead = getC $ \ !x -> return (Right $ decodingColumnsRead x, x) +{-# INLINE columnsRead #-} + +-- | Run the given 'S.Get' monad from binary package +-- and convert result into 'Get'. +castParser :: (DecodingState s, DecodingToken s ~ S.Text, Monad m) => T.Parser a -> GetM s S.Text o (NonEmpty String) m a +castParser !g = getC $ + go (TP.Partial $ TP.parse g) ST.empty + where + go (TP.Done !rest !result) !chunk !decoding = + if ST.null rest + then return (Right result, decoded chunk decoding) + else leftover rest >> return (Right result, decoded (ST.take (ST.length chunk - ST.length rest) chunk) decoding) + go (TP.Fail _ !err_context !err) !chunk !decoding = return (Left (err :| err_context), decoded chunk decoding) + go (TP.Partial !continue) !chunk !decoding = do + next <- maybe ST.empty toNullable <$> N.awaitNonNull + go (continue next) next (decoded chunk decoding) +{-# INLINE castParser #-} + +voidError :: Monad m => GetM s i o e m a -> GetM s i o () m a +voidError = mapError (const ()) +{-# INLINE voidError #-} + +anyError :: Monad m => GetM s i o e' m a -> GetM s i o e m a +anyError = mapError (const $ error "Data.Conduit.Parsers.Text.Parser.anyError") +{-# INLINE anyError #-} + +skipCharIs :: Char -> Parser () () +skipCharIs = void . pCharIs +{-# INLINE skipCharIs #-} + +pCharIs :: Char -> Parser () Char +pCharIs = voidError . castParser . Tp.char +{-# INLINE pCharIs #-} + +pChar :: Parser () Char +pChar = voidError $ castParser Tp.anyChar +{-# INLINE pChar #-} + +pCharIsNot :: Char -> Parser () Char +pCharIsNot = voidError . castParser . Tp.notChar +{-# INLINE pCharIsNot #-} + +satisfy :: (Char -> Bool) -> Parser () Char +satisfy = voidError . castParser . Tp.satisfy +{-# INLINE satisfy #-} + +satisfyWith :: (Char -> a) -> (a -> Bool) -> Parser () a +satisfyWith tr = voidError . castParser . Tp.satisfyWith tr +{-# INLINE satisfyWith #-} + +skip1 :: (Char -> Bool) -> Parser () () +skip1 = voidError . castParser . Tp.skip +{-# INLINE skip1 #-} + +peekChar :: Parser e (Maybe Char) +peekChar = anyError $ castParser Tp.peekChar +{-# INLINE peekChar #-} + +peekChar' :: Parser e Char +peekChar' = anyError $ castParser Tp.peekChar' +{-# INLINE peekChar' #-} + +pDigit :: Integral a => Parser () a +pDigit = voidError $ (\ !x -> fromIntegral $ ord x - ord '0') <$> castParser Tp.digit +{-# INLINE pDigit #-} + +pHexDigit :: Integral a => Parser () a +pHexDigit = + (fromIntegral . digitValue) <$> satisfy isHexDigit + where + digitValue x + | x >= 'a' = 10 + (ord x - ord 'a') + | x >= 'A' = 10 + (ord x - ord 'A') + | otherwise = ord x - ord '0' +{-# INLINE pHexDigit #-} + +pHexByte :: Parser () Word8 +pHexByte = do + !h <- pHexDigit + !l <- pHexDigit + return $ h `shiftL` 4 .|. l +{-# INLINE pHexByte #-} + +pLetter :: Parser () Char +pLetter = voidError $ castParser Tp.letter +{-# INLINE pLetter #-} + +pSpace :: Parser () Char +pSpace = voidError $ castParser Tp.space +{-# INLINE pSpace #-} + +skipStringIs :: S.Text -> Parser () () +skipStringIs = void . pStringIs +{-# INLINE skipStringIs #-} + +pStringIs :: S.Text -> Parser () S.Text +pStringIs = voidError . castParser . Tp.string +{-# INLINE pStringIs #-} + +pAsciiIgnoringCaseIs :: S.Text -> Parser () S.Text +pAsciiIgnoringCaseIs = voidError . castParser . Tp.asciiCI +{-# INLINE pAsciiIgnoringCaseIs #-} + +skipSpace :: Parser () () +skipSpace = voidError $ castParser Tp.skipSpace +{-# INLINE skipSpace #-} + +skipWhile :: (Char -> Bool) -> Parser e () +skipWhile = anyError . castParser . Tp.skipWhile +{-# INLINE skipWhile #-} + +scan :: s -> (s -> Char -> Maybe s) -> Parser e S.Text +scan s = anyError . castParser . Tp.scan s +{-# INLINE scan #-} + +runScanner :: s -> (s -> Char -> Maybe s) -> Parser e (S.Text, s) +runScanner s = anyError . castParser . Tp.runScanner s +{-# INLINE runScanner #-} + +pString :: Int -> Parser () S.Text +pString = voidError . castParser . Tp.take +{-# INLINE pString #-} + +pStringWhile :: (Char -> Bool) -> Parser e S.Text +pStringWhile = anyError . castParser . Tp.takeWhile +{-# INLINE pStringWhile #-} + +pStringWhile1 :: (Char -> Bool) -> Parser () S.Text +pStringWhile1 = voidError . castParser . Tp.takeWhile +{-# INLINE pStringWhile1 #-} + +pStringTill :: (Char -> Bool) -> Parser e S.Text +pStringTill = anyError . castParser . Tp.takeTill +{-# INLINE pStringTill #-} + +pRemainingString :: Parser e S.Text +pRemainingString = anyError $ castParser Tp.takeText +{-# INLINE pRemainingString #-} + +pRemainingLazyString :: Parser e Text +pRemainingLazyString = anyError $ castParser Tp.takeLazyText +{-# INLINE pRemainingLazyString #-} + +skipEndOfLine :: Parser () () +skipEndOfLine = voidError $ castParser Tp.endOfLine +{-# INLINE skipEndOfLine #-} + +pDecimal :: Integral a => Parser () a +pDecimal = voidError $ castParser Tp.decimal +{-# INLINE pDecimal #-} + +pHexadecimal :: (Integral a, Bits a) => Parser () a +pHexadecimal = voidError $ castParser Tp.hexadecimal +{-# INLINE pHexadecimal #-} + +pSignedDecimal :: Integral a => Parser () a +pSignedDecimal = voidError $ castParser $ Tp.signed Tp.decimal +{-# INLINE pSignedDecimal #-} + +pSignedHexadecimal :: (Integral a, Bits a) => Parser () a +pSignedHexadecimal = voidError $ castParser $ Tp.signed Tp.hexadecimal +{-# INLINE pSignedHexadecimal #-} + +pDouble :: Parser () Double +pDouble = voidError $ castParser Tp.double +{-# INLINE pDouble #-} + +pRational :: Fractional a => Parser () a +pRational = voidError $ castParser Tp.rational +{-# INLINE pRational #-} + +pScientific :: Parser () Scientific +pScientific = voidError $ castParser Tp.scientific +{-# INLINE pScientific #-} + +pEnum :: (Eq a, Ord a, Enum a, Bounded a, Show a) => Int -> Parser () a +pEnum !prefix = do + foldl1 (<|>) [pStringIs (ST.drop prefix $ ST.pack $ show t) >> return t | t <- [minBound .. maxBound]] +{-# INLINE pEnum #-} diff --git a/src/Data/Conduit/Parsers/Text/TextOffset.hs b/src/Data/Conduit/Parsers/Text/TextOffset.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Parsers/Text/TextOffset.hs @@ -0,0 +1,59 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +-- | At the first look, Data.Binary.Conduit.Get module is very similar with Data.Binary.Get. +-- The main differences between them are the following. +-- While the 'S.Get' from binary is a very custom monad, +-- the local 'Get' is 'ConduitM', which leads to easy integration in complicated format parsing. +-- The Data.Binary.Get module does not have a function to create custom 'S.Get' monad, +-- this module provides 'getC'. +-- Unlike 'isolate' from binary, local 'isolate' does not "cut" bytes counter. +-- While the binary's 'S.Get' is 'MonadFail', which leads to very ugly errors handling +-- in complicated cases, local 'Get' is 'MonadError'. + +module Data.Conduit.Parsers.Text.TextOffset + ( TextOffset (..) + ) where + +import qualified Data.Text as S (Text) +import qualified Data.Text as ST hiding (Text, head, last, tail, init) +import Data.Word +import Data.Conduit.Parsers +import Data.Conduit.Parsers.GetC +import Data.Conduit.Parsers.Text + +data TextOffset = TextOffset Word64 Word64 Word64 deriving Show + +instance DecodingState TextOffset where + type DecodingToken TextOffset = S.Text + decoded !i (TextOffset !o !l !c) = + let newlines = reverse $ drop 1 $ ST.split (== '\n') i in + TextOffset (o + fromIntegral (ST.length i)) (l + fromIntegral (length newlines)) $ case newlines of + [] -> c + fromIntegral (ST.length i) + (x : _) -> fromIntegral (ST.length x) + {-# INLINE decoded #-} + +instance DecodingElemsRead TextOffset where + decodingElemsRead (TextOffset !o _ _) = o + {-# INLINE decodingElemsRead #-} + +instance DecodingLinesRead TextOffset where + decodingLinesRead (TextOffset _ !l _) = l + {-# INLINE decodingLinesRead #-} + +instance DecodingColumnsRead TextOffset where + decodingColumnsRead (TextOffset _ _ !c) = c + {-# INLINE decodingColumnsRead #-} diff --git a/test/Data/Conduit/Parsers/Binary/Get/Spec.hs b/test/Data/Conduit/Parsers/Binary/Get/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Conduit/Parsers/Binary/Get/Spec.hs @@ -0,0 +1,316 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Data.Conduit.Parsers.Binary.Get.Spec + ( tests + ) where + +import Control.Applicative +import Control.Monad.Error.Class +import Control.Monad.Loops +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict +import Data.Bits +import qualified Data.ByteString as S (ByteString) +import qualified Data.ByteString as SB hiding (ByteString, head, last, init, tail) +import Data.ByteString.Lazy (ByteString) +import Data.Char +import Data.Conduit +import qualified Data.Conduit.Combinators as N +import Data.Conduit.Lift +import Data.Functor.Identity +import Data.Semigroup hiding (Option) +import Data.Void +import Data.Word +import Test.HUnit.Base hiding (Label) +import qualified Data.Conduit.Parsers as G +import qualified Data.Conduit.Parsers.Binary.ByteOffset as G +import Data.Conduit.Parsers.Binary.Get hiding (runGet) +import qualified Data.Conduit.Parsers.Binary.Get as G (runGet) +import qualified Data.Conduit.Parsers.GetC as G + +tests :: Test +tests = TestList + [ TestCase getBytes1 + , TestCase getBytes2 + , TestCase testSkip + , TestCase eofError + , TestCase eofOrNotEof + , TestCase testIsolateOverAlternativeIsolateNotEnough + , TestCase testIsolateOverAlternativeIsolateExactly + , TestCase testIsolateOverAlternativeIsolateEnough + , TestCase testIsolateOverAlternativeIsolateEnoughButEof + , TestCase testIsolateIsolateEnoughButEof + , TestCase testIsolateIsolateEnoughButEofEarly + , TestCase testAlternativeRollback + , TestCase testRecords + , TestCase testLeftoversInIsolate + , TestCase testSkipUntilZero + , TestCase testErrorMap + ] + +runGet :: Monad m => GetM G.ByteOffset i o e m a -> ConduitM i o m (Either e a, Word64) +runGet !g = (\(!r, !s) -> (r, G.decodingElemsRead s)) <$> G.runGetC (G.startDecoding $ G.ByteOffset 0) g + +testInput1 :: [S.ByteString] +testInput1 = + [ "\x12\x13\x14" + , "\x15\x18\xF3" + , "" + ] + +testInput2 :: [S.ByteString] +testInput2 = + [ "\x12\x13\x14" + , "\x15\x18\xF3" + , "\0" + ] + +testInput3 :: [S.ByteString] +testInput3 = + [ "\x12\x13" + , "\x15\x18\xF3" + , "\0" + ] + +testInput4 :: [S.ByteString] +testInput4 = + [ "AB" + , "C" + ] + +testInput5 :: [S.ByteString] +testInput5 = + [ "AB" + , "CDE" + ] + +testInput6 :: [S.ByteString] +testInput6 = + [ "\x01\x02\x03\x04\x05\x06" + , "\x07\x08\x09\x0A\x0B\x0C" + ] + +testInput7 :: [S.ByteString] +testInput7 = + [ "A" + , "B" + , "C" + ] + +ensureEof :: e -> Get e () +ensureEof e = do + eof <- N.nullE + if eof then return () else throwError e + +get1 :: (DefaultDecodingState s, Monad m) => GetM s S.ByteString Word16 Bool m () +get1 = do + yield =<< mapError (const False) getWord16le + yield =<< mapError (const False) getWord16le + yield =<< mapError (const False) getWord16be + ensureEof True + +get2 :: Get () Word64 +get2 = do + skip 3 + bytesRead + +getTailBytes :: Get () S.ByteString +getTailBytes = do + r <- getByteString 3 + ensureEof () + return r + +getBytes1 :: Assertion +getBytes1 = do + let ((!e, !c), !r) = runIdentity $ N.yieldMany testInput1 $$ (runGet get1 `fuseBoth` N.sinkList) + assertEqual "" (Right ()) e + assertEqual "" [0x13 `shiftL` 8 .|. 0x12, 0x15 `shiftL` 8 .|. 0x14, 0x18 `shiftL` 8 .|. 0xF3] r + assertEqual "" 6 c + +getBytes2 :: Assertion +getBytes2 = do + let ((!e, !c), !r) = runIdentity $ N.yieldMany testInput2 $$ (runGet get1 `fuseBoth` N.sinkList) + assertEqual "" (Left True) e + assertEqual "" [0x13 `shiftL` 8 .|. 0x12, 0x15 `shiftL` 8 .|. 0x14, 0x18 `shiftL` 8 .|. 0xF3] r + assertEqual "" 6 c + +testSkip :: Assertion +testSkip = do + let (!e, !c) = runIdentity $ N.yieldMany testInput3 $$ runGet get2 + assertEqual "" (Right 3) e + assertEqual "" 3 c + +eofError :: Assertion +eofError = do + let (!e, !c) = runIdentity $ N.yieldMany testInput4 $$ runGet getInt64host + assertEqual "" (Left ()) e + assertEqual "" 3 c + +eofOrNotEof :: Assertion +eofOrNotEof = do + let (!e, !c) = runIdentity $ N.yieldMany testInput4 $$ runGet (Right <$> getInt64host <|> Left <$> getTailBytes) + assertEqual "" (Right $ Left "ABC") e + assertEqual "" 3 c + +testIsolateOverAlternativeIsolateNotEnough :: Assertion +testIsolateOverAlternativeIsolateNotEnough = do + let + (!e, !c) = runIdentity $ N.yieldMany testInput5 + $$ runGet (isolate 2 $ Right <$> getInt32le <|> Left <$> getWord8) + assertEqual "" (Left $ Left $ Just 1) e + assertEqual "" 1 c + +testIsolateOverAlternativeIsolateExactly :: Assertion +testIsolateOverAlternativeIsolateExactly = do + let + (!e, !c) = runIdentity $ N.yieldMany testInput5 + $$ runGet (isolate 1 $ Right <$> getInt32le <|> Left <$> getWord8) + assertEqual "" (Right $ Left $ fromIntegral $ ord 'A') e + assertEqual "" 1 c + +testIsolateOverAlternativeIsolateEnough :: Assertion +testIsolateOverAlternativeIsolateEnough = do + let + (!e, !c) = runIdentity $ N.yieldMany testInput5 + $$ runGet (isolate 4 $ Right <$> getInt32le <|> Left <$> getWord8) + assertEqual "" (Right $ Right 1145258561) e + assertEqual "" 4 c + +testIsolateOverAlternativeIsolateEnoughButEof :: Assertion +testIsolateOverAlternativeIsolateEnoughButEof = do + let + (!e, !c) = runIdentity $ N.yieldMany testInput4 + $$ runGet (isolate 4 $ Right <$> getInt32le <|> Left <$> getWord8) + assertEqual "" (Left $ Left Nothing) e + assertEqual "" 0 c + +testIsolateIsolateEnoughButEof :: Assertion +testIsolateIsolateEnoughButEof = do + let + (!e, !c) = runIdentity $ N.yieldMany testInput4 + $$ runGet (isolate 4 getWord8) + assertEqual "" (Left $ Left $ Just 1) e + assertEqual "" 1 c + +testIsolateIsolateEnoughButEofEarly :: Assertion +testIsolateIsolateEnoughButEofEarly = do + let + (!e, !c) = runIdentity $ N.yieldMany testInput7 + $$ runGet (isolate 4 $ getWord8 >> getWord8 >> getWord8 >> getWord8) + assertEqual "" (Left $ Left Nothing) e + assertEqual "" 0 c + +testAlternativeRollback :: Assertion +testAlternativeRollback = do + let (!e, !c) = runIdentity $ N.yieldMany testInput6 $$ runGet ((skip 9 >> throwError ()) <|> getWord64le) + assertEqual "" (Right $ 0x01 .|. 0x02 `shiftL` 8 .|. 0x03 `shiftL` 16 .|. 0x04 `shiftL` 24 .|. 0x05 `shiftL` 32 .|. 0x06 `shiftL` 40 .|. 0x07 `shiftL` 48 .|. 0x08 `shiftL` 56) e + assertEqual "" 8 c + +recordBody :: Get () [Word64] +recordBody = whileM (not <$> N.nullE) $ mapError (const ()) $ isolate 8 getWord64le + +record :: Word64 -> Get (Either (Maybe Word64) ()) [Word64] +record z = isolate z recordBody + +records :: (DefaultDecodingState s, Monad m) => GetM s S.ByteString [Word64] (Either (Maybe Word64) ()) m () +records = do + yield =<< record 24 + yield =<< record 16 + yield =<< record 8 + +recordsInput :: [S.ByteString] +recordsInput = + [ "0123456701234567" + , "01234567012345670123456701234567" + ] + +testRecords :: Assertion +testRecords = do + let ((!e, !c), !r) = runIdentity $ N.yieldMany recordsInput $$ (runGet records `fuseBoth` N.sinkList) + assertEqual (show c) (Right ()) e + assertEqual "" [[3978425819141910832, 3978425819141910832, 3978425819141910832], [3978425819141910832, 3978425819141910832], [3978425819141910832]] r + assertEqual "" 48 c + +takeE :: Monad m => Int -> ConduitM S.ByteString o m S.ByteString +takeE !n = + go SB.empty 0 + where + go consumed !consumed_length + | consumed_length >= n = return consumed + | otherwise = do + !mi <- await + case mi of + Nothing -> error "takeE" + Just !i -> do + let !gap = n - consumed_length + if gap >= SB.length i + then do + go (consumed <> i) (consumed_length + fromIntegral (SB.length i)) + else do + let (!got, !rest) = SB.splitAt gap i + leftover rest + return (consumed <> got) + +testLeftoversInIsolate :: Assertion +testLeftoversInIsolate = do + let !i = isolate 4 $ (leftover =<< takeE 4) >> skip 2 + let + !g = do + catchError i $ const $ return () + !r <- mapError Right $ getByteString 2 + ensureEof $ Right () + return r + let (!e, !c) = runIdentity $ yield "ABCD" $$ runGet g + assertEqual "" (Right "CD") e + assertEqual "" 4 c + +skipUntilZero :: Get e Bool +skipUntilZero = G.getC $ flip runStateC $ untilJust $ do + !m_inp <- await + case m_inp of + Nothing -> return $ Just $ Right False + Just !inp -> do + case SB.elemIndex 0 inp of + Nothing -> do + lift $ modify' $ G.decoded inp + return Nothing + Just !i -> do + let (!h, !t) = SB.splitAt i inp + leftover t + lift $ modify' $ G.decoded h + return $ Just $ Right True + +testZeroInput1 :: [S.ByteString] +testZeroInput1 = + [ "0123" + , "45\0zx" + , "8" + ] + +testSkipUntilZero :: Assertion +testSkipUntilZero = do + let (!r, !c) = runIdentity $ N.yieldMany testZeroInput1 $$ runGet (skipUntilZero >> getRemainingLazyByteString) + assertEqual "" ((Right "\0zx8") :: Either Void ByteString) r + assertEqual "" 10 c + +w32 :: Get String Word32 +w32 = getWord32le ?>> ("Unexpected EOF at " ++) <$> show <$> bytesRead + +testErrorMap :: Assertion +testErrorMap = do + let !r = runIdentity $ N.yieldMany [] $$ G.runGet w32 + assertEqual "" (Left "Unexpected EOF at 0") r diff --git a/test/Data/Conduit/Parsers/Binary/Put/Spec.hs b/test/Data/Conduit/Parsers/Binary/Put/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Conduit/Parsers/Binary/Put/Spec.hs @@ -0,0 +1,64 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Data.Conduit.Parsers.Binary.Put.Spec + ( tests + ) where + +import Control.Monad hiding (fail) +import Control.Monad.Error.Class +import Control.Monad.Fix +import Control.Monad.Trans.Class +import Data.Bits +import qualified Data.ByteString as S (ByteString) +import Data.Conduit +import qualified Data.Conduit.Combinators as N +import Test.HUnit.Base hiding (Label) +import Data.Conduit.Parsers.Binary.Get +import Data.Conduit.Parsers.Binary.Put + +tests :: Test +tests = TestList + [ TestCase testExample + ] + +putWithSize :: (DefaultEncodingState s, Monad m) => PutM s i S.ByteString m () -> PutM s i S.ByteString m () +putWithSize !p = void $ mfix $ \size -> do + putWord64le size + before <- bytesWrote + p + after <- bytesWrote + return $ after - before + +testPut1 :: Int -> Put +testPut1 n = do + forM_ [1 .. n] putInthost + +testExample :: Assertion +testExample = do + runPut (putWithSize $ testPut1 3) $$ testResult + where + testResult = do + (\x -> lift $ assertEqual "" (Right $ 3 * fromIntegral (finiteBitSize (0 :: Word))) x) =<< runGet getWord64le + (\x -> lift $ assertEqual "" (Right 1) x) =<< runGet getWordhost + (\x -> lift $ assertEqual "" (Right 2) x) =<< runGet getWordhost + (\x -> lift $ assertEqual "" (Right 3) x) =<< runGet getWordhost + (\x -> lift $ assertEqual "" (Right ()) x) =<< runGet (ensureEof ()) + +ensureEof :: e -> Get e () +ensureEof e = do + eof <- N.nullE + if eof then return () else throwError e diff --git a/test/Data/Conduit/Parsers/Text/Parser/Spec.hs b/test/Data/Conduit/Parsers/Text/Parser/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Conduit/Parsers/Text/Parser/Spec.hs @@ -0,0 +1,69 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Data.Conduit.Parsers.Text.Parser.Spec + ( tests + ) where + +import Data.Conduit +import qualified Data.Conduit.Combinators as N +import Data.Functor.Identity +import qualified Data.Text as S (Text) +import Test.HUnit.Base hiding (Label) +import Data.Conduit.Parsers.Binary.Get hiding (runGet) +import Data.Conduit.Parsers.Text.Parser + +tests :: Test +tests = TestList + [ TestCase testLinesRead + ] + +testLinesRead :: Assertion +testLinesRead = do + let !r = runIdentity $ N.yieldMany testInput1 $$ runParser parser1 + assertEqual "" (Right ('t', 'x')) r + +parser1 :: Parser () (Char, Char) +parser1 = do + 0 <- linesRead + 0 <- columnsRead + c1 <- pChar + 0 <- linesRead + 1 <- columnsRead + skipEndOfLine + 1 <- linesRead + 0 <- columnsRead + skipCharIs 'a' + 1 <- linesRead + 1 <- columnsRead + skipCharIs 'u' + 1 <- linesRead + 2 <- columnsRead + skipEndOfLine + 2 <- linesRead + 0 <- columnsRead + c2 <- pCharIsNot 'b' + 2 <- linesRead + 1 <- columnsRead + endOfInput + return (c1, c2) + +testInput1 :: [S.Text] +testInput1 = + [ "t\n" + , "au\nx" + , "" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,32 @@ +-- +-- Copyright 2017 Warlock +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +import Control.Monad hiding (fail) +import Test.HUnit.Base hiding (Label) +import Test.HUnit.Text +import qualified Data.Conduit.Parsers.Binary.Get.Spec +import qualified Data.Conduit.Parsers.Binary.Put.Spec +import qualified Data.Conduit.Parsers.Text.Parser.Spec + +main :: IO () +main = void $ runTestTT tests + +tests :: Test +tests = TestList + [ Data.Conduit.Parsers.Binary.Get.Spec.tests + , Data.Conduit.Parsers.Binary.Put.Spec.tests + , Data.Conduit.Parsers.Text.Parser.Spec.tests + ] diff --git a/tests/Action.hs b/tests/Action.hs deleted file mode 100644 --- a/tests/Action.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module Action where - -import Control.Applicative -import Control.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Char -import Data.Int -import Data.List (intersperse, nub) - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck - -import Arbitrary () -import qualified Data.Binary.Get.Ext as Binary - -tests :: [Test] -tests = [ testProperty "action" prop_action - , testProperty "label" prop_label - , testProperty "fail" prop_fail ] - -data Action - = Actions [Action] - | GetByteString Int - | GetByteStringL Int - | Skip Int - | Isolate Int [Action] - | Try [Action] [Action] - | Label String [Action] - | LookAhead [Action] - -- | First argument is True if this action returns Just, otherwise False. - | LookAheadM Bool [Action] - -- | First argument is True if this action returns Right, otherwise Left. - | LookAheadE Bool [Action] - | BytesRead - | Fail - deriving (Show, Eq) - -instance Arbitrary Action where - arbitrary = fmap Actions (gen_actions False) - shrink action = - case action of - Actions [a] -> [a] - Actions as -> [ Actions as' | as' <- shrink as ] - BytesRead -> [] - Fail -> [] - GetByteString n -> [ GetByteString n' | n' <- shrink n ] - GetByteStringL n -> [ GetByteStringL n' | n' <- shrink n ] - Skip n -> [ Skip n' | n' <- shrink n ] - Isolate n as -> nub $ Actions as : - [ Isolate n' as' | (n',as') <- shrink (n,as) - , n' >= 0 - , n' <= max_len as' + 1 ] - Label str a -> Actions a : [ Label str a' | a' <- shrink a ] - LookAhead a -> Actions a : [ LookAhead a' | a' <- shrink a ] - LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- shrink a ] - LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- shrink a ] - Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ] - Try a b -> - [Actions a | not (willFail' a)] - ++ [ Try a' b' | (a',b') <- shrink (a,b) ] - -willFail :: Int -> [Action] -> Bool -willFail inp xxs = - case eval inp xxs of - EFail {} -> True - _ -> False - -willFail' :: [Action] -> Bool -willFail' = willFail maxBound - --- | The maximum length of input decoder can request. --- The decoder may end up using less, but never more. --- This way, you know how much input to generate for running a decoder test. -max_len :: [Action] -> Int -max_len [] = 0 -max_len (x:xs) = - case x of - Actions xs' -> max_len (xs' ++ xs) - BytesRead -> max_len xs - Fail -> 0 - GetByteString n -> n + max_len xs - GetByteStringL n -> n + max_len xs - Skip n -> n + max_len xs - Isolate n xs' - | Just _ <- actual_len' [Isolate n xs'] -> n + max_len xs - | otherwise -> n - Label _ xs' -> max_len (xs' ++ xs) - LookAhead xs' - | willFail' xs' -> max_len xs' - | otherwise -> max (max_len xs') (max_len xs) - LookAheadM consume xs' - | consume -> max_len (xs' ++ xs) - | otherwise -> max_len (LookAhead xs' : xs) - LookAheadE consume xs' - | consume -> max_len (xs' ++ xs) - | otherwise -> max_len (LookAhead xs' : xs) - Try a b - | willFail' a && willFail' b -> max (max_len a) (max_len b) - | willFail' a -> max (max_len a) (max_len b) + max_len xs - | otherwise -> max_len (a ++ xs) - --- | The actual length of input that will be consumed when --- a decoder is executed, or Nothing if the decoder will fail. -actual_len :: Int -> [Action] -> Maybe Int -actual_len inp xs = - case eval inp xs of - ESuccess inp' -> Just (inp - inp') - _ -> Nothing - -actual_len' :: [Action] -> Maybe Int -actual_len' = actual_len maxBound - -randomInput :: Int -> Gen L.ByteString -randomInput 0 = return L.empty -randomInput n = do - m <- choose (1, min n 10) - s <- vectorOf m $ choose ('a', 'z') - let b = B.pack $ map (fromIntegral.ord) s - rest <- randomInput (n-m) - return (L.append (L.fromChunks [b]) rest) - --- | Build binary programs and compare running them to running a (hopefully) --- identical model. --- Tests that 'bytesRead' returns correct values when used together with '<|>' --- and 'fail'. -prop_action :: Property -prop_action = - forAllShrink (gen_actions False) shrink $ \ actions -> - let max_len_input = max_len actions in - forAll (randomInput max_len_input) $ \ lbs -> - let allInput = B.concat (L.toChunks lbs) in - case Binary.runGetOrFail 0 (execute allInput actions) lbs of - Right (_inp, _off, _x) -> True - Left (_inp, _off, _msg) -> True - --- | When a decoder aborts with 'fail', check that all relevant uses of 'label' --- are respected. -prop_label :: Property -prop_label = - forAllShrink (gen_actions True) shrink $ \ actions -> - let max_len_input = max_len actions in - forAll (randomInput max_len_input) $ \ lbs -> - let allInput = B.concat (L.toChunks lbs) in - collect (failReason $ eval max_len_input actions) $ - case Binary.runGetOrFail 0 (execute allInput actions) lbs of - Left (_, _, Left e) -> error $ "Internal error " ++ e - Left (_inp, _off, Right msg) -> - let lbls = case collectLabels max_len_input actions of - Just lbls' -> lbls' - Nothing -> error ("expected labels, got: " ++ msg) - expectedMsg = concat $ intersperse "\n" lbls - in expectedMsg === msg - Right (_inp, _off, _value) -> label "test case without 'fail'" $ True - --- | When a decoder aborts with 'fail', check the fail position and --- remaining input. -prop_fail :: Property -prop_fail = - forAllShrink (gen_actions True) shrink $ \ actions -> - let max_len_input = max_len actions in - forAll (randomInput max_len_input) $ \ lbs -> - let allInput = B.concat (L.toChunks lbs) in - collect (failReason $ eval max_len_input actions) $ - case Binary.runGetOrFail 0 (execute allInput actions) lbs of - Left (inp, off, _msg) -> - case () of - _ | Just off /= findFailPosition max_len_input actions -> - error ("fail position incorrect, expected " ++ - show (findFailPosition max_len_input actions) ++ - " but got " ++ show off) - | inp /= L.drop (fromIntegral off) lbs -> - error $ "remaining output incorrect, was: " ++ show inp ++ - ", should hav been: " ++ show (L.drop (fromIntegral off) lbs) - | otherwise -> property True - Right (_inp, _off, _value) -> label "test case without 'fail'" $ property True - --- | Collect all the labels up to a 'fail', or Nothing if the --- decoder will not fail. -collectLabels :: Int -> [Action] -> Maybe [String] -collectLabels inp xxs = - case eval inp xxs of - EFail _ lbls _ -> Just lbls - _ -> Nothing - --- | Finds at which byte offset the decoder will fail, --- or Nothing if it won't fail. -findFailPosition :: Int -> [Action] -> Maybe Binary.ByteOffset -findFailPosition inp xxs = - case eval inp xxs of - EFail _ _ inp' -> return (fromIntegral (inp-inp')) - _ -> Nothing - -failReason :: Eval -> String -failReason (EFail fr _ _) = show fr -failReason _ = "NoFail" - --- | The result of an evaluation. -data Eval = ESuccess Int - -- ^ The evalutation completed successfully. Contains the number of - -- remaining bytes of the input. - | EFail FailReason [String] Int - -- ^ The evaluation completed with a failure. Contains the labels up - -- to the failure, and the number of remaining bytes of the input. - deriving (Show,Eq) - -data FailReason - = FRFail - | FRIsolateTooMuch - | FRIsolateTooLittle - | FRTooMuch - deriving (Show,Eq) - --- | Given the number of input bytes and a list of actions, evaluate the --- actions and return whether the actions succeeed or fail. -eval :: Int -> [Action] -> Eval -eval inp0 = go inp0 [] - where - step :: Int -> Int -> [String] -> [Action] -> Eval - step inp n lbls xs - | inp - n < 0 = - let msg = "not enough bytes" - in EFail FRTooMuch (msg:lbls) inp - | otherwise = go (inp-n) lbls xs - go :: Int -> [String] -> [Action] -> Eval - go inp _lbls [] = ESuccess inp - go inp lbls (x:xs) = - case x of - Actions xs' -> go inp lbls (xs'++xs) - BytesRead -> go inp lbls xs - Fail -> EFail FRFail ("fail":lbls) inp - GetByteString n -> step inp n lbls xs - GetByteStringL n -> step inp n lbls xs - Skip n -> step inp n lbls xs - Isolate n xs' - | n > inp -> - case go inp lbls xs' of - ESuccess inp' -> - let msg = "isolate: the decoder consumed " ++ show (inp - inp') ++ - " bytes which is less than the expected " ++ (show n) ++ - " bytes" - in EFail FRTooMuch (msg:lbls) inp' - efail -> efail - | otherwise -> - case go n lbls xs' of - EFail fr lbls' inp' -> EFail fr lbls' (inp - n + inp') - ESuccess 0 -> go (inp-n) lbls xs - ESuccess inp' -> - let msg = "isolate: the decoder consumed " ++ show (n - inp') ++ - " bytes which is less than the expected " ++ (show n) ++ - " bytes" - in EFail FRIsolateTooLittle (msg:lbls) (inp - n + inp') - Label str xs' -> - case go inp (str:lbls) xs' of - EFail fr lbls' inp' -> EFail fr lbls' inp' - ESuccess inp' -> go inp' lbls xs - LookAhead xs' - | EFail fr lbls' inp' <- go inp lbls xs' -> EFail fr lbls' inp' - | otherwise -> go inp lbls xs - LookAheadM consume xs' - | consume -> go inp lbls (xs'++xs) - | otherwise -> go inp lbls (LookAhead xs' : xs) - LookAheadE consume xs' - | consume -> go inp lbls (xs'++xs) - | otherwise -> go inp lbls (LookAhead xs' : xs) - Try a b -> - case go inp lbls a of - ESuccess inp' -> go inp' lbls xs - EFail {} -> go inp lbls (b++xs) - -getLazyByteString :: Int64 -> Binary.Get String L.ByteString -getLazyByteString = (`Binary.withError` "not enough bytes") . Binary.getLazyByteString - -skip :: Int -> Binary.Get String () -skip = (`Binary.withError` "not enough bytes") . Binary.skip - -isolate :: Int -> Binary.Get String a -> Binary.Get String a -isolate n decoder = - Binary.isolate n decoder (msg n) - where - msg n0 consumed - = "isolate: the decoder consumed " ++ show consumed ++ " bytes" - ++ " which is less than the expected " ++ show n0 ++ " bytes" - -getByteString :: Int -> Binary.Get String B.ByteString -getByteString = (`Binary.withError` "not enough bytes") . Binary.getByteString - --- | Execute (run) the model. --- First argument is all the input that will be used when executing --- this decoder. It is used in this function to compare the expected --- value with the actual value from the decoder functions. --- The second argument is the model - the actions we will execute. -execute :: B.ByteString -> [Action] -> Binary.Get String () -execute inp acts0 = go 0 acts0 >> return () - where - inp_len = B.length inp - go _ [] = return () - go pos (x:xs) = - case x of - Actions a -> go pos (a++xs) - GetByteString n -> do - -- Run the operation in the Get monad... - actual <- getByteString n - let expected = B.take n . B.drop pos $ inp - -- ... and compare that we got what we expected. - when (actual /= expected) $ error $ - "execute(getByteString): actual /= expected at pos " ++ show pos ++ - ", got: " ++ show actual ++ ", expected: " ++ show expected - go (pos+n) xs - GetByteStringL n -> do - -- Run the operation in the Get monad... - actual <- L.toStrict <$> getLazyByteString (fromIntegral n) - let expected = B.take n . B.drop pos $ inp - -- ... and compare that we got what we expected. - when (actual /= expected) $ error $ - "execute(getLazyByteString): actual /= expected at pos " ++ show pos ++ - ", got: " ++ show actual ++ ", expected: " ++ show expected - go (pos+n) xs - Skip n -> do - skip n - go (pos+n) xs - BytesRead -> do - pos' <- Binary.bytesRead - if pos == fromIntegral pos' - then go pos xs - else error $ "execute(bytesRead): expected " ++ - show pos ++ " but got " ++ show pos' - Fail -> Binary.failG "fail" - Isolate n as -> do - let str = B.take n (B.drop pos inp) - _ <- isolate n (execute str as) - when (willFail (inp_len - pos) [Isolate n as]) $ - error "expected isolate to fail" - go (pos + n) xs - Label str as -> do - len <- Binary.label str (leg pos as) - go (pos+len) xs - LookAhead a -> do - _ <- Binary.lookAhead (go pos a) - go pos xs - LookAheadM b a -> do - let f True = Just <$> leg pos a - f False = go pos a >> return Nothing - len <- Binary.lookAheadM (f b) - case len of - Nothing -> go pos xs - Just offset -> go (pos+offset) xs - LookAheadE b a -> do - let f True = Right <$> leg pos a - f False = go pos a >> return (Left ()) - len <- Binary.lookAheadE (f b) - case len of - Left _ -> go pos xs - Right offset -> go (pos+offset) xs - Try a b -> do - offset <- leg pos a <|> leg pos b - go (pos+offset) xs - leg pos t = do - go pos t - case actual_len (inp_len - pos) t of - Nothing -> error "impossible: branch should have failed" - Just offset -> return offset - -gen_actions :: Bool -> Gen [Action] -gen_actions genFail = do - acts <- sized (go False) - return acts - where - go :: Bool -> Int -> Gen [Action] - go _ 0 = return [] - go inTry s = oneof $ [ do n <- choose (0,10) - (:) (GetByteString n) <$> go inTry (s-1) - , do n <- choose (0,10) - (:) (GetByteStringL n) <$> go inTry (s-1) - , do n <- choose (0,10) - (:) (Skip n) <$> go inTry (s-1) - , do (:) BytesRead <$> go inTry (s-1) - , do t1 <- go True (s `div` 2) - t2 <- go inTry (s `div` 2) - (:) (Try t1 t2) <$> go inTry (s `div` 2) - , do t <- go inTry (s`div`2) - (:) (LookAhead t) <$> go inTry (s-1) - , do t <- go inTry (s`div`2) - b <- arbitrary - (:) (LookAheadM b t) <$> go inTry (s-1) - , do t <- go inTry (s`div`2) - b <- arbitrary - (:) (LookAheadE b t) <$> go inTry (s-1) - , do t <- go inTry (s`div`2) - Positive n <- arbitrary :: Gen (Positive Int) - (:) (Label ("some label: " ++ show n) t) <$> go inTry (s-1) - , do t <- resize (s`div`2) (gen_isolate (genFail || inTry)) - (:) t <$> go inTry (s-1) - ] ++ [frequency [(if inTry || genFail then 1 else 0, return [Fail]) - ,(9 , go inTry s)]] - -gen_isolate :: Bool -> Gen Action -gen_isolate genFail = gen_actions genFail >>= go - where - go t0 = do - -- We can isolate the decoder with three different ranges; - -- * give too few bytes -> isolate will fail - -- * give exactly right amount of bytes -> isolate - -- will succeed if the given decoder succeeds - -- * give too many bytes -> isolate will fail - -- Here we generate Isolates that belong to the different - -- buckets. - let t = t0 - tooFewBytes n = do - n' <- choose (0, n) - return (n',t) - requiredBytes n = return (n,t) - tooManyBytes n = do - n' <- choose (n+1, n+10) - return (n+n',t) - let trees - | Just n <- actual_len' t = oneof $ - [ requiredBytes n ] ++ - [ tooFewBytes n | genFail ] ++ - [ tooManyBytes n | genFail ] - | otherwise = return (max_len t, t) - (n,t') <- trees - return (Isolate n t') diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs deleted file mode 100644 --- a/tests/Arbitrary.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Arbitrary where - -import Test.QuickCheck - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -#if MIN_VERSION_bytestring(0,10,4) -import qualified Data.ByteString.Short as S -#endif - -instance Arbitrary L.ByteString where - arbitrary = fmap L.fromChunks arbitrary - -instance Arbitrary B.ByteString where - arbitrary = B.pack `fmap` arbitrary - -#if MIN_VERSION_bytestring(0,10,4) -instance Arbitrary S.ShortByteString where - arbitrary = S.toShort `fmap` arbitrary -#endif diff --git a/tests/File.hs b/tests/File.hs deleted file mode 100644 --- a/tests/File.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -module Main where - -#if ! MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -import System.Directory (getTemporaryDirectory) -import System.FilePath (()) -import Test.HUnit - -import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity (silent) - -import Data.Binary - -data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show) - -instance Binary Foo where - get = Bar <$> get <*> get <*> get - put (Bar a b c) = put (a,b,c) - -exampleData :: [Foo] -exampleData = make bytes - where - make (a:b:c:xs) = Bar a b c : make xs - make _ = [] - bytes = take (256*1024) (cycle [minBound..maxBound]) - -readWriteTest :: Test -readWriteTest = TestCase $ do - tmpDir <- getTemporaryDirectory - withTempDirectory silent tmpDir "foo-dir" $ \dir -> do - let fn = dir "foo.bin" - encodeFile fn exampleData - content <- decodeFile fn - -- It'd be nice to use lsof to verify that 'fn' isn't still open. - exampleData @=? content - -main :: IO () -main = do - _ <- runTestTT readWriteTest - return () diff --git a/tests/QC.hs b/tests/QC.hs deleted file mode 100644 --- a/tests/QC.hs +++ /dev/null @@ -1,782 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} -module Main ( main ) where - -#if MIN_VERSION_base(4,8,0) -#define HAS_NATURAL -#endif - -#if MIN_VERSION_base(4,7,0) -#define HAS_FIXED_CONSTRUCTOR -#endif - -import Control.Applicative -import Control.Exception as C (SomeException, - catch, evaluate) -import Control.Monad (unless, liftM2) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L -#if MIN_VERSION_bytestring(0,10,4) -import Data.ByteString.Short (ShortByteString) -#endif -import Data.Int -import Data.Ratio -import Data.Typeable -import System.IO.Unsafe - -#ifdef HAS_NATURAL -import Numeric.Natural -#endif - -import GHC.Fingerprint - -import qualified Data.Fixed as Fixed - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck - -import qualified Action (tests) -import Arbitrary () - -import Data.Binary hiding (Get, get, getWord8) -import Data.Binary.Get.Ext hiding - ( getLazyByteString, getLazyByteStringNul, getWord8 - , getWord16le, getWord16be, getWord16host - , getWord32le, getWord32be, getWord32host - , getWord64le, getWord64be, getWord64host - , getWordhost, getByteString - , getInt8 - , getInt16be, getInt16le, getInt16host - , getInt32be, getInt32le, getInt32host - , getInt64be, getInt64le, getInt64host - , getInthost - ) -import qualified Data.Binary.Get.Ext as Binary - ( getLazyByteString, getLazyByteStringNul, getWord8 - , getWord16le, getWord16be, getWord16host - , getWord32le, getWord32be, getWord32host - , getWord64le, getWord64be, getWord64host - , getWordhost, getByteString - , getInt8 - , getInt16be, getInt16le, getInt16host - , getInt32be, getInt32le, getInt32host - , getInt64be, getInt64le, getInt64host - , getInthost - ) -import Data.Binary.Put - ------------------------------------------------------------------------- - -roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool -roundTrip a f = a == - {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) - -runGet :: Get String a -> L.ByteString -> a -runGet decoder inp = - case runGetOrFail 0 decoder inp of - Right (_, _, a) -> a - Left (_, pos, msg) -> error $ "Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ show msg - -withStringError :: Get () a -> Get String a -withStringError = (`withError` "not enough bytes") - -getByteString :: Int -> Get String B.ByteString -getByteString = withStringError . Binary.getByteString - -getWord8 :: Get String Word8 -getWord8 = withStringError Binary.getWord8 - -getWord16be :: Get String Word16 -getWord16be = withStringError Binary.getWord16be - -getWord16le :: Get String Word16 -getWord16le = withStringError Binary.getWord16le - -getWord16host :: Get String Word16 -getWord16host = withStringError Binary.getWord16host - -getWord32be :: Get String Word32 -getWord32be = withStringError Binary.getWord32be - -getWord32le :: Get String Word32 -getWord32le = withStringError Binary.getWord32le - -getWord32host :: Get String Word32 -getWord32host = withStringError Binary.getWord32host - -getWord64be :: Get String Word64 -getWord64be = withStringError Binary.getWord64be - -getWord64le :: Get String Word64 -getWord64le = withStringError Binary.getWord64le - -getWord64host :: Get String Word64 -getWord64host = withStringError Binary.getWord64host - -getWordhost :: Get String Word -getWordhost = withStringError Binary.getWordhost - -getInt8 :: Get String Int8 -getInt8 = withStringError Binary.getInt8 - -getInt16be :: Get String Int16 -getInt16be = withStringError Binary.getInt16be - -getInt16le :: Get String Int16 -getInt16le = withStringError Binary.getInt16le - -getInt16host :: Get String Int16 -getInt16host = withStringError Binary.getInt16host - -getInt32be :: Get String Int32 -getInt32be = withStringError Binary.getInt32be - -getInt32le :: Get String Int32 -getInt32le = withStringError Binary.getInt32le - -getInt32host :: Get String Int32 -getInt32host = withStringError Binary.getInt32host - -getInt64be :: Get String Int64 -getInt64be = withStringError Binary.getInt64be - -getInt64le :: Get String Int64 -getInt64le = withStringError Binary.getInt64le - -getInt64host :: Get String Int64 -getInt64host = withStringError Binary.getInt64host - -getInthost :: Get String Int -getInthost = withStringError Binary.getInthost - -roundTripWith :: Eq a => (a -> Put) -> Get String a -> a -> Property -roundTripWith putter getter x = - forAll positiveList $ \xs -> - x == runGet getter (refragment xs (runPut (putter x))) - --- make sure that a test fails -mustThrowError :: B a -mustThrowError a = unsafePerformIO $ - C.catch (do _ <- C.evaluate a - return False) - (\(_e :: SomeException) -> return True) - --- low level ones: --- --- Words - -prop_Word8 :: Word8 -> Property -prop_Word8 = roundTripWith putWord8 getWord8 - -prop_Word16be :: Word16 -> Property -prop_Word16be = roundTripWith putWord16be getWord16be - -prop_Word16le :: Word16 -> Property -prop_Word16le = roundTripWith putWord16le getWord16le - -prop_Word16host :: Word16 -> Property -prop_Word16host = roundTripWith putWord16host getWord16host - -prop_Word32be :: Word32 -> Property -prop_Word32be = roundTripWith putWord32be getWord32be - -prop_Word32le :: Word32 -> Property -prop_Word32le = roundTripWith putWord32le getWord32le - -prop_Word32host :: Word32 -> Property -prop_Word32host = roundTripWith putWord32host getWord32host - -prop_Word64be :: Word64 -> Property -prop_Word64be = roundTripWith putWord64be getWord64be - -prop_Word64le :: Word64 -> Property -prop_Word64le = roundTripWith putWord64le getWord64le - -prop_Word64host :: Word64 -> Property -prop_Word64host = roundTripWith putWord64host getWord64host - -prop_Wordhost :: Word -> Property -prop_Wordhost = roundTripWith putWordhost getWordhost - --- Ints - -prop_Int8 :: Int8 -> Property -prop_Int8 = roundTripWith putInt8 getInt8 - -prop_Int16be :: Int16 -> Property -prop_Int16be = roundTripWith putInt16be getInt16be - -prop_Int16le :: Int16 -> Property -prop_Int16le = roundTripWith putInt16le getInt16le - -prop_Int16host :: Int16 -> Property -prop_Int16host = roundTripWith putInt16host getInt16host - -prop_Int32be :: Int32 -> Property -prop_Int32be = roundTripWith putInt32be getInt32be - -prop_Int32le :: Int32 -> Property -prop_Int32le = roundTripWith putInt32le getInt32le - -prop_Int32host :: Int32 -> Property -prop_Int32host = roundTripWith putInt32host getInt32host - -prop_Int64be :: Int64 -> Property -prop_Int64be = roundTripWith putInt64be getInt64be - -prop_Int64le :: Int64 -> Property -prop_Int64le = roundTripWith putInt64le getInt64le - -prop_Int64host :: Int64 -> Property -prop_Int64host = roundTripWith putInt64host getInt64host - -prop_Inthost :: Int -> Property -prop_Inthost = roundTripWith putInthost getInthost - -{- --- Floats and Doubles - -prop_Floatbe :: Float -> Property -prop_Floatbe = roundTripWith putFloatbe getFloatbe - -prop_Floatle :: Float -> Property -prop_Floatle = roundTripWith putFloatle getFloatle - -prop_Floathost :: Float -> Property -prop_Floathost = roundTripWith putFloathost getFloathost - -prop_Doublebe :: Double -> Property -prop_Doublebe = roundTripWith putDoublebe getDoublebe - -prop_Doublele :: Double -> Property -prop_Doublele = roundTripWith putDoublele getDoublele - -prop_Doublehost :: Double -> Property -prop_Doublehost = roundTripWith putDoublehost getDoublehost --} - -#if MIN_VERSION_base(4,10,0) -testTypeable :: Test -testTypeable = testProperty "TypeRep" prop_TypeRep - -prop_TypeRep :: TypeRep -> Property -prop_TypeRep = roundTripWith Class.put Class.get - -atomicTypeReps :: [TypeRep] -atomicTypeReps = - [ typeRep (Proxy :: Proxy ()) - , typeRep (Proxy :: Proxy String) - , typeRep (Proxy :: Proxy Int) - , typeRep (Proxy :: Proxy (,)) - , typeRep (Proxy :: Proxy ((,) (Maybe Int))) - , typeRep (Proxy :: Proxy Maybe) - , typeRep (Proxy :: Proxy 'Nothing) - , typeRep (Proxy :: Proxy 'Left) - , typeRep (Proxy :: Proxy "Hello") - , typeRep (Proxy :: Proxy 42) - , typeRep (Proxy :: Proxy '[1,2,3,4]) - , typeRep (Proxy :: Proxy ('Left Int)) - , typeRep (Proxy :: Proxy (Either Int String)) - , typeRep (Proxy :: Proxy (() -> ())) - ] - -instance Arbitrary TypeRep where - arbitrary = oneof (map pure atomicTypeReps) -#else -testTypeable :: Test -testTypeable = testGroup "Skipping Typeable tests" [] -#endif - --- done, partial and fail - --- | Test partial results. --- May or may not use the whole input, check conditions for the different --- outcomes. -prop_partial :: L.ByteString -> Property -prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN -> - let result = pushChunks (runGetIncremental 0 decoder) lbs - decoder = do - s <- getByteString (fromIntegral skipN) - return (L.fromChunks [s]) - in case result of - Partial _ -> L.length lbs < skipN - Done unused _pos value -> - and [ L.length value == skipN - , L.append value (L.fromChunks [unused]) == lbs - ] - Fail _ _ _ -> False - --- | Fail a decoder and make sure the result is sane. -prop_fail :: L.ByteString -> String -> Property -prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos -> - let result = pushChunks (runGetIncremental 0 decoder) lbs - decoder = do - -- use part of the input... - _ <- getByteString (fromIntegral pos) - -- ... then fail - failG msg - in case result of - Fail unused pos' msg' -> - and [ pos == pos' - , Right msg == msg' - , L.length lbs - pos == fromIntegral (B.length unused) - , L.fromChunks [unused] `L.isSuffixOf` lbs - ] - _ -> False -- wuut? - --- read negative length -prop_getByteString_negative :: Int -> Property -prop_getByteString_negative n = - n < 1 ==> - runGet (getByteString n) L.empty == B.empty - - -prop_bytesRead :: L.ByteString -> Property -prop_bytesRead lbs = - forAll (makeChunks 0 totalLength) $ \chunkSizes -> - let result = pushChunks (runGetIncremental 0 decoder) lbs - decoder = do - -- Read some data and invoke bytesRead several times. - -- Each time, check that the values are what we expect. - flip mapM_ chunkSizes $ \(total, step) -> do - _ <- getByteString (fromIntegral step) - n <- bytesRead - unless (n == total) $ fail "unexpected position" - bytesRead - in case result of - Done unused pos value -> - and [ value == totalLength - , pos == value - , B.null unused - ] - Partial _ -> False - Fail _ _ _ -> False - where - totalLength = L.length lbs - makeChunks total i - | i == 0 = return [] - | otherwise = do - n <- choose (0,i) - let total' = total + n - rest <- makeChunks total' (i - n) - return ((total',n):rest) - - --- | We're trying to guarantee that the Decoder will not ask for more input --- with Partial if it has been given Nothing once. --- In this test we're making the decoder return 'Partial' to get more --- input, and to get knownledge of the current position using 'BytesRead'. --- Both of these operations, when used with the <|> operator, result internally --- in that the decoder return with Partial and BytesRead multiple times, --- in which case we need to keep track of if the user has passed Nothing to a --- Partial in the past. -prop_partialOnlyOnce :: Property -prop_partialOnlyOnce = property $ - let result = runGetIncremental 0 (decoder <|> decoder) - decoder = do - 0 <- bytesRead - _ <- getWord8 -- this will make the decoder return with Partial - return "shouldn't get here" - in case result of - -- we expect Partial followed by Fail - Partial k -> case k Nothing of -- push down a Nothing - Fail _ _ _ -> True - Partial _ -> error $ "partial twice! oh noes!" - Done _ _ _ -> error $ "we're not supposed to be done." - _ -> error $ "not partial, error!" - --- read too much -prop_readTooMuch :: (Eq a, Binary a) => a -> Bool -prop_readTooMuch x = mustThrowError $ x == a && x /= b - where - -- encode 'a', but try to read 'b' too - (a,b) = decode (encode x) - _types = [a,b] - --- In binary-0.5 the Get monad looked like --- --- > data S = S {-# UNPACK #-} !B.ByteString --- > L.ByteString --- > {-# UNPACK #-} !Int64 --- > --- > newtype Get a = Get { unGet :: S -> (# a, S #) } --- --- with a helper function --- --- > mkState :: L.ByteString -> Int64 -> S --- > mkState l = case l of --- > L.Empty -> S B.empty L.empty --- > L.Chunk x xs -> S x xs --- --- Note that mkState is strict in its first argument. This goes wrong in this --- function: --- --- > getBytes :: Int -> Get B.ByteString --- > getBytes n = do --- > S s ss bytes <- traceNumBytes n $ get --- > if n <= B.length s --- > then do let (consume,rest) = B.splitAt n s --- > put $! S rest ss (bytes + fromIntegral n) --- > return $! consume --- > else --- > case L.splitAt (fromIntegral n) (s `join` ss) of --- > (consuming, rest) -> --- > do let now = B.concat . L.toChunks $ consuming --- > put $ mkState rest (bytes + fromIntegral n) --- > -- forces the next chunk before this one is returned --- > if (B.length now < n) --- > then --- > fail "too few bytes" --- > else --- > return now --- --- Consider the else-branch of this function; suppose we ask for n bytes; --- the call to L.splitAt gives us a lazy bytestring 'consuming' of precisely @n@ --- bytes (unless we don't have enough data, in which case we fail); but then --- the strict evaluation of mkState on 'rest' means we look ahead too far. --- --- Although this is all done completely differently in binary-0.7 it is --- important that the same bug does not get introduced in some other way. The --- test is basically the same test that already exists in this test suite, --- verifying that --- --- > decode . refragment . encode == id --- --- However, we use a different 'refragment', one that introduces an exception --- as the tail of the bytestring after rechunking. If we don't look ahead too --- far then this should make no difference, but if we do then this will throw --- an exception (for instance, in binary-0.5, this will throw an exception for --- certain rechunkings, but not for others). --- --- To make sure that the property holds no matter what refragmentation we use, --- we test exhaustively for a single chunk, and all ways to break the string --- into 2, 3 and 4 chunks. -prop_lookAheadIndepOfChunking :: (Eq a, Binary a) => a -> Property -prop_lookAheadIndepOfChunking testInput = - forAll (testCuts (L.length (encode testInput))) $ - roundTrip testInput . rechunk - where - testCuts :: forall a. (Num a, Enum a) => a -> Gen [a] - testCuts len = elements $ [ [] ] - ++ [ [i] - | i <- [0 .. len] ] - ++ [ [i, j] - | i <- [0 .. len] - , j <- [0 .. len - i] ] - ++ [ [i, j, k] - | i <- [0 .. len] - , j <- [0 .. len - i] - , k <- [0 .. len - i - j] ] - - -- Rechunk a bytestring, leaving the tail as an exception rather than Empty - rechunk :: forall a. Integral a => [a] -> L.ByteString -> L.ByteString - rechunk cuts = fromChunks . cut cuts . B.concat . L.toChunks - where - cut :: [a] -> B.ByteString -> [B.ByteString] - cut [] bs = [bs] - cut (i:is) bs = let (bs0, bs1) = B.splitAt (fromIntegral i) bs - in bs0 : cut is bs1 - - fromChunks :: [B.ByteString] -> L.ByteString - fromChunks [] = error "Binary should not have to ask for this chunk!" - fromChunks (bs:bss) = L.Chunk bs (fromChunks bss) - --- String utilities - -getLazyByteString :: Int64 -> Get String L.ByteString -getLazyByteString = (`withError` "not enough bytes") . Binary.getLazyByteString - -getLazyByteStringNul :: Get String L.ByteString -getLazyByteStringNul = Binary.getLazyByteStringNul `withError` "not enough bytes" - -prop_getLazyByteString :: L.ByteString -> Property -prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len -> - let result = pushChunks (runGetIncremental 0 decoder) lbs - decoder = getLazyByteString len - in case result of - Done unused _pos value -> - and [ value == L.take len lbs - , L.fromChunks [unused] == L.drop len lbs - ] - Partial _ -> len > L.length lbs - _ -> False - -prop_getLazyByteStringNul :: Word16 -> [Int] -> Property -prop_getLazyByteStringNul count0 fragments = count >= 0 ==> - forAll (choose (0, count)) $ \pos -> - let lbs = case L.splitAt pos (L.replicate count 65) of - (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end] - result = pushEndOfInput $ pushChunks (runGetIncremental 0 getLazyByteStringNul) lbs - in case result of - Done unused pos' value -> - and [ value == L.take pos lbs - , pos + 1 == pos' -- 1 for the NUL - , L.fromChunks [unused] == L.drop (pos + 1) lbs - ] - _ -> False - where - count = fromIntegral count0 -- to make the generated numbers a bit smaller - --- | Same as prop_getLazyByteStringNul, but without any NULL in the string. -prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property -prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==> - let lbs = refragment fragments $ L.replicate count 65 - result = pushEndOfInput $ pushChunks (runGetIncremental 0 getLazyByteStringNul) lbs - in case result of - Fail _ _ _ -> True - _ -> False - where - count = fromIntegral count0 -- to make the generated numbers a bit smaller - -prop_getRemainingLazyByteString :: L.ByteString -> Property -prop_getRemainingLazyByteString lbs = property $ - let result = pushEndOfInput $ pushChunks (runGetIncremental 0 getRemainingLazyByteString) lbs - in case result of - Done unused pos value -> - and [ value == lbs - , B.null unused - , fromIntegral pos == L.length lbs - ] - _ -> False - --- sanity: - -invariant_lbs :: L.ByteString -> Bool -invariant_lbs (L.Empty) = True -invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs - -prop_invariant :: (Binary a) => a -> Bool -prop_invariant = invariant_lbs . encode - --- refragment a lazy bytestring's chunks -refragment :: [Int] -> L.ByteString -> L.ByteString -refragment [] lbs = lbs -refragment (x:xs) lbs = - let x' = fromIntegral . (+1) . abs $ x - rest = refragment xs (L.drop x' lbs) in - L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest - --- check identity of refragmentation -prop_refragment :: L.ByteString -> [Int] -> Bool -prop_refragment lbs xs = lbs == refragment xs lbs - --- check that refragmention still hold invariant -prop_refragment_inv :: L.ByteString -> [Int] -> Bool -prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs - -main :: IO () -main = defaultMain tests - ------------------------------------------------------------------------- - -genInteger :: Gen Integer -genInteger = do - b <- arbitrary - if b then genIntegerSmall else genIntegerSmall - -genIntegerSmall :: Gen Integer -genIntegerSmall = arbitrary - -genIntegerBig :: Gen Integer -genIntegerBig = do - x <- arbitrarySizedIntegral :: Gen Integer - -- arbitrarySizedIntegral generates numbers smaller than - -- (maxBound :: Word32), so let's make them bigger to better test - -- the Binary instance. - return (x + fromIntegral (maxBound :: Word32)) - -#ifdef HAS_NATURAL -genNatural :: Gen Natural -genNatural = do - b <- arbitrary - if b then genNaturalSmall else genNaturalBig - -genNaturalSmall :: Gen Natural -genNaturalSmall = arbitrarySizedNatural - -genNaturalBig :: Gen Natural -genNaturalBig = do - x <- arbitrarySizedNatural :: Gen Natural - -- arbitrarySizedNatural generates numbers smaller than - -- (maxBound :: Word64), so let's make them bigger to better test - -- the Binary instance. - return (x + fromIntegral (maxBound :: Word64)) -#endif - ------------------------------------------------------------------------- - -#if !MIN_VERSION_base(4,7,0) -instance Show Fingerprint where - show (Fingerprint x1 x2) = show (x1,x2) -#endif - -type T a = a -> Property -type B a = a -> Bool - -p :: (Testable p) => p -> Property -p = property - -test :: (Eq a, Binary a) => a -> Property -test a = forAll positiveList (roundTrip a . refragment) - -test' :: (Show a, Arbitrary a) => String -> (a -> Property) -> ([a] -> Property) -> Test -test' desc prop propList = - testGroup desc [ - testProperty desc prop, - testProperty ("[" ++ desc ++ "]") propList - ] - -testWithGen :: (Show a, Eq a, Binary a) => String -> Gen a -> Test -testWithGen desc gen = - testGroup desc [ - testProperty desc (forAll gen test), - testProperty ("[" ++ desc ++ "]") (forAll (listOf gen) test) - ] - -positiveList :: Gen [Int] -positiveList = fmap (filter (/=0) . map abs) $ arbitrary - -tests :: [Test] -tests = - [ testGroup "Utils" - [ testProperty "refragment id" (p prop_refragment) - , testProperty "refragment invariant" (p prop_refragment_inv) - ] - - , testGroup "Boundaries" - [ testProperty "read to much" (p (prop_readTooMuch :: B Word8)) - , testProperty "read negative length" (p (prop_getByteString_negative :: T Int)) - , -- Arbitrary test input - let testInput :: [Int] ; testInput = [0 .. 10] - in testProperty "look-ahead independent of chunking" (p (prop_lookAheadIndepOfChunking testInput)) - ] - - , testGroup "Partial" - [ testProperty "partial" (p prop_partial) - , testProperty "fail" (p prop_fail) - , testProperty "bytesRead" (p prop_bytesRead) - , testProperty "partial only once" (p prop_partialOnlyOnce) - ] - - , testGroup "Model" - Action.tests - - , testGroup "Primitives" - [ testProperty "Word8" (p prop_Word8) - , testProperty "Word16be" (p prop_Word16be) - , testProperty "Word16le" (p prop_Word16le) - , testProperty "Word16host" (p prop_Word16host) - , testProperty "Word32be" (p prop_Word32be) - , testProperty "Word32le" (p prop_Word32le) - , testProperty "Word32host" (p prop_Word32host) - , testProperty "Word64be" (p prop_Word64be) - , testProperty "Word64le" (p prop_Word64le) - , testProperty "Word64host" (p prop_Word64host) - , testProperty "Wordhost" (p prop_Wordhost) - -- Int - , testProperty "Int8" (p prop_Int8) - , testProperty "Int16be" (p prop_Int16be) - , testProperty "Int16le" (p prop_Int16le) - , testProperty "Int16host" (p prop_Int16host) - , testProperty "Int32be" (p prop_Int32be) - , testProperty "Int32le" (p prop_Int32le) - , testProperty "Int32host" (p prop_Int32host) - , testProperty "Int64be" (p prop_Int64be) - , testProperty "Int64le" (p prop_Int64le) - , testProperty "Int64host" (p prop_Int64host) - , testProperty "Inthost" (p prop_Inthost) -{- - -- Float/Double - , testProperty "Floatbe" (p prop_Floatbe) - , testProperty "Floatle" (p prop_Floatle) - , testProperty "Floathost" (p prop_Floathost) - , testProperty "Doublebe" (p prop_Doublebe) - , testProperty "Doublele" (p prop_Doublele) - , testProperty "Doublehost" (p prop_Doublehost) --} - ] - - , testGroup "String utils" - [ testProperty "getLazyByteString" prop_getLazyByteString - , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul - , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul - , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString - ] - - , testGroup "Using Binary class, refragmented ByteString" - [ test' "()" (test :: T () ) test - , test' "Bool" (test :: T Bool ) test - , test' "Char" (test :: T Char ) test - , test' "Ordering" (test :: T Ordering ) test - , test' "Ratio Int" (test :: T (Ratio Int)) test - - , test' "Word" (test :: T Word ) test - , test' "Word8" (test :: T Word8 ) test - , test' "Word16" (test :: T Word16) test - , test' "Word32" (test :: T Word32) test - , test' "Word64" (test :: T Word64) test - - , test' "Int" (test :: T Int ) test - , test' "Int8" (test :: T Int8 ) test - , test' "Int16" (test :: T Int16) test - , test' "Int32" (test :: T Int32) test - , test' "Int64" (test :: T Int64) test - - , testWithGen "Integer mixed" genInteger - , testWithGen "Integer small" genIntegerSmall - , testWithGen "Integer big" genIntegerBig - -#ifdef HAS_NATURAL - , testWithGen "Natural mixed" genNatural - , testWithGen "Natural small" genNaturalSmall - , testWithGen "Natural big" genNaturalBig -#endif - - , test' "Float" (test :: T Float ) test - , test' "Double" (test :: T Double) test - - , test' "((), ())" (test :: T ((), ()) ) test - , test' "(Word8, Word32)" (test :: T (Word8, Word32) ) test - , test' "(Int8, Int32)" (test :: T (Int8, Int32) ) test - , test' "(Int32, [Int])" (test :: T (Int32, [Int]) ) test - , test' "Maybe Int8" (test :: T (Maybe Int8) ) test - , test' "Either Int8 Int16" (test :: T (Either Int8 Int16) ) test - - , test' "(Int, ByteString)" - (test :: T (Int, B.ByteString) ) test - , test' "[(Int, ByteString)]" - (test :: T [(Int, B.ByteString)] ) test - - , test' "(Maybe Int64, Bool, [Int])" - (test :: T (Maybe Int64, Bool, [Int])) test - , test' "(Maybe Word8, Bool, [Int], Either Bool Word8)" - (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8)) test - , test' "(Maybe Word16, Bool, [Int], Either Bool Word16, Int)" - (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int)) test - -{- - , test' "(Int,Int,Int,Int,Int,Int)" - (test :: T (Int,Int,Int,Int,Int,Int)) test - , test' "(Int,Int,Int,Int,Int,Int,Int)" - (test :: T (Int,Int,Int,Int,Int,Int,Int)) test - , test' "(Int,Int,Int,Int,Int,Int,Int,Int)" - (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)) test - , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int)" - (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)) test - , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)" - (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) test --} - - , test' "B.ByteString" (test :: T B.ByteString) test - , test' "L.ByteString" (test :: T L.ByteString) test - ] - - , testGroup "Invariants" $ map (uncurry testProperty) - [ ("B.ByteString invariant", p (prop_invariant :: B B.ByteString )) - , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] )) - , ("L.ByteString invariant", p (prop_invariant :: B L.ByteString )) - , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) - ] - , testTypeable - ]