binary-ext 1.0.8.5.1 → 2.0
raw patch · 29 files changed
+2866/−2421 lines, 29 filesdep +attoparsecdep +binary-extdep +conduitdep −Cabaldep −QuickCheckdep −arraydep ~basedep ~bytestringsetup-changed
Dependencies added: attoparsec, binary-ext, conduit, conduit-combinators, data-binary-ieee754, errors, exceptions, monad-control, monad-loops, mono-traversable, mtl, scientific, text, transformers, transformers-base
Dependencies removed: Cabal, QuickCheck, array, containers, directory, filepath, ghc-prim, random, test-framework, test-framework-quickcheck2
Dependency ranges changed: base, bytestring
Files
- LICENSE +195/−25
- README.md +0/−26
- Setup.hs +2/−0
- Setup.lhs +0/−3
- binary-ext.cabal +98/−82
- src/Control/Monad/Error/Map.hs +180/−0
- src/Data/Binary/FloatCast.hs +0/−45
- src/Data/Binary/Get/Ext.hs +0/−524
- src/Data/Binary/Get/Ext/Internal.hs +0/−428
- src/Data/Binary/Internal.hs +0/−15
- src/Data/Conduit/Parsers.hs +123/−0
- src/Data/Conduit/Parsers/Binary.hs +32/−0
- src/Data/Conduit/Parsers/Binary/ByteOffset.hs +57/−0
- src/Data/Conduit/Parsers/Binary/Get.hs +356/−0
- src/Data/Conduit/Parsers/Binary/Put.hs +271/−0
- src/Data/Conduit/Parsers/GetC.hs +449/−0
- src/Data/Conduit/Parsers/PutS.hs +102/−0
- src/Data/Conduit/Parsers/Text.hs +46/−0
- src/Data/Conduit/Parsers/Text/Gen.hs +92/−0
- src/Data/Conduit/Parsers/Text/Parser.hs +323/−0
- src/Data/Conduit/Parsers/Text/TextOffset.hs +59/−0
- test/Data/Conduit/Parsers/Binary/Get/Spec.hs +316/−0
- test/Data/Conduit/Parsers/Binary/Put/Spec.hs +64/−0
- test/Data/Conduit/Parsers/Text/Parser/Spec.hs +69/−0
- test/Spec.hs +32/−0
- tests/Action.hs +0/−425
- tests/Arbitrary.hs +0/−23
- tests/File.hs +0/−43
- tests/QC.hs +0/−782
LICENSE view
@@ -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.
− README.md
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
binary-ext.cabal view
@@ -1,88 +1,104 @@-name: binary-ext-version: 1.0.8.5.1-license: BSD3-license-file: LICENSE-author: Warlock <internalmike@gmail.com>-maintainer: Warlock <internalmike@gmail.com>-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 <internalmike@gmail.com>+maintainer: Warlock <internalmike@gmail.com>+copyright: 2017 Warlock <internalmike@gmail.com>+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
+ src/Control/Monad/Error/Map.hs view
@@ -0,0 +1,180 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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'' #-}
− src/Data/Binary/FloatCast.hs
@@ -1,45 +0,0 @@--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}---- | This module was written based on--- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.------ Implements casting via a 1-elemnt STUArray, as described in--- <http://stackoverflow.com/a/7002812/263061>.-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 #-}
− src/Data/Binary/Get/Ext.hs
@@ -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
− src/Data/Binary/Get/Ext/Internal.hs
@@ -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 #-}
− src/Data/Binary/Internal.hs
@@ -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
+ src/Data/Conduit/Parsers.hs view
@@ -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 #-}
+ src/Data/Conduit/Parsers/Binary.hs view
@@ -0,0 +1,32 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Binary/ByteOffset.hs view
@@ -0,0 +1,57 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Binary/Get.hs view
@@ -0,0 +1,356 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Binary/Put.hs view
@@ -0,0 +1,271 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/GetC.hs view
@@ -0,0 +1,449 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/PutS.hs view
@@ -0,0 +1,102 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Text.hs view
@@ -0,0 +1,46 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Text/Gen.hs view
@@ -0,0 +1,92 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Text/Parser.hs view
@@ -0,0 +1,323 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ src/Data/Conduit/Parsers/Text/TextOffset.hs view
@@ -0,0 +1,59 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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 #-}
+ test/Data/Conduit/Parsers/Binary/Get/Spec.hs view
@@ -0,0 +1,316 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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
+ test/Data/Conduit/Parsers/Binary/Put/Spec.hs view
@@ -0,0 +1,64 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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
+ test/Data/Conduit/Parsers/Text/Parser/Spec.hs view
@@ -0,0 +1,69 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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"+ , ""+ ]
+ test/Spec.hs view
@@ -0,0 +1,32 @@+--+-- Copyright 2017 Warlock <internalmike@gmail.com>+--+-- 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+ ]
− tests/Action.hs
@@ -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')
− tests/Arbitrary.hs
@@ -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
− tests/File.hs
@@ -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 ()
− tests/QC.hs
@@ -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- ]