forms-data-format (empty) → 0.1

raw patch · 5 files changed

+220/−0 lines, 5 filesdep +basedep +bytestringdep +grammatical-parsers

Dependencies added: base, bytestring, grammatical-parsers, monoid-subclasses, parsers, rank2classes, text

Files

CHANGELOG.md +5/−0
LICENSE +28/−0
README.md +15/−0
forms-data-format.cabal +36/−0
src/Text/FDF.hs +136/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for forms-data-format++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2023, Mario++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.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER 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,15 @@+Forms Data Format+=================++The Forms Data Format, or FDF for short, is a horrible data format thought up+by Adobe. Its only redeeming feature is that in practice it's much simpler+than PDF.++This Haskell package is hacked together to parse and re-serialize *some* files+in FDF format. It certainly does not support the full range of possible FDF+files. I tried to follow the specification but gave up.++The main purpose of the package is to allow parsing and serializing [Canadian+tax forms](https://github.com/blamario/canadian-income-tax) in FDF format.+For that purpose this hack seems sufficient. If you find it doesn't work for+some other FDF files, feel free to contribute.

+ forms-data-format.cabal view

@@ -0,0 +1,36 @@+cabal-version:      2.4+name:               forms-data-format+version:            0.1++synopsis: Parse and serialize FDF, the Forms Data Format++description: This is a hacked-together library to parse and serialize FDF,+             Adobe's [Forms Data+             Format](https://helpx.adobe.com/acrobat/kb/acrobat-forms-form-data-web.html). It+             does not follow the specification, but seems to work for simple+             cases.++category:           data, text+license:            BSD-3-Clause+license-files:      LICENSE+copyright:          (c) 2023 Mario Blažević+author:             Mario Blažević+maintainer:         blamario@protonmail.com+bug-reports:        https://github.com/blamario/forms-data-format/issues++extra-source-files: CHANGELOG.md, README.md+source-repository head+  type:     git+  location: https://github.com/blamario/forms-data-format++library+    exposed-modules:  Text.FDF++    -- Modules included in this library but not exported.+    -- other-modules:+    other-extensions: ImportQualifiedPost NamedFieldPuns OverloadedStrings+    build-depends:    base == 4.*, bytestring >=0.9 && < 0.12, text,+                      monoid-subclasses == 1.*, rank2classes >= 1 && < 1.6,+                      parsers < 0.13, grammatical-parsers >= 0.5 && < 0.8+    hs-source-dirs:   src+    default-language: Haskell2010

+ src/Text/FDF.hs view

