construct (empty) → 0.1
raw patch · 17 files changed
+1886/−0 lines, 17 filesdep +attoparsecdep +basedep +bytestringbuild-type:Customsetup-changedbinary-added
Dependencies added: attoparsec, base, bytestring, cereal, construct, directory, doctest, filepath, incremental-parser, monoid-subclasses, parsers, rank2classes, tasty, tasty-hunit, text
Files
- CHANGELOG.md +5/−0
- LICENSE +26/−0
- README.md +113/−0
- Setup.hs +6/−0
- construct.cabal +67/−0
- src/Construct.hs +452/−0
- src/Construct/Bits.hs +73/−0
- src/Construct/Classes.hs +283/−0
- src/Construct/Internal.hs +16/−0
- test/Doctest.hs +6/−0
- test/MBR.hs +91/−0
- test/README.lhs +113/−0
- test/TAR.hs +157/−0
- test/Test.hs +70/−0
- test/URI.hs +152/−0
- test/WMF.hs +256/−0
- test/examples/wmf1.wmf binary
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for construct++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2016, Mario Blažević+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,113 @@+Construct.hs+============++This is a Haskell implementation of Python's [Construct](https://construct.readthedocs.io/en/latest/intro.html)+library. It provides a succinct and easy way to specify data formats. Before you get to the succinct part, though,+you'll probably need a bunch of extensions and imports:++~~~ {.haskell}+{-# LANGUAGE FlexibleInstances, StandaloneDeriving, TemplateHaskell #-}++module README where++import Data.Functor.Identity (Identity(Identity))+import Data.Word (Word8)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ASCII+import qualified Rank2.TH+import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser, completeResults, feed, feedEof)+import Construct++import Prelude hiding ((*>), (<*))+~~~++Example+-------++With that out of the way, let's take the simple example format from the original. Here's what its specification looks+like in Haskell:++~~~ {.haskell}+data BitMap f = BitMap{+ width :: f Word8,+ height :: f Word8,+ pixels :: f [[Word8]]+ }+deriving instance Show (BitMap Identity)+$(Rank2.TH.deriveAll ''BitMap)++format :: Format (Parser ByteString) Maybe ByteString (BitMap Identity)+format = literal (ASCII.pack "BMP") *> mfix (\this-> record+ BitMap{+ width= byte,+ height= byte,+ pixels= count (fromIntegral $ height this) (count (fromIntegral $ width this) byte)+ })+~~~++There are two parts to the specification.++The `data BitMap` declaration specifies the in-memory layout of a simple bitmap. Note that it's declared as a record+with every field wrapped in a type constructor parameter. This declaration style is sometimes called [Higher-Kinded+Data](https://reasonablypolymorphic.com/blog/higher-kinded-data/). To regain a regular record, just instantiate the+parameter to `Identity` — a `BitMap Identity` contains exactly one value of each field.++The other part of the specification is the `format` definition that specifies the bi-directional mapping between the+in-memory and the serialized form of the bitmap. A bijection, to be precise. The two definitions are enough to automatically+serialize the in-memory record form into the binary form:++~~~ {.haskell}+-- | >>> serialize format BitMap{width= Identity 3, height= Identity 2, pixels= Identity [[7,8,9], [11,12,13]]}+-- Just "BMP\ETX\STX\a\b\t\v\f\r"+~~~++and to parse the serialized binary form back into the record structure:++~~~ {.haskell}+-- | >>> completeResults $ feedEof $ feed (ASCII.pack "BMP" <> ByteString.pack [3, 2, 7, 8, 9, 11, 12, 13]) $ parse format+-- [(BitMap {width = Identity 3, height = Identity 2, pixels = Identity [[7,8,9],[11,12,13]]},"")]+~~~++Examples of more complex and realistic formats can be found in the+[`test`](https://github.com/blamario/construct/tree/master/test) directory.++Acknowledgements+----------------++I owe the inspiration for this library to Yair Chuchem and his+[post](https://yairchu.github.io/posts/codecs-as-prisms.html) that introduced me to Construct. I must also express+gratitude to the authors of the original library of course. And finally, to the authors of the paper [Invertible+Syntax Descriptions:Unifying Parsing and Pretty+Printing](https://www.informatik.uni-marburg.de/~rendel/unparse/rendel10invertible.pdf) which I remembered reading+just in time to avoid following some bad ideas.++Implementation notes+--------------------++I had to overcome two problems in the course of the implementation. The first difficulty, already touched on in the+aforementioned blog post, is how to convert a record of formats into a format of the record. As the author of+[rank2classes](https://hackage.haskell.org/package/rank2classes), I went for an obvious solution: parameterize the+record as seen in the example, make it an instance of the+[`Rank2.Traversable`](https://hackage.haskell.org/package/rank2classes-1.3.1.2/docs/Rank2.html#t:Traversable) class,+and apply [`Rank2.traverse`](https://hackage.haskell.org/package/rank2classes-1.3.1.2/docs/Rank2.html#v:traverse) to+it.++That little trick alone would have been enough for a nearly complete package, except the Python library also enables a+record field to refer to any of the preceding fields. This is not a problem when serializing, but when parsing it+means that a parser must be able to refer to an already-parsed part of the value that's still being parsed.++The standard solution to the problem of accessing the results (parsed values) of a computation (parsing) *while within+the computation* is known as the+[`MonadFix`](https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad-Fix.html#t:MonadFix) class, though+perhaps not as widely as it deserves. You won't find any parsers in the list of its instances, though, and for a good+reason - it's quite impossible for a parser to obtain a value that it hasn't parsed yet. All *we* need, luckily, is+access an already parsed part of a partially parsed structure. A limited `MonadFix` instance can do that, provided+that we also use a specialized form of `Rank2.traverse` capable of preserving the record structure while it's being+parsed.++As it happens, I have an old parser library named+[incremental-parser](https://hackage.haskell.org/package/incremental-parser) on Hackage, and the name seems quite+appropriate for what I'm doing here. I added the necessary functionality there, but another parser combinator library+should be capable of the same feat. It just needs to implement the `mfix` and `fixSequence` combinators and it can be+used with the present library.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctests"
+ construct.cabal view
@@ -0,0 +1,67 @@+cabal-version: >=1.10+name: construct+version: 0.1+synopsis: Haskell version of the Construct library for easy specification of file formats+description:+ A Haskell version of the <https://construct.readthedocs.io/en/latest/intro.html Construct> library for Python. A+ succinct file format specification provides both a parser and the serializer for the format.+bug-reports: https://github.com/blamario/construct/issues+license: BSD3+license-file: LICENSE+author: Mario Blažević+maintainer: Mario Blažević <blamario@protonmail.com>+copyright: Mario Blažević 2020+category: Data, Parsing, Serialization+build-type: Custom+extra-source-files: CHANGELOG.md, README.md, test/README.lhs+data-dir: test/examples/+data-files: wmf1.wmf+custom-setup+ setup-depends:+ base >= 4 && <5,+ Cabal,+ cabal-doctest >= 1 && <1.1+ ++library+ -- other-extensions:+ hs-source-dirs: src+ exposed-modules: Construct, Construct.Bits, Construct.Classes+ other-modules: Construct.Internal+ build-depends: base >=4.11 && <4.13,+ bytestring >= 0.10 && < 0.11,+ text >= 0.10 && < 1.3,+ monoid-subclasses >= 1.0 && < 1.1,+ incremental-parser >= 0.4 && < 0.5,+ parsers >= 0.11 && < 0.13,+ attoparsec >= 0.12 && < 0.14,+ cereal >= 0.5 && < 0.6,+ rank2classes >= 1 && < 1.4+ default-language: Haskell2010+ ghc-options: -Wall++test-suite doctests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ main-is: Doctest.hs+ other-modules: README+ ghc-options: -threaded -pgmL markdown-unlit+ build-depends: base, construct,+ bytestring >= 0.10 && < 0.11, incremental-parser >= 0.4 && < 0.5, rank2classes >= 1.0.2 && < 1.4,+ doctest >= 0.8+ build-tool-depends: markdown-unlit:markdown-unlit >= 0.5 && < 0.6+ x-doctest-options: -XTypeApplications++test-suite examples+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ x-uses-tf: true+ build-depends: base >=4.9 && < 5, construct,+ bytestring < 0.11, text < 1.3, cereal, rank2classes >= 1.0.2 && < 1.4,+ monoid-subclasses >= 1.0 && < 1.1, incremental-parser < 0.5, attoparsec >= 0.12 && < 0.14,+ directory < 2, filepath < 1.5,+ tasty >= 0.7, tasty-hunit+ main-is: Test.hs+ other-modules: MBR, TAR, URI, WMF+ default-language: Haskell2010
+ src/Construct.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}++module Construct+(+ -- * The type+ Format, parse, serialize,++ -- * Combinators+ (Construct.<$), (Construct.*>), (Construct.<*), (Construct.<|>), (<+>), (<?>),+ empty, optional, optionWithDefault, pair, deppair, many, some, sepBy, count,+ -- ** Self-referential record support+ mfix, record,+ -- ** Mapping over a 'Format'+ mapSerialized, mapMaybeSerialized, mapValue, mapMaybeValue,+ -- ** Constraining a 'Format'+ satisfy, value, padded, padded1,++ -- * Primitives+ literal, byte, char,+ cereal, cereal',+ Construct.take, Construct.takeWhile, Construct.takeWhile1, Construct.takeCharsWhile, Construct.takeCharsWhile1,+ -- * Test helpers+ testParse, testSerialize+) where++import qualified Control.Applicative as Applicative+import qualified Control.Monad.Fix as Monad.Fix+import Control.Applicative (Applicative, Alternative)+import Control.Monad.Fix (MonadFix)+import Data.Functor ((<$>), void)+import qualified Data.Functor.Const as Functor+import qualified Data.List as List+import Data.List.NonEmpty (nonEmpty)+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup, (<>), sconcat)+import Data.Word (Word8)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual+import qualified Data.Monoid.Null as Null+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import Data.String (IsString, fromString)+import qualified Text.Parser.Combinators as Parser+import qualified Text.Parser.Char as Parser.Char+import qualified Text.ParserCombinators.Incremental as Incremental+import Text.ParserCombinators.Incremental.Symmetric (Symmetric)+import Data.Serialize (Serialize, Result(Done, Fail, Partial), Get, Putter, runGetPartial, runPut)+import qualified Data.Serialize as Serialize++import qualified Rank2++import qualified Construct.Classes as Input+import Construct.Classes (AlternativeFail(failure), InputParsing (ParserInput), InputCharParsing, InputMappableParsing,+ FixTraversable, Error, errorString, expectedName)+import Construct.Internal++import Prelude hiding (pred, take, takeWhile)++-- $setup+-- >>> import Data.Char (isDigit, isLetter)+-- >>> import Data.Serialize.Get (getWord16le)+-- >>> import Data.Serialize.Put (putWord16le)+-- >>> import Data.Word (Word16)+-- >>> import Numeric (showInt)++literal :: (Functor m, InputParsing m, Applicative n, ParserInput m ~ s) => s -> Format m n s ()+-- | A literal serialized form, such as a magic constant, corresponding to no value+--+-- >>> testParse (literal "Hi") "Hi there"+-- Right [(()," there")]+literal s = Format{+ parse = void (Input.string s),+ serialize = const (pure s)+ }++-- | Modifies the serialized form of the given format by padding it with the given template if it's any shorter+--+-- >>> testParse (padded "----" $ takeCharsWhile isDigit) "12--3---"+-- Right [("12","3---")]+-- >>> testSerialize (padded "----" $ takeCharsWhile isDigit) "12"+-- Right "12--"+padded :: (Monad m, Functor n, InputParsing m, ParserInput m ~ s, FactorialMonoid s) =>+ s -> Format m n s s -> Format m n s s+padded template format = Format{+ parse = parse format >>= parsePadding,+ serialize = (padRight <$>) . serialize format+ }+ where padRight s = s <> Factorial.drop (Factorial.length s) template+ parsePadding s = if Null.null padding then pure s else s Applicative.<$ Input.string padding+ where padding = Factorial.drop (Factorial.length s) template++-- | Modifies the serialized form of the given format by padding it with the given template. The serialized form has+-- to be shorter than the template before padding.+padded1 :: (Monad m, Monad n, InputParsing m, ParserInput m ~ s, FactorialMonoid s, Show s, AlternativeFail n) =>+ s -> Format m n s s -> Format m n s s+padded1 template format = Format{+ parse = parse format >>= parsePadding,+ serialize = \a-> serialize format a >>= padRight+ }+ where padRight s = if Null.null padding then expectedName ("padded1 " ++ show template) (failure $ show s)+ else pure (s <> padding)+ where padding = Factorial.drop (Factorial.length s) template+ parsePadding s = if Null.null padding+ then Parser.unexpected (show s) Parser.<?> ("padded1 " ++ show template)+ else s Applicative.<$ Input.string padding+ where padding = Factorial.drop (Factorial.length s) template++-- | Format whose in-memory value is a fixed-size prefix of the serialized value+--+-- >>> testParse (take 3) "12345"+-- Right [("123","45")]+-- >>> testSerialize (take 3) "123"+-- Right "123"+-- >>> testSerialize (take 3) "1234"+-- Left "expected a value of length 3, encountered \"1234\""+take :: (InputParsing m, ParserInput m ~ s, FactorialMonoid s, Show s, AlternativeFail n) => Int -> Format m n s s+take n = Format{+ parse = Input.take n,+ serialize = \s-> if Factorial.length s == n then pure s+ else expectedName ("a value of length " ++ show n) (failure $ show s)+ }++-- | Format whose in-memory value is the longest prefix of the serialized value smallest parts of which all satisfy+-- the given predicate.+--+-- >>> testParse (takeWhile (> "b")) "abcd"+-- Right [("","abcd")]+-- >>> testParse (takeWhile (> "b")) "dcba"+-- Right [("dc","ba")]+-- >>> testSerialize (takeWhile (> "b")) "dcba"+-- Left "expected takeWhile, encountered \"dcba\""+-- >>> testSerialize (takeWhile (> "b")) "dc"+-- Right "dc"+-- >>> testSerialize (takeWhile (> "b")) ""+-- Right ""+takeWhile :: (InputParsing m, ParserInput m ~ s, FactorialMonoid s, Show s, AlternativeFail n) =>+ (s -> Bool) -> Format m n s s+takeWhile pred = Format{+ parse = Input.takeWhile pred,+ serialize = \s-> if Null.null (Factorial.dropWhile pred s) then pure s+ else expectedName "takeWhile" (failure $ show s)+ }++-- | Format whose in-memory value is the longest non-empty prefix of the serialized value smallest parts of which all+-- satisfy the given predicate.+--+-- >>> testParse (takeWhile1 (> "b")) "abcd"+-- Left "takeWhile1"+-- >>> testSerialize (takeWhile1 (> "b")) ""+-- Left "expected takeWhile1, encountered \"\""+-- >>> testSerialize (takeWhile1 (> "b")) "dc"+-- Right "dc"+takeWhile1 :: (InputParsing m, ParserInput m ~ s, FactorialMonoid s, Show s, AlternativeFail n) =>+ (s -> Bool) -> Format m n s s+takeWhile1 pred = Format{+ parse = Input.takeWhile1 pred,+ serialize = \s-> if not (Null.null s) && Null.null (Factorial.dropWhile pred s) then pure s+ else expectedName "takeWhile1" (failure $ show s)+ }++-- | Format whose in-memory value is the longest prefix of the serialized value that consists of characters which all+-- satisfy the given predicate.+--+-- >>> testParse (takeCharsWhile isDigit) "a12"+-- Right [("","a12")]+-- >>> testParse (takeCharsWhile isDigit) "12a"+-- Right [("12","a")]+-- >>> testSerialize (takeCharsWhile isDigit) "12a"+-- Left "expected takeCharsWhile, encountered \"12a\""+-- >>> testSerialize (takeCharsWhile isDigit) "12"+-- Right "12"+-- >>> testSerialize (takeCharsWhile isDigit) ""+-- Right ""+takeCharsWhile :: (InputCharParsing m, ParserInput m ~ s, TextualMonoid s, Show s, AlternativeFail n) =>+ (Char -> Bool) -> Format m n s s+takeCharsWhile pred = Format{+ parse = Input.takeCharsWhile pred,+ serialize = \s-> if Null.null (Textual.dropWhile_ False pred s) then pure s+ else expectedName "takeCharsWhile" (failure $ show s)+ }++-- | Format whose in-memory value is the longest non-empty prefix of the serialized value that consists of characters+-- which all satisfy the given predicate.+--+-- >>> testParse (takeCharsWhile1 isDigit) "a12"+-- Left "takeCharsWhile1 encountered 'a'"+-- >>> testParse (takeCharsWhile1 isDigit) "12a"+-- Right [("12","a")]+-- >>> testSerialize (takeCharsWhile1 isDigit) "12"+-- Right "12"+-- >>> testSerialize (takeCharsWhile1 isDigit) ""+-- Left "expected takeCharsWhile1, encountered \"\""+takeCharsWhile1 :: (InputCharParsing m, ParserInput m ~ s, TextualMonoid s, Show s, AlternativeFail n) =>+ (Char -> Bool) -> Format m n s s+takeCharsWhile1 pred = Format{+ parse = Input.takeCharsWhile1 pred,+ serialize = \s-> if not (Null.null s) && Null.null (Textual.dropWhile_ False pred s) then pure s+ else expectedName "takeCharsWhile1" (failure $ show s)+ }++value :: (Eq a, Show a, Parser.Parsing m, Monad m, Alternative n) => Format m n s a -> a -> Format m n s ()+-- | A fixed expected value serialized through the argument format+--+-- >>> testParse (value char 'a') "bcd"+-- Left "encountered 'b'"+-- >>> testParse (value char 'a') "abc"+-- Right [((),"bc")]+value f v = Format{+ parse = void (parse f >>= \x-> if x == v then pure x else Parser.unexpected (show x)),+ serialize = \()-> serialize f v+ }++satisfy :: (Parser.Parsing m, Monad m, AlternativeFail n, Show a) => (a -> Bool) -> Format m n s a -> Format m n s a+-- | Filter the argument format so it only succeeds for values that pass the predicate.+--+-- >>> testParse (satisfy isDigit char) "abc"+-- Left "encountered 'a'"+-- >>> testParse (satisfy isLetter char) "abc"+-- Right [('a',"bc")]+satisfy predicate f = Format{+ parse = parse f >>= \v-> if predicate v then pure v else Parser.unexpected (show v),+ serialize = \v-> if predicate v then serialize f v else expectedName "satisfy" (failure $ show v)+ }++-- | Converts a format for serialized streams of type @s@ so it works for streams of type @t@ instead+--+-- >>> testParse (mapSerialized ByteString.unpack ByteString.pack byte) [1,2,3]+-- Right [(1,[2,3])]+mapSerialized :: (Monoid s, Monoid t, InputParsing (m s), InputParsing (m t),+ s ~ ParserInput (m s), t ~ ParserInput (m t), InputMappableParsing m, Functor n) =>+ (s -> t) -> (t -> s) -> Format (m s) n s a -> Format (m t) n t a+mapSerialized f f' format = Format{+ parse = Input.mapParserInput f f' (parse format),+ serialize = (f <$>) . serialize format}++-- | Converts a format for serialized streams of type @s@ so it works for streams of type @t@ instead. The argument+-- functions may return @Nothing@ to indicate they have insuficient input to perform the conversion.+mapMaybeSerialized :: (Monoid s, Monoid t, InputParsing (m s), InputParsing (m t),+ s ~ ParserInput (m s), t ~ ParserInput (m t), InputMappableParsing m, Functor n) =>+ (s -> Maybe t) -> (t -> Maybe s) -> Format (m s) n s a -> Format (m t) n t a+mapMaybeSerialized f f' format = Format{+ parse = Input.mapMaybeParserInput f f' (parse format),+ serialize = (fromMaybe (error "Partial serialization") . f <$>) . serialize format}++-- | Converts a format for in-memory values of type @a@ so it works for values of type @b@ instead.+--+-- >>> testParse (mapValue (read @Int) show $ takeCharsWhile1 isDigit) "012 34"+-- Right [(12," 34")]+-- >>> testSerialize (mapValue read show $ takeCharsWhile1 isDigit) 12+-- Right "12"+mapValue :: Functor m => (a -> b) -> (b -> a) -> Format m n s a -> Format m n s b+mapValue f f' format = Format{+ parse = f <$> parse format,+ serialize = serialize format . f'}++-- | Converts a format for in-memory values of type @a@ so it works for values of type @b@ instead. The argument+-- functions may signal conversion failure by returning @Nothing@.+mapMaybeValue :: (Monad m, Parser.Parsing m, Show a, Show b, AlternativeFail n) =>+ (a -> Maybe b) -> (b -> Maybe a) -> Format m n s a -> Format m n s b+mapMaybeValue f f' format = Format{+ parse = parse format >>= \v-> maybe (Parser.unexpected $ show v) pure (f v),+ serialize = \v-> maybe (expectedName "mapMaybeValue" (failure $ show v)) (serialize format) (f' v)}++byte :: (InputParsing m, ParserInput m ~ ByteString, Applicative n) => Format m n ByteString Word8+-- | A trivial format for a single byte in a 'ByteString'+--+-- >>> testParse byte (ByteString.pack [1,2,3])+-- Right [(1,"\STX\ETX")]+byte = Format{+ parse = ByteString.head <$> Input.anyToken,+ serialize = pure . ByteString.singleton}++char :: (Parser.Char.CharParsing m, ParserInput m ~ s, IsString s, Applicative n) => Format m n s Char+-- | A trivial format for a single character+--+-- >>> testParse char "abc"+-- Right [('a',"bc")]+char = Format{+ parse = Parser.Char.anyChar,+ serialize = pure . fromString . (:[])}++cereal :: (Serialize a, Monad m, InputParsing m, ParserInput m ~ ByteString, Applicative n) => Format m n ByteString a+-- | A quick way to format a value that already has an appropriate 'Serialize' instance+--+-- >>> testParse (cereal @Word16) (ByteString.pack [1,2,3])+-- Right [(258,"\ETX")]+-- >>> testSerialize cereal (1025 :: Word16)+-- Right "\EOT\SOH"+cereal = cereal' Serialize.get Serialize.put++cereal' :: (Monad m, InputParsing m, ParserInput m ~ ByteString, Applicative n) =>+ Get a -> Putter a -> Format m n ByteString a+-- | Specifying a formatter explicitly using the cereal getter and putter+--+-- >>> testParse (cereal' getWord16le putWord16le) (ByteString.pack [1,2,3])+-- Right [(513,"\ETX")]+cereal' get put = Format p (pure . runPut . put)+ where p = go (runGetPartial get mempty)+ where go (Fail msg _) = fail msg+ go (Done r _) = pure r+ go (Partial cont) = Input.anyToken >>= go . cont++count :: (Applicative m, AlternativeFail n, Show a, Monoid s) => Int -> Format m n s a -> Format m n s [a]+-- | Repeats the argument format the given number of times.+--+-- >>> testParse (count 4 byte) (ByteString.pack [1,2,3,4,5])+-- Right [([1,2,3,4],"\ENQ")]+-- >>> testSerialize (count 4 byte) [1,2,3,4,5]+-- Left "expected a list of length 4, encountered [1,2,3,4,5]"+-- >>> testSerialize (count 4 byte) [1,2,3,4]+-- Right "\SOH\STX\ETX\EOT"+count n item = Format{+ parse = Parser.count (fromIntegral n) (parse item),+ serialize = \as-> if length as == n then mconcat <$> traverse (serialize item) as+ else expectedName ("a list of length " ++ show n) (failure $ show as)}++record :: (Rank2.Apply g, Rank2.Traversable g, FixTraversable m, Monoid (n s), Applicative o, Foldable o) =>+ g (Format m n s) -> Format m n s (g o)+-- | Converts a record of field formats into a single format of the whole record.+record formats = Format{+ parse = Input.fixSequence (parse Rank2.<$> formats),+ serialize = Rank2.foldMap Functor.getConst . Rank2.liftA2 serializeField formats+ }+ where serializeField format xs = Functor.Const (foldMap (serialize format) xs)++infixl 3 <|>+infixl 4 <$+infixl 4 <*+infixl 4 *>++(<$) :: (Eq a, Show a, Functor m, AlternativeFail n) => a -> Format m n s () -> Format m n s a+-- | Same as the usual 'Data.Functor.<$' except a 'Format' is no 'Functor'.+a <$ f = Format{+ parse = a Applicative.<$ parse f,+ serialize = \b-> if a == b then serialize f () else expectedName (show a) (failure $ show b)}++(*>) :: (Applicative m, Semigroup (n s)) => Format m n s () -> Format m n s a -> Format m n s a+-- | Same as the usual 'Applicative.*>' except a 'Format' is no 'Functor', let alone 'Applicative'.+f1 *> f2 = Format{+ parse = parse f1 Applicative.*> parse f2,+ serialize = \a-> serialize f1 () <> serialize f2 a}++(<*) :: (Applicative m, Semigroup (n s)) => Format m n s a -> Format m n s () -> Format m n s a+-- | Same as the usual 'Applicative.<*' except a 'Format' is no 'Functor', let alone 'Applicative'.+f1 <* f2 = Format{+ parse = parse f1 Applicative.<* parse f2,+ serialize = \a-> serialize f1 a <> serialize f2 ()}++(<|>) :: (Alternative m, Alternative n) => Format m n s a -> Format m n s a -> Format m n s a+-- | Same as the usual 'Applicative.<|>' except a 'Format' is no 'Functor', let alone 'Alternative'.+f1 <|> f2 = Format{+ parse = parse f1 Applicative.<|> parse f2,+ serialize = \a-> serialize f1 a Applicative.<|> serialize f2 a}++(<+>) :: Alternative m => Format m n s a -> Format m n s b -> Format m n s (Either a b)+-- | A discriminated or tagged choice between two formats.+f1 <+> f2 = Format{+ parse = Left <$> parse f1 Applicative.<|> Right <$> parse f2,+ serialize = either (serialize f1) (serialize f2)}++optional :: (Alternative m, Alternative n, Monoid (n s)) => Format m n s a -> Format m n s (Maybe a)+-- | Same as the usual 'Applicative.optional' except a 'Format' is no 'Functor', let alone 'Alternative'.+optional f = Format{+ parse = Applicative.optional (parse f),+ serialize = maybe mempty (serialize f)}++-- | Like 'optional' except with arbitrary default serialization for the @Nothing@ value.+--+-- > optional = optionWithDefault (literal mempty)+optionWithDefault :: (Alternative m, Alternative n, Monoid (n s)) =>+ Format m n s () -> Format m n s a -> Format m n s (Maybe a)+optionWithDefault d f = Format{+ parse = Just <$> parse f Applicative.<|> Nothing Applicative.<$ parse d,+ serialize = maybe (serialize d ()) (serialize f)}++many :: (Alternative m, Monoid (n s)) => Format m n s a -> Format m n s [a]+-- | Same as the usual 'Applicative.many' except a 'Format' is no 'Functor', let alone 'Alternative'.+many f = Format{+ parse = Applicative.many (parse f),+ serialize = foldMap (serialize f)}++some :: (Alternative m, AlternativeFail n, Semigroup (n s)) => Format m n s a -> Format m n s [a]+-- | Same as the usual 'Applicative.some' except a 'Format' is no 'Functor', let alone 'Alternative'.+some f = Format{+ parse = Applicative.some (parse f),+ serialize = maybe (failure "[]") sconcat . nonEmpty . map (serialize f)}++sepBy :: (Alternative m, Applicative n, Monoid s) => Format m n s a -> Format m n s () -> Format m n s [a]+-- | Represents any number of values formatted using the first argument, separated by the second format argumewnt in+-- serialized form. Similar to the usual 'Parser.sepBy' combinator.+--+-- >>> testParse (takeCharsWhile isLetter `sepBy` literal ",") "foo,bar,baz"+-- Right [([],"foo,bar,baz"),(["foo"],",bar,baz"),(["foo","bar"],",baz"),(["foo","bar","baz"],"")]+sepBy format separator = Format{+ parse = Parser.sepBy (parse format) (parse separator),+ serialize = \xs-> mconcat <$> sequenceA (List.intersperse (serialize separator ()) $ serialize format <$> xs)}++pair :: (Applicative m, Semigroup (n s)) => Format m n s a -> Format m n s b -> Format m n s (a, b)+-- | Combines two formats into a format for the pair of their values.+--+-- >>> testParse (pair char char) "abc"+-- Right [(('a','b'),"c")]+pair f g = Format{+ parse = (,) <$> parse f <*> parse g,+ serialize = \(a, b)-> serialize f a <> serialize g b}++deppair :: (Monad m, Semigroup (n s)) => Format m n s a -> (a -> Format m n s b) -> Format m n s (a, b)+-- | Combines two formats, where the second format depends on the first value, into a format for the pair of their+-- values. Similar to '>>=' except 'Format' is no 'Functor' let alone 'Monad'.+--+-- >>> testParse (deppair char (\c-> satisfy (==c) char)) "abc"+-- Left "encountered 'b'"+-- >>> testParse (deppair char (\c-> satisfy (==c) char)) "aac"+-- Right [(('a','a'),"c")]+deppair f g = Format{+ parse = parse f >>= \a-> parse (g a) >>= \b-> return (a, b),+ serialize = \(a, b)-> serialize f a <> serialize (g a) b}++empty :: (Alternative m, Alternative n) => Format m n s a+-- | Same as the usual 'Applicative.empty' except a 'Format' is no 'Functor', let alone 'Alternative'.+empty = Format{+ parse = Applicative.empty,+ serialize = const Applicative.empty}++infixr 0 <?>+(<?>) :: (Parser.Parsing m, AlternativeFail n) => Format m n s a -> String -> Format m n s a+-- | Name a format to improve error messages.+--+-- >>> testParse (takeCharsWhile1 isDigit <?> "a number") "abc"+-- Left "expected a number, encountered 'a'"+-- >>> testSerialize (takeCharsWhile1 isDigit <?> "a number") "abc"+-- Left "expected a number, encountered \"abc\""+f <?> name = Format{+ parse = parse f Parser.<?> name,+ serialize = expectedName name . serialize f}++mfix :: MonadFix m => (a -> Format m n s a) -> Format m n s a+-- | Same as the usual 'Control.Monad.Fix.mfix' except a 'Format' is no 'Functor', let alone 'Monad'.+mfix f = Format{+ parse = Monad.Fix.mfix (parse . f),+ serialize = \a-> serialize (f a) a}++-- | Attempts to 'parse' the given input with the format with a constrained type, returns either a failure message or+-- a list of successes.+testParse :: Monoid s => Format (Incremental.Parser Symmetric s) (Either Error) s a -> s -> Either String [(a, s)]+testParse format input = fst <$> Incremental.inspect (Incremental.feedEof $ Incremental.feed input $ parse format)++-- | A less polymorphic wrapper around 'serialize' useful for testing+testSerialize :: Format (Incremental.Parser Symmetric s) (Either Error) s a -> a -> Either String s+testSerialize format = either (Left . errorString) Right . serialize format
+ src/Construct/Bits.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE GADTs #-}++-- | This module exports the primitives and combinators for constructing formats with sub- or cross-byte+-- components. See @test/MBR.hs@ for an example of its use.+--+-- >>> testParse (bigEndianBytesOf $ pair (count 5 bit) (count 3 bit)) (ByteString.pack [9])+-- Right [(([False,False,False,False,True],[False,False,True]),"")]++module Construct.Bits+ (Bits, bit,+ -- * The combinators for converting between 'Bits' and 'ByteString' input streams+ bigEndianBitsOf, bigEndianBytesOf, littleEndianBitsOf, littleEndianBytesOf) where++import Data.Bits (setBit, testBit)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.List as List+import Data.Word (Word8)++import Construct+import Construct.Classes+import Construct.Internal++-- | The list of bits+type Bits = [Bool]++bit :: (Applicative n, InputParsing m, ParserInput m ~ Bits) => Format m n Bits Bool+bigEndianBitsOf :: (InputParsing (m Bits), InputParsing (m ByteString), InputMappableParsing m, Functor n,+ ParserInput (m Bits) ~ Bits, ParserInput (m ByteString) ~ ByteString) =>+ Format (m ByteString) n ByteString a -> Format (m Bits) n Bits a+bigEndianBytesOf :: (InputParsing (m Bits), InputParsing (m ByteString), InputMappableParsing m, Functor n,+ ParserInput (m Bits) ~ Bits, ParserInput (m ByteString) ~ ByteString) =>+ Format (m Bits) n Bits a -> Format (m ByteString) n ByteString a+littleEndianBitsOf :: (InputParsing (m Bits), InputParsing (m ByteString), InputMappableParsing m, Functor n,+ ParserInput (m Bits) ~ Bits, ParserInput (m ByteString) ~ ByteString) =>+ Format (m ByteString) n ByteString a -> Format (m Bits) n Bits a+littleEndianBytesOf :: (InputParsing (m Bits), InputParsing (m ByteString), InputMappableParsing m, Functor n,+ ParserInput (m Bits) ~ Bits, ParserInput (m ByteString) ~ ByteString) =>+ Format (m Bits) n Bits a -> Format (m ByteString) n ByteString a++-- | The primitive format of a single bit+--+-- >>> testParse bit [True, False, False, True]+-- Right [(True,[False,False,True])]+bit = Format{+ parse = head <$> anyToken,+ serialize = pure . (:[])}++bigEndianBitsOf = mapMaybeSerialized (Just . enumerateFromMostSignificant) collectFromMostSignificant+bigEndianBytesOf = mapMaybeSerialized collectFromMostSignificant (Just . enumerateFromMostSignificant)+littleEndianBitsOf = mapMaybeSerialized (Just . enumerateFromLeastSignificant) collectFromLeastSignificant+littleEndianBytesOf = mapMaybeSerialized collectFromLeastSignificant (Just . enumerateFromLeastSignificant)++collectFromMostSignificant :: Bits -> Maybe ByteString+collectFromLeastSignificant :: Bits -> Maybe ByteString+enumerateFromMostSignificant :: ByteString -> Bits+enumerateFromLeastSignificant :: ByteString -> Bits++collectFromMostSignificant bits = (ByteString.pack . map toByte) <$> splitEach8 bits+ where toByte octet = List.foldl' setBit (0 :: Word8) (map snd $ filter fst $ zip octet [7,6..0])+collectFromLeastSignificant bits = (ByteString.pack . map toByte) <$> splitEach8 bits+ where toByte octet = List.foldl' setBit (0 :: Word8) (map snd $ filter fst $ zip octet [0..7])+enumerateFromMostSignificant = ByteString.foldr ((++) . enumerateByte) []+ where enumerateByte b = [testBit b i | i <- [7,6..0]]+enumerateFromLeastSignificant = ByteString.foldr ((++) . enumerateByte) []+ where enumerateByte b = [testBit b i | i <- [0..7]]++splitEach8 :: [a] -> Maybe [[a]]+splitEach8 [] = Just []+splitEach8 list+ | length first8 == 8 = (first8 :) <$> splitEach8 rest+ | otherwise = Nothing+ where (first8, rest) = splitAt 8 list
+ src/Construct/Classes.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances, TypeFamilies,+ TypeSynonymInstances, UndecidableInstances #-}++-- | The only good reason to import this module is if you intend to add another instance of the classes it exports.++module Construct.Classes where++import qualified Rank2+import qualified Text.ParserCombinators.Incremental as Incremental++import Control.Applicative (Alternative ((<|>), empty))+import Control.Monad (void)+import Data.String (IsString (fromString))+import Text.ParserCombinators.ReadP (ReadP)+import qualified Text.ParserCombinators.ReadP as ReadP++import Text.Parser.Char (CharParsing)+import Text.Parser.Combinators (count, eof, notFollowedBy, try, unexpected)+import Text.Parser.LookAhead (LookAheadParsing, lookAhead)+import qualified Text.Parser.Char as Char++import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Null as Null+import qualified Data.Monoid.Textual as Textual+import qualified Data.Semigroup.Cancellative as Cancellative+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import Data.Semigroup.Cancellative (LeftReductive)++import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ByteString.Char8+import qualified Data.Text as Text++import qualified Data.Attoparsec.ByteString as Attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec.Char8+import qualified Data.Attoparsec.Text as Attoparsec.Text++import Prelude hiding (take, takeWhile)++-- | Subclass of 'Alternative' that carries an error message in case of failure+class Alternative m => AlternativeFail m where+ -- | Equivalent to 'empty' except it takes an error message it may carry or drop on the floor. The grammatical form+ -- of the argument be a noun representing the unexpected value.+ failure :: String -> m a+ -- | Sets or modifies the expected value.+ expectedName :: String -> m a -> m a++ failure = const empty+ expectedName = const id++-- | Methods for parsing factorial monoid inputs+class LookAheadParsing m => InputParsing m where+ type ParserInput m+ -- | Always sucessful parser that returns the remaining input without consuming it.+ getInput :: m (ParserInput m)++ -- | A parser that accepts any single atomic prefix of the input stream.+ -- > anyToken == satisfy (const True)+ -- > anyToken == take 1+ anyToken :: m (ParserInput m)+ -- | A parser that accepts exactly the given number of input atoms.+ take :: Int -> m (ParserInput m)+ -- | A parser that accepts an input atom only if it satisfies the given predicate.+ satisfy :: (ParserInput m -> Bool) -> m (ParserInput m)+ -- | A parser that succeeds exactly when satisfy doesn't, equivalent to+ -- 'Text.Parser.Combinators.notFollowedBy' @. satisfy@+ notSatisfy :: (ParserInput m -> Bool) -> m ()++ -- | A stateful scanner. The predicate modifies a state argument, and each transformed state is passed to successive+ -- invocations of the predicate on each token of the input until one returns 'Nothing' or the input ends.+ --+ -- This parser does not fail. It will return an empty string if the predicate returns 'Nothing' on the first+ -- character.+ --+ -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers+ -- loop until a failure occurs. Careless use will thus result in an infinite loop.+ scan :: state -> (state -> ParserInput m -> Maybe state) -> m (ParserInput m)+ -- | A parser that consumes and returns the given prefix of the input.+ string :: ParserInput m -> m (ParserInput m)++ -- | A parser accepting the longest sequence of input atoms that match the given predicate; an optimized version of+ -- 'concatMany . satisfy'.+ --+ -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers+ -- loop until a failure occurs. Careless use will thus result in an infinite loop.+ takeWhile :: (ParserInput m -> Bool) -> m (ParserInput m)+ -- | A parser accepting the longest non-empty sequence of input atoms that match the given predicate; an optimized+ -- version of 'concatSome . satisfy'.+ takeWhile1 :: (ParserInput m -> Bool) -> m (ParserInput m)+ -- | Zero or more argument occurrences like 'many', with concatenated monoidal results.+ concatMany :: Monoid a => m a -> m a++ anyToken = take 1+ notSatisfy predicate = try (void $ satisfy $ not . predicate) <|> eof+ default concatMany :: (Monoid a, Alternative m) => m a -> m a+ concatMany p = go+ where go = mappend <$> try p <*> go <|> pure mempty++ default string :: (Monad m, LeftReductive (ParserInput m), FactorialMonoid (ParserInput m), Show (ParserInput m))+ => ParserInput m -> m (ParserInput m)+ string s = do i <- getInput+ if s `Cancellative.isPrefixOf` i+ then take (Factorial.length s)+ else unexpected ("string " <> show s)+ default scan :: (Monad m, FactorialMonoid (ParserInput m)) =>+ state -> (state -> ParserInput m -> Maybe state) -> m (ParserInput m)+ scan state f = do i <- getInput+ let (prefix, _suffix, _state) = Factorial.spanMaybe' state f i+ take (Factorial.length prefix)+ default takeWhile :: (Monad m, FactorialMonoid (ParserInput m)) => (ParserInput m -> Bool) -> m (ParserInput m)+ takeWhile predicate = do i <- getInput+ take (Factorial.length $ Factorial.takeWhile predicate i)+ default takeWhile1 :: (Monad m, FactorialMonoid (ParserInput m)) => (ParserInput m -> Bool) -> m (ParserInput m)+ takeWhile1 predicate = do x <- takeWhile predicate+ if Null.null x then unexpected "takeWhile1" else pure x+ {-# INLINE concatMany #-}++-- | Methods for parsing textual monoid inputs+class (CharParsing m, InputParsing m) => InputCharParsing m where+ -- | Specialization of 'satisfy' on textual inputs, accepting an input character only if it satisfies the given+ -- predicate, and returning the input atom that represents the character. Equivalent to @fmap singleton+ -- . Char.satisfy@+ satisfyCharInput :: (Char -> Bool) -> m (ParserInput m)+ -- | A parser that succeeds exactly when satisfy doesn't, equivalent to @notFollowedBy . Char.satisfy@+ notSatisfyChar :: (Char -> Bool) -> m ()++ -- | Stateful scanner like `scan`, but specialized for 'TextualMonoid' inputs.+ scanChars :: state -> (state -> Char -> Maybe state) -> m (ParserInput m)++ -- | Specialization of 'takeWhile' on 'TextualMonoid' inputs, accepting the longest sequence of input characters that+ -- match the given predicate; an optimized version of @fmap fromString . many . Char.satisfy@.+ --+ -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers+ -- loop until a failure occurs. Careless use will thus result in an infinite loop.+ takeCharsWhile :: (Char -> Bool) -> m (ParserInput m)+ -- | Specialization of 'takeWhile1' on 'TextualMonoid' inputs, accepting the longest sequence of input characters+ -- that match the given predicate; an optimized version of @fmap fromString . some . Char.satisfy@.+ takeCharsWhile1 :: (Char -> Bool) -> m (ParserInput m)++ default satisfyCharInput :: IsString (ParserInput m) => (Char -> Bool) -> m (ParserInput m)+ satisfyCharInput = fmap (fromString . (:[])) . Char.satisfy+ notSatisfyChar = notFollowedBy . Char.satisfy+ default scanChars :: (Monad m, TextualMonoid (ParserInput m)) =>+ state -> (state -> Char -> Maybe state) -> m (ParserInput m)+ scanChars state f = do i <- getInput+ let (prefix, _suffix, _state) = Textual.spanMaybe' state (const $ const Nothing) f i+ take (Factorial.length prefix)++ default takeCharsWhile :: (Monad m, TextualMonoid (ParserInput m)) => (Char -> Bool) -> m (ParserInput m)+ takeCharsWhile predicate = do i <- getInput+ take (Factorial.length $ Textual.takeWhile_ False predicate i)+ default takeCharsWhile1 :: (Monad m, TextualMonoid (ParserInput m)) => (Char -> Bool) -> m (ParserInput m)+ takeCharsWhile1 predicate = do x <- takeCharsWhile predicate+ if Null.null x then unexpected "takeCharsWhile1" else pure x++-- | A subclass of 'InputParsing' for parsers that can switch the input stream type+class InputMappableParsing m where+ -- | Converts a parser accepting one input stream type to another. The functions @forth@ and @back@ must be inverses of+ -- each other and they must distribute through '<>':+ --+ -- > f (s1 <> s2) == f s1 <> f s2+ mapParserInput :: (InputParsing (m s), s ~ ParserInput (m s), Monoid s, Monoid s') =>+ (s -> s') -> (s' -> s) -> m s a -> m s' a+ -- | Converts a parser accepting one input stream type to another just like 'mapParserInput', except the argument+ -- functions can return @Nothing@ to indicate they need more input.+ + mapMaybeParserInput :: (InputParsing (m s), s ~ ParserInput (m s), Monoid s, Monoid s') =>+ (s -> Maybe s') -> (s' -> Maybe s) -> m s a -> m s' a++-- | A subclass of 'MonadFix' for monads that can fix a function that handles higher-kinded data+class Monad m => FixTraversable m where+ -- | This specialized form of 'Rank2.traverse' can be used inside 'mfix'.+ fixSequence :: (Rank2.Traversable g, Applicative n) => g m -> m (g n)+ fixSequence = Rank2.traverse (pure <$>)++------------------------------------------------------------+-- Instances+------------------------------------------------------------++data Error = Error [String] (Maybe String) deriving (Eq, Show)++instance Semigroup Error where+ Error expected1 encountered1 <> Error expected2 encountered2 =+ Error (expected1 <> expected2) (maybe encountered2 Just encountered1)++instance AlternativeFail Maybe++instance AlternativeFail []++instance {-# OVERLAPS #-} Alternative (Either Error) where+ empty = Left (Error [] Nothing)+ Right a <|> _ = Right a+ _ <|> Right a = Right a+ Left e1 <|> Left e2 = Left (e1 <> e2)++instance AlternativeFail (Either Error) where+ failure encountered = Left (Error [] (Just encountered))+ expectedName expected (Left (Error _ encountered)) = Left (Error [expected] encountered)+ expectedName _ success = success++errorString :: Error -> String+errorString (Error ex Nothing) = maybe "" ("expected " <>) (concatExpected ex)+errorString (Error [] (Just en)) = "encountered " <> en+errorString (Error ex (Just en)) = maybe "" ("expected " <>) (concatExpected ex) <> ", encountered " <> en++concatExpected :: [String] -> Maybe String+concatExpected [] = Nothing+concatExpected [e] = Just e+concatExpected [e1, e2] = Just (e1 <> " or " <> e2)+concatExpected (e:es) = Just (oxfordComma e es)++oxfordComma :: String -> [String] -> String+oxfordComma e [] = "or " <> e+oxfordComma e (e':es) = e <> ", " <> oxfordComma e' es++instance InputParsing ReadP where+ type ParserInput ReadP = String+ getInput = ReadP.look+ take n = count n ReadP.get+ anyToken = pure <$> ReadP.get+ satisfy predicate = pure <$> ReadP.satisfy (predicate . pure)+ string = ReadP.string++instance InputCharParsing ReadP where+ satisfyCharInput predicate = pure <$> ReadP.satisfy predicate++instance InputParsing Attoparsec.Parser where+ type ParserInput Attoparsec.Parser = ByteString+ getInput = lookAhead Attoparsec.takeByteString+ anyToken = Attoparsec.take 1+ take = Attoparsec.take+ satisfy predicate = Attoparsec.satisfyWith ByteString.singleton predicate+ string = Attoparsec.string++instance InputCharParsing Attoparsec.Parser where+ satisfyCharInput predicate = ByteString.Char8.singleton <$> Attoparsec.Char8.satisfy predicate+ scanChars = Attoparsec.Char8.scan+ takeCharsWhile = Attoparsec.Char8.takeWhile+ takeCharsWhile1 = Attoparsec.Char8.takeWhile1++instance InputParsing Attoparsec.Text.Parser where+ type ParserInput Attoparsec.Text.Parser = Text+ getInput = lookAhead Attoparsec.Text.takeText+ anyToken = Attoparsec.Text.take 1+ take = Attoparsec.Text.take+ satisfy predicate = Attoparsec.Text.satisfyWith Text.singleton predicate+ string = Attoparsec.Text.string++instance InputCharParsing Attoparsec.Text.Parser where+ satisfyCharInput predicate = Text.singleton <$> Attoparsec.Text.satisfy predicate+ scanChars = Attoparsec.Text.scan+ takeCharsWhile = Attoparsec.Text.takeWhile+ takeCharsWhile1 = Attoparsec.Text.takeWhile1++instance (FactorialMonoid s, Cancellative.LeftReductive s, LookAheadParsing (Incremental.Parser t s)) =>+ InputParsing (Incremental.Parser t s) where+ type ParserInput (Incremental.Parser t s) = s+ getInput = lookAhead Incremental.acceptAll+ anyToken = Incremental.anyToken+ take n = Incremental.count n Incremental.anyToken+ satisfy = Incremental.satisfy+ string = Incremental.string+ takeWhile = Incremental.takeWhile+ takeWhile1 = Incremental.takeWhile1+ concatMany = Incremental.concatMany++instance (TextualMonoid s, Cancellative.LeftReductive s, LookAheadParsing (Incremental.Parser t s)) =>+ InputCharParsing (Incremental.Parser t s) where+ satisfyCharInput = Incremental.satisfyChar+ takeCharsWhile = Incremental.takeCharsWhile+ takeCharsWhile1 = Incremental.takeCharsWhile1++instance FixTraversable Attoparsec.Parser++instance Monoid s => FixTraversable (Incremental.Parser t s) where+ fixSequence = Incremental.record++instance InputMappableParsing (Incremental.Parser t) where+ mapParserInput = Incremental.mapInput+ mapMaybeParserInput = Incremental.mapMaybeInput+
+ src/Construct/Internal.hs view
@@ -0,0 +1,16 @@+module Construct.Internal where++-- | The central type. The four type parameters are:+--+-- * @m@ is the type of the parser for the format+-- * @n@ is the container type for the serialized form of the value, typically 'Identity' unless something+-- 'Alternative' is called for.+-- * @s@ is the type of the serialized value, typically 'ByteString'+-- * @a@ is the type of the value in the program+--+-- The @parse@ and @serialize@ fields can be used to perform the two sides of the conversion between the in-memory and+-- serialized form of the value.+data Format m n s a = Format {+ parse :: m a,+ serialize :: a -> n s+ }
+ test/Doctest.hs view
@@ -0,0 +1,6 @@+import Build_doctests (flags, pkgs, module_sources)+import Test.DocTest (doctest)++main = do+ doctest (flags ++ pkgs ++ module_sources)+ doctest (flags ++ pkgs ++ ["-pgmL", "markdown-unlit", "test/README.lhs"])
+ test/MBR.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances, StandaloneDeriving, TemplateHaskell #-}+module MBR where++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.Functor.Identity (Identity)+import Data.Word+import qualified Rank2.TH+import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser)++import Construct+import Construct.Bits++import Prelude hiding ((<$), head)++data MasterBootRecord f = MasterBootRecord{+ bootLoaderCode :: f [Word8],+ partitions :: f [Partition Identity]+ }++data Partition f = Partition{+ state :: f PartitionState,+ beginning :: f (Position Identity),+ partitionType :: f PartitionType,+ ending :: f (Position Identity),+ sectorOffset :: f Word32,+ size :: f Word32}++data PartitionState = Inactive | Active+ deriving (Eq, Read, Show)++data PartitionType = NoType+ | FAT12+ | XENIX_ROOT+ | XENIX_USR+ | FAT16_old+ | Extended_DOS+ | FAT16+ | NTFS+ | FAT32+ | FAT32_LBA+ | ExtendedWithLBA+ | LINUX_SWAP+ | LINUX_NATIVE+ deriving (Eq, Read, Show)++data Position f = Position{+ head :: f Word8,+ sector :: f Bits,+ cylinder :: f Bits}++deriving instance Show (MasterBootRecord Identity)+deriving instance Show (Partition Identity)+deriving instance Show (Position Identity)++format :: Format (Parser ByteString) Maybe ByteString (MasterBootRecord Identity)+format = record MasterBootRecord{+ bootLoaderCode = count 446 byte,+ partitions = count 4 partition}++partition :: Format (Parser ByteString) Maybe ByteString (Partition Identity)+partition = record Partition{+ state = Inactive <$ literal (ByteString.singleton 0) <|>+ Active <$ literal (ByteString.singleton 0x80),+ beginning = position,+ partitionType = NoType <$ literal (ByteString.singleton 0) <|>+ FAT12 <$ literal (ByteString.singleton 1) <|>+ XENIX_ROOT <$ literal (ByteString.singleton 2) <|>+ XENIX_USR <$ literal (ByteString.singleton 3) <|>+ FAT16_old <$ literal (ByteString.singleton 4) <|>+ Extended_DOS <$ literal (ByteString.singleton 5) <|>+ FAT16 <$ literal (ByteString.singleton 6) <|>+ NTFS <$ literal (ByteString.singleton 7) <|>+ FAT32 <$ literal (ByteString.singleton 0xB) <|>+ FAT32_LBA <$ literal (ByteString.singleton 0xC) <|>+ ExtendedWithLBA <$ literal (ByteString.singleton 0xF) <|>+ LINUX_SWAP <$ literal (ByteString.singleton 0x82) <|>+ LINUX_NATIVE <$ literal (ByteString.singleton 0x83),+ ending = position,+ sectorOffset = cereal,+ size = cereal}++position :: Format (Parser ByteString) Maybe ByteString (Position Identity)+position = littleEndianBytesOf $ record Position{+ head = littleEndianBitsOf byte,+ sector = count 6 bit,+ cylinder = count 10 bit}++$(Rank2.TH.deriveAll ''MasterBootRecord)+$(Rank2.TH.deriveAll ''Partition)+$(Rank2.TH.deriveAll ''Position)
+ test/README.lhs view
@@ -0,0 +1,113 @@+Construct.hs+============++This is a Haskell implementation of Python's [Construct](https://construct.readthedocs.io/en/latest/intro.html)+library. It provides a succinct and easy way to specify data formats. Before you get to the succinct part, though,+you'll probably need a bunch of extensions and imports:++~~~ {.haskell}+{-# LANGUAGE FlexibleInstances, StandaloneDeriving, TemplateHaskell #-}++module README where++import Data.Functor.Identity (Identity(Identity))+import Data.Word (Word8)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ASCII+import qualified Rank2.TH+import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser, completeResults, feed, feedEof)+import Construct++import Prelude hiding ((*>), (<*))+~~~++Example+-------++With that out of the way, let's take the simple example format from the original. Here's what its specification looks+like in Haskell:++~~~ {.haskell}+data BitMap f = BitMap{+ width :: f Word8,+ height :: f Word8,+ pixels :: f [[Word8]]+ }+deriving instance Show (BitMap Identity)+$(Rank2.TH.deriveAll ''BitMap)++format :: Format (Parser ByteString) Maybe ByteString (BitMap Identity)+format = literal (ASCII.pack "BMP") *> mfix (\this-> record+ BitMap{+ width= byte,+ height= byte,+ pixels= count (fromIntegral $ height this) (count (fromIntegral $ width this) byte)+ })+~~~++There are two parts to the specification.++The `data BitMap` declaration specifies the in-memory layout of a simple bitmap. Note that it's declared as a record+with every field wrapped in a type constructor parameter. This declaration style is sometimes called [Higher-Kinded+Data](https://reasonablypolymorphic.com/blog/higher-kinded-data/). To regain a regular record, just instantiate the+parameter to `Identity` — a `BitMap Identity` contains exactly one value of each field.++The other part of the specification is the `format` definition that specifies the bi-directional mapping between the+in-memory and the serialized form of the bitmap. A bijection, to be precise. The two definitions are enough to automatically+serialize the in-memory record form into the binary form:++~~~ {.haskell}+-- | >>> serialize format BitMap{width= Identity 3, height= Identity 2, pixels= Identity [[7,8,9], [11,12,13]]}+-- Just "BMP\ETX\STX\a\b\t\v\f\r"+~~~++and to parse the serialized binary form back into the record structure:++~~~ {.haskell}+-- | >>> completeResults $ feedEof $ feed (ASCII.pack "BMP" <> ByteString.pack [3, 2, 7, 8, 9, 11, 12, 13]) $ parse format+-- [(BitMap {width = Identity 3, height = Identity 2, pixels = Identity [[7,8,9],[11,12,13]]},"")]+~~~++Examples of more complex and realistic formats can be found in the+[`test`](https://github.com/blamario/construct/tree/master/test) directory.++Acknowledgements+----------------++I owe the inspiration for this library to Yair Chuchem and his+[post](https://yairchu.github.io/posts/codecs-as-prisms.html) that introduced me to Construct. I must also express+gratitude to the authors of the original library of course. And finally, to the authors of the paper [Invertible+Syntax Descriptions:Unifying Parsing and Pretty+Printing](https://www.informatik.uni-marburg.de/~rendel/unparse/rendel10invertible.pdf) which I remembered reading+just in time to avoid following some bad ideas.++Implementation notes+--------------------++I had to overcome two problems in the course of the implementation. The first difficulty, already touched on in the+aforementioned blog post, is how to convert a record of formats into a format of the record. As the author of+[rank2classes](https://hackage.haskell.org/package/rank2classes), I went for an obvious solution: parameterize the+record as seen in the example, make it an instance of the+[`Rank2.Traversable`](https://hackage.haskell.org/package/rank2classes-1.3.1.2/docs/Rank2.html#t:Traversable) class,+and apply [`Rank2.traverse`](https://hackage.haskell.org/package/rank2classes-1.3.1.2/docs/Rank2.html#v:traverse) to+it.++That little trick alone would have been enough for a nearly complete package, except the Python library also enables a+record field to refer to any of the preceding fields. This is not a problem when serializing, but when parsing it+means that a parser must be able to refer to an already-parsed part of the value that's still being parsed.++The standard solution to the problem of accessing the results (parsed values) of a computation (parsing) *while within+the computation* is known as the+[`MonadFix`](https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad-Fix.html#t:MonadFix) class, though+perhaps not as widely as it deserves. You won't find any parsers in the list of its instances, though, and for a good+reason - it's quite impossible for a parser to obtain a value that it hasn't parsed yet. All *we* need, luckily, is+access an already parsed part of a partially parsed structure. A limited `MonadFix` instance can do that, provided+that we also use a specialized form of `Rank2.traverse` capable of preserving the record structure while it's being+parsed.++As it happens, I have an old parser library named+[incremental-parser](https://hackage.haskell.org/package/incremental-parser) on Hackage, and the name seems quite+appropriate for what I'm doing here. I added the necessary functionality there, but another parser combinator library+should be capable of the same feat. It just needs to implement the `mfix` and `fixSequence` combinators and it can be+used with the present library.
+ test/TAR.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, StandaloneDeriving, TemplateHaskell #-}++module TAR where++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ASCII+import Data.Char (isOctDigit)+import Data.Foldable (fold)+import Data.Functor.Identity (Identity(Identity, runIdentity))+import Data.Monoid.Textual (TextualMonoid)+import qualified Data.Monoid.Textual+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Word+import Numeric (readOct, showOct)+import qualified Rank2.TH+import Data.Attoparsec.ByteString (Parser)++import Construct++import Prelude hiding ((<$), (<*), (*>), take, takeWhile)++data Archive f = Archive{files :: f [File Identity]}++data File f = File{+ header :: f (FileHeader () Identity),+ content :: f ByteString}++data FileType = NormalFile+ | HardLink+ | SymLink+ | CharSpecial+ | BlockSpecial+ | Directory+ | FIFO+ | ContiguousFile+ | ExtendedGlobalHeader+ | ExtendedFileHeader+ | VendorExtension{vendorCode :: Word8}+ | Reserved{reservedCode :: Word8}+ deriving (Eq, Read, Show)++data FileHeader cksum f = FileHeader{+ fileName :: f Text,+ fileMode :: f Word32,+ ownerID :: f Word32,+ groupID :: f Word32,+ fileSize :: f Word64,+ modified :: f Word64,+ checksum :: f cksum,+ fileType :: f FileType,+ linked :: f Text,+ ustar :: f (Maybe (UStarHeader Identity))}++data UStarHeader f = UStarHeader{+ ownerName :: f Text,+ groupName :: f Text,+ deviceMajor :: f (Maybe Word32),+ deviceMinor :: f (Maybe Word32),+ namePrefix :: f Text}++deriving instance Show (Archive Identity)+deriving instance Show (File Identity)+deriving instance Show (FileHeader () Identity)+deriving instance Show (FileHeader Word32 Identity)+deriving instance Show (UStarHeader Identity)++archive :: Format Parser Maybe ByteString (Archive Identity)+archive = record Archive{files= many file}++file :: Format Parser Maybe ByteString (File Identity)+file = mapValue (uncurry file) (\f-> (runIdentity $ header f, runIdentity $ content f)) $+ deppair fileHeader (\FileHeader{fileSize= size}->+ ByteString.replicate (((fromIntegral size + 511) `div` 512) * 512) 0 `padded`+ take (fromIntegral size))+ where file h c = File (Identity h) (Identity c)++fileHeader :: Format Parser Maybe ByteString (FileHeader () Identity)+fileHeader = mapMaybeValue validate calculate (record $ fileHeaderRecord (zeroDelimitedOctal 7 <* value char ' '))+ where validate header+ | header' <- header{checksum= pure ()}, fromIntegral (checksum header) == sumOf header' = Just header'+ | otherwise = Nothing+ calculate header = Just header{checksum= pure $ sumOf header}++fileHeaderRecord :: Format Parser Maybe ByteString cksum+ -> FileHeader cksum (Format Parser Maybe ByteString)+fileHeaderRecord checksumFormat = FileHeader{+ fileName = zeroDelimitedUtf8 100,+ fileMode = zeroDelimitedOctal 8,+ ownerID = zeroDelimitedOctal 8,+ groupID = zeroDelimitedOctal 8,+ fileSize = zeroDelimitedOctal64,+ modified = zeroDelimitedOctal64,+ checksum = checksumFormat,+ fileType = NormalFile <$ value char '0'+ <|> HardLink <$ value char '1'+ <|> SymLink <$ value char '2'+ <|> CharSpecial <$ value char '3'+ <|> BlockSpecial <$ value char '4'+ <|> Directory <$ value char '5'+ <|> FIFO <$ value char '6'+ <|> ContiguousFile <$ value char '7'+ <|> ExtendedGlobalHeader <$ value char 'g'+ <|> ExtendedFileHeader <$ value char 'x'+ <|> mapValue VendorExtension vendorCode byte+ <|> mapValue Reserved reservedCode byte,+ linked = zeroDelimitedUtf8 100,+ ustar = optional ((value (zeroDelimitedUtf8 8) "ustar " <|> value (zeroDelimitedUtf8 8) "ustar00") *> ustarHeader)}++ustarHeader :: Format Parser Maybe ByteString (UStarHeader Identity)+ustarHeader = record UStarHeader{+ ownerName = zeroDelimitedUtf8 32,+ groupName = zeroDelimitedUtf8 32,+ deviceMajor = optionWithDefault (literal $ ByteString.replicate 8 0) (zeroDelimitedOctal 8),+ deviceMinor = optionWithDefault (literal $ ByteString.replicate 8 0) (zeroDelimitedOctal 8),+ namePrefix = zeroDelimitedUtf8 167 {- 155+12 to pad to 512 -}}++zeroDelimitedUtf8 :: Int -> Format Parser Maybe ByteString Text+zeroDelimitedUtf8 width = mapValue decodeUtf8 encodeUtf8 $+ ByteString.replicate width 0 `padded1` (takeWhile (/= ByteString.singleton 0))++zeroDelimitedOctal :: Int -> Format Parser Maybe ByteString Word32+zeroDelimitedOctal width = mapValue (fst . head . readOct . ASCII.unpack)+ (padLeft '0' (width - 1) . ASCII.pack . flip showOct "") $+ ByteString.replicate width 0 `padded1` (takeCharsWhile1 isOctDigit)++zeroDelimitedOctal64 :: Format Parser Maybe ByteString Word64+zeroDelimitedOctal64 = mapValue (fst . head . readOct . ASCII.unpack)+ (padLeft '0' 11 . ASCII.pack . flip showOct "") $+ ByteString.replicate 12 0 `padded1` (takeCharsWhile1 isOctDigit)++padLeft :: Char -> Int -> ByteString -> ByteString+padLeft filler len bs+ | ByteString.length bs < len = ASCII.replicate (len - ByteString.length bs) filler <> bs+ | otherwise = bs++sumOf :: FileHeader () Identity -> Word32+sumOf header = ByteString.foldl' add 0 (fold $ serialize blankFormat header)+ where add s b = s + fromIntegral b+ blankFormat = record (fileHeaderRecord $ literal $ ASCII.replicate 8 ' ')++instance TextualMonoid ByteString where+ fromText = encodeUtf8+ singleton = ASCII.singleton+ splitCharacterPrefix = ASCII.uncons+ dropWhile _ = ASCII.dropWhile+ dropWhile_ _ = ASCII.dropWhile+ takeWhile _ = ASCII.takeWhile+ takeWhile_ _ = ASCII.takeWhile+ span _ = ASCII.span+ span_ _ = ASCII.span++$(Rank2.TH.deriveAll ''Archive)+$(Rank2.TH.deriveAll ''File)+$(Rank2.TH.deriveAll ''FileHeader)+$(Rank2.TH.deriveAll ''UStarHeader)
+ test/Test.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}++module Main where++import qualified Data.ByteString as ByteString+import Data.ByteString (ByteString)+import Data.Functor.Identity (Identity)+import Data.List (isSuffixOf)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Numeric (showHex)+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath.Posix (combine)+import qualified Text.ParserCombinators.Incremental as Incremental+import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser)+import qualified Data.Attoparsec.ByteString as Atto+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertFailure, assertEqual, testCase)++import Construct+import qualified MBR+import qualified TAR+import qualified URI+import qualified WMF++data TestFormat = forall f. TestFormat (Format (Parser ByteString) Maybe ByteString (f Identity))+ | forall f. LineFormat (Format (Parser Text) Maybe Text (f Identity))+ | forall f. AttoFormat (Format Atto.Parser Maybe ByteString (f Identity))++main = exampleTree "" "test/examples" >>= defaultMain . testGroup "examples"++exampleTree :: FilePath -> FilePath -> IO [TestTree]+exampleTree ancestry path =+ do let fullPath = combine ancestry path+ isDir <- doesDirectoryExist fullPath+ if isDir+ then (:[]) . testGroup path . concat <$> (listDirectory fullPath >>= mapM (exampleTree fullPath))+ else do blob <- ByteString.readFile fullPath+ let format+ | ".mbr" `isSuffixOf` path = TestFormat MBR.format+ | ".tar" `isSuffixOf` path = AttoFormat TAR.archive+ | ".uris" `isSuffixOf` path = LineFormat URI.uriReference+ | ".wmf" `isSuffixOf` path = TestFormat WMF.fileFormat+ textLines = Text.lines (decodeUtf8 blob)+ roundTrip f t+ | Text.null t = Just t+ | [(structure, remainder)] <- Incremental.completeResults (Incremental.feedEof $+ Incremental.feed t $ parse f),+ Text.null remainder = serialize f structure+ | otherwise = Nothing+ Just blob'+ | TestFormat f <- format,+ [(structure, remainder)] <- Incremental.completeResults (Incremental.feedEof $+ Incremental.feed blob $ parse f) =+ (<> remainder) <$> serialize f structure+ | LineFormat f <- format = Just (encodeUtf8 $ mconcat $ mapMaybe (roundTrip f) textLines)+ | AttoFormat f <- format,+ Atto.Done remainder structure <- Atto.parse (parse f) blob =+ (<> remainder) <$> serialize f structure+ | AttoFormat f <- format, Atto.Partial i <- Atto.parse (parse f) blob,+ Atto.Done remainder structure <- i mempty =+ (<> remainder) <$> serialize f structure+ return . (:[]) . testCase path $ assertEqual "round-trip" (hex blob) (hex blob')++hex :: ByteString -> String+hex = ByteString.foldr (pad . flip showHex "") ""+ where pad [x] s = ['0', x] ++ s+ pad [x, y] s = [x, y] ++ s
+ test/URI.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving,+ TemplateHaskell, TupleSections, TypeApplications #-}++module URI where++import Data.Bits ((.|.), (.&.), shift)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ASCII+import Data.Char (isAlpha, isAscii, isDigit, isHexDigit, chr, ord)+import Data.Foldable (fold)+import Data.Functor.Identity (Identity, runIdentity)+import qualified Data.List as List+import Data.Maybe (isNothing, maybe)+import Data.Monoid.Textual (TextualMonoid)+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual+import Data.String (fromString)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Word+import Numeric (readHex, showHex)+import Numeric.Natural (Natural)+import qualified Rank2.TH+import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser)++import Construct++import Prelude hiding ((<$), (<*), (*>), take, takeWhile)++data UriReference t f = UriReference{+ scheme :: f (Maybe t),+ authority :: f (Maybe (Authority t Identity)),+ path :: f [t],+ query :: f (Maybe t),+ fragment :: f (Maybe t)+ }++data Authority t f = Authority{+ user :: f (Maybe t),+ host :: f (HostName t),+ port :: f (Maybe Word16)+ }++data HostName t = IPv4address{getIPv4address :: [Word8]}+ | IPv6address{getIPv6address :: [Word16]}+ | IPvFuture {version :: Word,+ address :: t}+ | RegisteredName{getRegisteredName :: t}++uriReference :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t (UriReference t Identity)+uriReference = record UriReference{+ scheme = optional (mapValue (uncurry (<>)) (Factorial.splitAt 1) $+ pair (satisfy (any alpha . Textual.characterPrefix) $ take 1)+ (takeCharsWhile schemeChar)+ <* literal ":"),+ authority = optional $ record Authority{+ user = optional (takeCharsWhile userChar <* literal "@"),+ host = hostName,+ port = optional (mapValue fromIntegral fromIntegral $ satisfy (< 65536) $+ literal ":" *> mapDec (takeCharsWhile1 digit))}, -- port = *DIGIT in spec?+ path = encodedCharSequence pathChar `sepBy` literal "/",+ query = optional (literal "*" *> encodedCharSequence queryChar),+ fragment = optional (literal "#" *> encodedCharSequence fragmentChar)+ }++hostName :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t (HostName t)+hostName = mapValue IPv4address getIPv4address ipV4address+ <|> literal "["+ *> (mapValue IPv6address getIPv6address ipV6address+ <|> mapValue (uncurry IPvFuture) (\ipf-> (version ipf, address ipf))+ (pair (literal "v" *> mapHex (takeCharsWhile1 hexDigit))+ (literal "." *> takeCharsWhile1 ipFutureChar)))+ <* literal "]"+ <|> mapValue RegisteredName getRegisteredName (encodedCharSequence hostChar)++ipV4address :: forall t. (Show t, TextualMonoid t) => Format (Parser t) Maybe t [Word8]+ipV4address = satisfy ((== 4) . length) (decOctet `sepBy` literal ".")+ where decOctet = mapValue fromIntegral fromIntegral $+ satisfy (< 256) $ mapDec $+ takeCharsWhile1 digit++ipV6address :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t [Word16]+ipV6address = satisfy ((== 8) . length) $+ mapValue fill shorten ipV6addressShort+ where fill :: [Maybe Word16] -> [Word16]+ shorten :: [Word16] -> [Maybe Word16]+ fill words = concatMap (maybe (replicate (8 - length words) 0) (:[])) words+ shorten [] = []+ shorten (0:0:words) = Nothing : map Just (dropWhile (== 0) words)+ shorten (word:words) = Just word : shorten words++ipV6addressShort :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t [Maybe Word16]+ipV6addressShort = satisfy zeroOrOneNothings $+ mapValue (uncurry (++)) (, []) $+ pair (optional h16 `sepBy` literal ":")+ (literal ":" *> mapValue v4tov6 v6tov4 ipV4address <|> [] <$ literal "")+ where v4tov6 [] = []+ v4tov6 (byte1:byte2:bytes) = Just (shift (fromIntegral byte1) 8 .|. fromIntegral byte2) : v4tov6 bytes+ v4tov6 _ = error "odd number of ipv4 bytes"+ v6tov4 [] = []+ v6tov4 (Just word:words) = fromIntegral (shift word $ negate 8) : fromIntegral (word .&. 0xFF) : v6tov4 words+ v6tov4 (Nothing:words) = 0 : 0 : v6tov4 words+ zeroOrOneNothings words = elisionCount == 0 && length words == 8 || elisionCount == 1 && length words < 7+ where elisionCount = length (filter isNothing words)+ h16 = mapHex $ satisfy ((<5) . Factorial.length) $ takeCharsWhile1 hexDigit++mapHex :: (Show t, TextualMonoid t, Integral n, Show n) => Format (Parser t) Maybe t t -> Format (Parser t) Maybe t n+mapDec :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t t -> Format (Parser t) Maybe t Natural+mapDec = mapValue (read . Textual.toString (error . show)) (fromString . show)+mapHex = mapValue (fst . head . readHex . Textual.toString (error . show)) (fromString . flip showHex "")++alpha, digit, hexDigit, schemeChar, hostChar, userChar, ipFutureChar,+ pathChar, queryChar, fragmentChar, unreserved, subDelim :: Char -> Bool++alpha c = isAlpha c && isAscii c+digit c = isAlpha c && isDigit c+hexDigit c = isAlpha c && isHexDigit c+schemeChar c = (isAlpha c || isDigit c) && isAscii c || elem @[] c "+-."+ipFutureChar = userChar+hostChar c = unreserved c || subDelim c+userChar c = unreserved c || subDelim c || c == ':'+pathChar c = unreserved c || subDelim c || c == ':' || c == '@'+queryChar c = pathChar c || c == '/' || c == '?'+fragmentChar = queryChar+subDelim c = elem @[] c "!$&'()*+,;="+unreserved c = isAscii c && (isAlpha c || isDigit c || elem @[] c "-._~")++encodedCharSequence :: forall t. (Show t, TextualMonoid t) => (Char -> Bool) -> Format (Parser t) Maybe t t+encodedCharSequence predicate = mapValue concatSequence splitSequence $+ many (takeCharsWhile predicate <+> percentEncoded)+ where concatSequence :: [Either t Char] -> t+ splitSequence :: t -> [Either t Char]+ percentEncoded :: Format (Parser t) Maybe t Char+ concatSequence = mconcat . map (either id Textual.singleton)+ splitSequence s = case Textual.splitCharacterPrefix s+ of Just ('#', rest)+ | Just (hex1, rest1) <- Textual.splitCharacterPrefix rest,+ Just (hex2, rest2) <- Textual.splitCharacterPrefix rest1 ->+ Right (hexChar [hex1, hex2]) : splitSequence rest2+ | otherwise -> []+ Just (c, _)+ | predicate c, (prefix, rest) <- Textual.span_ False predicate s -> Left prefix : splitSequence rest+ _ -> []+ percentEncoded = mapValue hexChar (padLeft . (`showHex` "") . ord) $+ literal "#" *> count 2 (satisfy hexDigit char)+ hexChar = chr . fst . head . readHex+ padLeft [c] = ['0', c]+ padLeft cs = cs++$(Rank2.TH.deriveAll ''UriReference)+$(Rank2.TH.deriveAll ''Authority)
+ test/WMF.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE FlexibleInstances, StandaloneDeriving, TemplateHaskell #-}++module WMF where++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.Functor.Identity (Identity)+import Data.Int+import Data.Word+import Data.Serialize+import qualified Rank2.TH+import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser)++import Construct++import Prelude hiding ((<$), (*>))++data File f = File{+ placeableHeader :: f (Maybe (PlaceableHeader Identity)),+ wmfType :: f WMFType,+ version :: f Word16,+ size :: f Word32,+ numberOfObjects :: f Word16,+ sizeOfLargestRecord :: f Word32,+ numberOfParams :: f Word16,+ records :: f [Record Identity]+ }++deriving instance Show (File Identity)++data PlaceableHeader f = PlaceableHeader{+ handle :: f Word16,+ left :: f Int16,+ top :: f Int16,+ right :: f Int16,+ bottom :: f Int16,+ unitsPerInch :: f Word16,+ checksum :: f Word16+ }++deriving instance Show (PlaceableHeader Identity)++data Record f = Record{+ recordSize :: f Word32,+ function :: f Function,+ params :: f [Word16]+ }++deriving instance Show (Record Identity)++data WMFType = InMemory | InFile deriving (Eq, Ord, Show)++data Function = AbortDoc+ | Aldus_Header+ | AnimatePalette+ | Arc+ | BitBlt+ | Chord+ | CLP_Header16+ | CLP_Header32+ | CreateBitmap+ | CreateBitmapIndirect+ | CreateBrush+ | CreateBrushIndirect+ | CreateFontIndirect+ | CreatePalette+ | CreatePatternBrush+ | CreatePenIndirect+ | CreateRegion+ | DeleteObject+ | DibBitblt+ | DibCreatePatternBrush+ | DibStretchBlt+ | DrawText+ | Ellipse+ | EndDoc+ | EndPage+ | EOF+ | Escape+ | ExcludeClipRect+ | ExtFloodFill+ | ExtTextOut+ | FillRegion+ | FloodFill+ | FrameRegion+ | Header+ | IntersectClipRect+ | InvertRegion+ | LineTo+ | MoveTo+ | OffsetClipRgn+ | OffsetViewportOrg+ | OffsetWindowOrg+ | PaintRegion+ | PatBlt+ | Pie+ | Polygon+ | Polyline+ | PolyPolygon+ | RealizePalette+ | Rectangle+ | ResetDC+ | ResizePalette+ | RestoreDC+ | RoundRect+ | SaveDC+ | ScaleViewportExt+ | ScaleWindowExt+ | SelectClipRegion+ | SelectObject+ | SelectPalette+ | SetBKColor+ | SetBKMode+ | SetDibToDev+ | SelLayout+ | SetMapMode+ | SetMapperFlags+ | SetPalEntries+ | SetPixel+ | SetPolyFillMode+ | SetReLabs+ | SetROP2+ | SetStretchBltMode+ | SetTextAlign+ | SetTextCharExtra+ | SetTextColor+ | SetTextJustification+ | SetViewportExt+ | SetViewportOrg+ | SetWindowExt+ | SetWindowOrg+ | StartDoc+ | StartPage+ | StretchBlt+ | StretchDIB+ | TextOut+ deriving (Eq, Ord, Show)++fileFormat :: Format (Parser ByteString) Maybe ByteString (File Identity)+fileFormat = record File{+ placeableHeader = optional headerFormat,+ wmfType = InMemory <$ literal (ByteString.pack [0, 0])+ <|> InFile <$ literal (ByteString.pack [1, 0]),+ version = literal (ByteString.pack [9, 0]) *> cereal' getWord16le putWord16le,+ size = cereal' getWord32le putWord32le,+ numberOfObjects = cereal' getWord16le putWord16le,+ sizeOfLargestRecord = cereal' getWord32le putWord32le,+ numberOfParams = cereal' getWord16le putWord16le,+ records = many recordFormat+ }+ +headerFormat :: Format (Parser ByteString) Maybe ByteString (PlaceableHeader Identity)+headerFormat = record PlaceableHeader{+ handle = literal (ByteString.pack [0xD7, 0xCD, 0xC6, 0x9A]) *> cereal' getWord16le putWord16le,+ left = cereal' getInt16le putInt16le,+ top = cereal' getInt16le putInt16le,+ right = cereal' getInt16le putInt16le,+ bottom = cereal' getInt16le putInt16le,+ unitsPerInch = cereal' getWord16le putWord16le,+ checksum = literal (ByteString.pack [0, 0, 0, 0]) *> cereal' getWord16le putWord16le+ }++recordFormat :: Format (Parser ByteString) Maybe ByteString (Record Identity)+recordFormat = mfix $ \this-> record Record{+ recordSize = cereal' getWord32le putWord32le,+ function = AbortDoc <$ word16le 0x0052 <|>+ Aldus_Header <$ word16le 0x0001 <|>+ AnimatePalette <$ word16le 0x0436 <|>+ Arc <$ word16le 0x0817 <|>+ BitBlt <$ word16le 0x0922 <|>+ Chord <$ word16le 0x0830 <|>+ CLP_Header16 <$ word16le 0x0002 <|>+ CLP_Header32 <$ word16le 0x0003 <|>+ CreateBitmap <$ word16le 0x06FE <|>+ CreateBitmapIndirect <$ word16le 0x02FD <|>+ CreateBrush <$ word16le 0x00F8 <|>+ CreateBrushIndirect <$ word16le 0x02FC <|>+ CreateFontIndirect <$ word16le 0x02FB <|>+ CreatePalette <$ word16le 0x00F7 <|>+ CreatePatternBrush <$ word16le 0x01F9 <|>+ CreatePenIndirect <$ word16le 0x02FA <|>+ CreateRegion <$ word16le 0x06FF <|>+ DeleteObject <$ word16le 0x01F0 <|>+ DibBitblt <$ word16le 0x0940 <|>+ DibCreatePatternBrush <$ word16le 0x0142 <|>+ DibStretchBlt <$ word16le 0x0B41 <|>+ DrawText <$ word16le 0x062F <|>+ Ellipse <$ word16le 0x0418 <|>+ EndDoc <$ word16le 0x005E <|>+ EndPage <$ word16le 0x0050 <|>+ EOF <$ word16le 0x0000 <|>+ Escape <$ word16le 0x0626 <|>+ ExcludeClipRect <$ word16le 0x0415 <|>+ ExtFloodFill <$ word16le 0x0548 <|>+ ExtTextOut <$ word16le 0x0A32 <|>+ FillRegion <$ word16le 0x0228 <|>+ FloodFill <$ word16le 0x0419 <|>+ FrameRegion <$ word16le 0x0429 <|>+ Header <$ word16le 0x0004 <|>+ IntersectClipRect <$ word16le 0x0416 <|>+ InvertRegion <$ word16le 0x012A <|>+ LineTo <$ word16le 0x0213 <|>+ MoveTo <$ word16le 0x0214 <|>+ OffsetClipRgn <$ word16le 0x0220 <|>+ OffsetViewportOrg <$ word16le 0x0211 <|>+ OffsetWindowOrg <$ word16le 0x020F <|>+ PaintRegion <$ word16le 0x012B <|>+ PatBlt <$ word16le 0x061D <|>+ Pie <$ word16le 0x081A <|>+ Polygon <$ word16le 0x0324 <|>+ Polyline <$ word16le 0x0325 <|>+ PolyPolygon <$ word16le 0x0538 <|>+ RealizePalette <$ word16le 0x0035 <|>+ Rectangle <$ word16le 0x041B <|>+ ResetDC <$ word16le 0x014C <|>+ ResizePalette <$ word16le 0x0139 <|>+ RestoreDC <$ word16le 0x0127 <|>+ RoundRect <$ word16le 0x061C <|>+ SaveDC <$ word16le 0x001E <|>+ ScaleViewportExt <$ word16le 0x0412 <|>+ ScaleWindowExt <$ word16le 0x0410 <|>+ SelectClipRegion <$ word16le 0x012C <|>+ SelectObject <$ word16le 0x012D <|>+ SelectPalette <$ word16le 0x0234 <|>+ SetBKColor <$ word16le 0x0201 <|>+ SetBKMode <$ word16le 0x0102 <|>+ SetDibToDev <$ word16le 0x0D33 <|>+ SelLayout <$ word16le 0x0149 <|>+ SetMapMode <$ word16le 0x0103 <|>+ SetMapperFlags <$ word16le 0x0231 <|>+ SetPalEntries <$ word16le 0x0037 <|>+ SetPixel <$ word16le 0x041F <|>+ SetPolyFillMode <$ word16le 0x0106 <|>+ SetReLabs <$ word16le 0x0105 <|>+ SetROP2 <$ word16le 0x0104 <|>+ SetStretchBltMode <$ word16le 0x0107 <|>+ SetTextAlign <$ word16le 0x012E <|>+ SetTextCharExtra <$ word16le 0x0108 <|>+ SetTextColor <$ word16le 0x0209 <|>+ SetTextJustification <$ word16le 0x020A <|>+ SetViewportExt <$ word16le 0x020E <|>+ SetViewportOrg <$ word16le 0x020D <|>+ SetWindowExt <$ word16le 0x020C <|>+ SetWindowOrg <$ word16le 0x020B <|>+ StartDoc <$ word16le 0x014D <|>+ StartPage <$ word16le 0x004F <|>+ StretchBlt <$ word16le 0x0B23 <|>+ StretchDIB <$ word16le 0x0F43 <|>+ TextOut <$ word16le 0x0521,+ params = count (fromIntegral (recordSize this) - 3) (cereal' getWord16le putWord16le)+ }+ where word16le = value (cereal' getWord16le putWord16le)++$(Rank2.TH.deriveAll ''File)+$(Rank2.TH.deriveAll ''PlaceableHeader)+$(Rank2.TH.deriveAll ''Record)
+ test/examples/wmf1.wmf view
binary file changed (absent → 1228 bytes)