@@ -0,0 +1,136 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Text.FDF (FDF (FDF, body), Field (Field, name, value, kids),+                 mapWithKey, mapFieldWithKey,+                 foldMapWithKey, foldMapFieldWithKey,+                 traverseWithKey, traverseFieldWithKey,+                 parse, serialize) where++import Control.Applicative ((<*), (<*>), (<|>), many, some, optional)+import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import Data.Char (isSpace)+import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8 (ByteStringUTF8))+import Data.Monoid.Textual (toString, toText)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding (encodeUtf8)+import Rank2 qualified+import Text.Grampa+import Text.Grampa.Combinators+import Text.Parser.Combinators (manyTill)+import Text.Grampa.PEG.Backtrack qualified as PEG++type Parser = PEG.Parser (Rank2.Only FDF)++data FDF = FDF {+  header :: ByteString,+  body :: Field,+  trailer :: ByteString}+  deriving (Show)++data Field = Field {+  name :: Text,+  value :: Maybe Text,+  kids :: [Field]}+  deriving (Show)++mapWithKey :: ([Text] -> Text -> Text) -> FDF -> FDF+mapWithKey f x@FDF{body} = x{body = mapFieldWithKey f body}++mapFieldWithKey :: ([Text] -> Text -> Text) -> Field -> Field+mapFieldWithKey f x@Field{name, value, kids} =+  x{value = f [name] <$> value,+    kids = mapFieldWithKey (f . (name:)) <$> kids}++foldMapWithKey :: Monoid a => ([Text] -> Text -> a) -> FDF -> a+foldMapWithKey f x@FDF{body} = foldMapFieldWithKey f body++foldMapFieldWithKey :: Monoid a => ([Text] -> Text -> a) -> Field -> a+foldMapFieldWithKey f x@Field{name, value, kids} =+  foldMap (f [name]) value <> foldMap (foldMapFieldWithKey $ f . (name:)) kids++traverseWithKey :: Applicative f => ([Text] -> Text -> f Text) -> FDF -> f FDF+traverseWithKey f x@FDF{body} = (\body'-> x{body = body'}) <$> traverseFieldWithKey f body++traverseFieldWithKey :: Applicative f => ([Text] -> Text -> f Text) -> Field -> f Field+traverseFieldWithKey f x@Field{name, value, kids} =+  Field name <$> traverse (f [name]) value <*> traverse (traverseFieldWithKey $ f . (name:)) kids++serialize :: FDF -> ByteString+serialize FDF{header, body, trailer} =+  "%FDF-1.2\n"+  <> header+  <> "<<\n"+  <> "/FDF\n"+  <> "<<\n"+  <> "/Fields [\n"+  <> encodeUtf8 (serializeField body) <> "\n"+  <> "]\n"+  <> ">>\n"+  <> ">>\n"+  <> trailer+  <> "%%EOF\n"++serializeField :: Field -> Text+serializeField Field{name, value, kids} =+  "<<\n"+  <> "/T (" <> name <> ")\n"+  <> foldMap (\v-> "/V (" <> v <> ")\n") value+  <> (if null kids then "" else "/Kids [\n" <> Text.intercalate "\n" (serializeField <$> kids) <> "]\n")+  <> ">>"++parse :: ByteString -> Either String FDF+parse input =+  bimap (\failure-> toString (const "<?>") $ failureDescription s failure 4) id $ simply parseComplete parser s+  where s = ByteStringUTF8 input++parser :: Parser ByteStringUTF8 FDF+parser = FDF+  <$ (string "%FDF-1.2" <* lineEnd <?> "first line")+  <*> extract ((takeWhile1 (`notElem` ["\r", "\n"]) <?> "bytes")+               <> lineEnd <> (mconcat <$> manyTill line begin) <?> "header")+  <* (string "/FDF" <* takeCharsWhile (== ' ') <* lineEnd <?> "end header")+  <* begin+  <* (string "/Fields [" <* takeCharsWhile (== ' ') <* lineEnd <?> "fields")+  <*> field+  <* (string "]" <* takeCharsWhile (== ' ') <* lineEnd <?> "end the fields")+  <* (end <?> "end the body")+  <*> extract ((end <?> "end the object")+               <> string "endobj" <> lineEnd+               <> takeCharsWhile isSpace+               <> string "trailer" <> lineEnd+               <> (mconcat <$> manyTill line (string "%%EOF" <?> "last line"))+               <?> "trailer")+  <* optional lineEnd++field :: Parser ByteStringUTF8 Field+field = Field <$ begin+  <*> strictText (string "/T (" *> takeCharsWhile (`notElem` [')', '\r', '\n']) <* string ")" <* lineEnd <?> "name")+  <*> optional (strictText $ admit (string "/V (" *> commit (takeCharsWhile (`notElem` [')', '\r', '\n']) <* string ")" <* lineEnd)+                                    <|> string "/V /" *> commit (takeCharsWhile (`notElem` ['\r', '\n']) <* lineEnd)+                                    <?> "value"))+  <*> admit (string "/Kids [" *> commit (lineEnd *> takeSome field <* string "]" <* lineEnd <?> "kids")+             <|> commit mempty)+  <* end++begin :: Parser ByteStringUTF8 ByteStringUTF8+begin = string "<<" *> lineEnd <?> "<<"++end :: Parser ByteStringUTF8 ByteStringUTF8+end = string ">>" *> takeCharsWhile (== ' ') *> moptional lineEnd <?> ">>"++line :: Parser ByteStringUTF8 ByteStringUTF8+line = takeCharsWhile (`notElem` ['\r', '\n']) <> lineEnd <?> "line"++lineEnd :: Parser ByteStringUTF8 ByteStringUTF8+lineEnd = string "\r\n" <|> string "\r" <|> string "\n"++strictText :: Parser ByteStringUTF8 ByteStringUTF8 -> Parser ByteStringUTF8 Text+strictText = fmap $ toText (error . ("Invalid UTF-8 sequence: " ++) . show)++extract :: Parser ByteStringUTF8 ByteStringUTF8 -> Parser ByteStringUTF8 ByteString+extract = fmap $ \(ByteStringUTF8 bs) -> bs