forms-data-format 0.2.1 → 0.3

raw patch · 6 files changed

+362/−36 lines, 6 filesdep +directorydep +forms-data-formatdep +optparse-applicativedep ~bytestringdep ~textnew-component:exe:fdfdiffnew-component:exe:fdfpatchPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, forms-data-format, optparse-applicative

Dependency ranges changed: bytestring, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• app/Common.hs +32/−0
• app/Diff.hs +120/−0
• app/Patch.hs +73/−0
• forms-data-format.cabal +19/−1
• src/Text/FDF.hs +113/−35

@@ -15,3 +15,8 @@ ## 0.2.1 -- 2024-02-29  * Properly parse and serialize special and Unicode characters++## 0.3 -- 2025-02-15++* Changed the `Field` data type, as it appears to never have a value and children at the same time+* Added executables `fdfdiff` and `fdfpatch`

@@ -0,0 +1,32 @@+-- | Common definitions for executables++{-# LANGUAGE Haskell2010, ImportQualifiedPost, OverloadedRecordDot, OverloadedStrings, NoFieldSelectors  #-}++module Common where++import Control.Monad (unless)+import Data.ByteString qualified as ByteString+import Data.Text (Text)+import System.Directory (doesFileExist)++import Text.FDF (FDF)+import Text.FDF qualified as FDF+++-- | A single item of a difference between two FDFs+data Difference+  = Deletion Text+  | Addition Text+  | Change Text Text+  deriving (Eq, Read, Show)++-- | Read an FDF file from the given path, standard input if path is @-@+readFDF :: FilePath -> IO FDF+readFDF inputPath = do+   exists <- doesFileExist inputPath+   unless (inputPath == "-" || exists) (error $ "Input file " <> show inputPath <> " doesn't exist.")+   content <- if inputPath == "-" then ByteString.getContents else ByteString.readFile inputPath+   case FDF.parse content of+     Left err -> error ((if inputPath == "-" then "Standard input" else "File " <> inputPath)+                        <> " is not valid FDF:\n" <> err)+     Right fdf -> pure fdf

@@ -0,0 +1,120 @@+-- | Outputs the difference of two input FDF files in the following format:+--+-- output = (line "\n")*+-- line = "< " path "=" value+--      | "> " path "=" value+--      | "! " path ": " value "->" value+-- path = name ("/" name)*+-- name = <any printable character except "/" and "=">*+-- value = <any printable character except ">">*++{-# LANGUAGE Haskell2010, ImportQualifiedPost, OverloadedRecordDot, OverloadedStrings, NoFieldSelectors  #-}++module Main (main) where++import Control.Applicative ((<|>), some)+import Control.Monad (when)+import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.List qualified as List+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text.IO+import Options.Applicative qualified as OptsAp++import Text.FDF (FDF)+import Text.FDF qualified as FDF+import Common (Difference(Deletion, Addition, Change), readFDF)+++data Options = Options {+  ignore :: [Text],+  oldPaths :: Bool,+  old :: FilePath,+  new :: FilePath,+  verbose :: Bool}++optionsParser :: OptsAp.Parser Options+optionsParser =+  (+    Options+    <$> some (OptsAp.strOption (OptsAp.short 'i' <> OptsAp.long "ignore" <> OptsAp.metavar "<name to ignore>"+                                <> OptsAp.help "ignore the named difference in the field path"))+    <*> (OptsAp.flag' True (OptsAp.long "old" <> OptsAp.help "emit field paths from the old FDF")+         <|> OptsAp.flag' False (OptsAp.long "new" <> OptsAp.help "emit field paths from the new FDF"))+    <|>+    pure (Options [] True)+  )+  <*> OptsAp.strArgument (OptsAp.metavar "<old form file input>")+  <*> OptsAp.strArgument (OptsAp.metavar "<new form file input>")+  <*> OptsAp.switch (OptsAp.short 'v' <> OptsAp.long "verbose" <> OptsAp.help "also diff fields with empty values")++diffLine :: ([Text], Difference) -> Text+diffLine (path, Deletion value) = "< " <> Text.intercalate "/" path <> "=" <> value+diffLine (path, Addition value) = "> " <> Text.intercalate "/" path <> "=" <> value+diffLine (path, Change old new) = "! " <> Text.intercalate "/" path <> ": " <> old <> "->" <> new++diff :: Bool -> (Text -> Bool) -> [Text] -> FDF.Field -> FDF.Field -> [([Text], Difference)]+diff oldPaths ignorable ancestry old new+  | old.name /= new.name =+    map (Deletion <$>) (list (ancestry ++) old) +++    map (Addition <$>) (list (ancestry ++) new)+  | otherwise = diffContents oldPaths ignorable (ancestry ++ [old.name]) old.content new.content++diffContents :: Bool -> (Text -> Bool) -> [Text] -> FDF.FieldContent -> FDF.FieldContent -> [([Text], Difference)]+diffContents oldPaths ignorable ancestry (FDF.FieldValue old) (FDF.FieldValue new)+  | old == new = []+  | otherwise = [(ancestry, Change old new)]+diffContents oldPaths ignorable ancestry (FDF.Children old) (FDF.Children new) =+  diffAll oldPaths ignorable ancestry old new+diffContents oldPaths ignorable ancestry old new =+  map (Deletion <$>) (listContent (ancestry ++) old) +++  map (Addition <$>) (listContent (ancestry ++) new)++diffAll, diffSorted :: Bool -> (Text -> Bool) -> [Text] -> [FDF.Field] -> [FDF.Field] -> [([Text], Difference)]++diffAll oldPaths ignorable ancestry old new = diffSorted oldPaths ignorable ancestry (List.sort old) (List.sort new)++diffSorted oldPaths ignorable ancestry (old : olds) (new : news)+  | ignorable old.name, FDF.Children kids <- old.content+  = diffSorted oldPaths ignorable+      (if oldPaths then ancestry ++ [old.name] else ancestry)+      (List.sort $ kids ++ olds)+      (new : news)+  | ignorable new.name, FDF.Children kids <- new.content+  = diffSorted oldPaths ignorable+      (if oldPaths then ancestry else ancestry ++ [new.name])+      (old : olds)+      (List.sort $ kids ++ news)+  | old.name < new.name = map (Deletion <$>) (list (ancestry ++) old) ++ diffSorted oldPaths ignorable ancestry olds (new : news)+  | old.name > new.name = map (Addition <$>) (list (ancestry ++) new) ++ diffSorted oldPaths ignorable ancestry (old : olds) news+  | otherwise = diff oldPaths ignorable ancestry old new <> diffSorted oldPaths ignorable ancestry olds news+diffSorted _ _ ancestry olds [] = foldMap (map (Deletion <$>) . list (ancestry ++)) olds+diffSorted _ _ ancestry [] news = foldMap (map (Addition <$>) . list (ancestry ++)) news++list :: ([Text] -> [Text]) -> FDF.Field -> [([Text], Text)]+list addAncestry x = listContent (addAncestry . (x.name :)) x.content++listContent :: ([Text] -> [Text]) -> FDF.FieldContent -> [([Text], Text)]+listContent addAncestry (FDF.FieldValue v) = [(addAncestry [], v)]+listContent addAncestry (FDF.Children kids) = foldMap (list addAncestry) (List.sort kids)++hasNonemptyValue :: Difference -> Bool+hasNonemptyValue (Deletion v) = not (Text.null v)+hasNonemptyValue (Addition v) = not (Text.null v)+hasNonemptyValue (Change v1 v2) = v1 /= v2++process :: Options -> IO ()+process options = do+  when (options.old == "-" && options.new == "-") $ error "Only one input can be '-' stdin"+  old <- readFDF options.old+  new <- readFDF options.new+  let filterEmpty = if options.verbose then id else filter (hasNonemptyValue . snd)+      ignorable name = maybe (name `elem` options.ignore) (`elem` options.ignore) (Text.stripSuffix "[0]" name)+  traverse_ (Text.IO.putStrLn . diffLine) (filterEmpty $ diff options.oldPaths ignorable [] old.body new.body)++main :: IO ()+main =+  OptsAp.execParser (OptsAp.info optionsParser+                     $ OptsAp.progDesc "Output the difference between two input FDF files")+  >>= process

@@ -0,0 +1,73 @@+{-# LANGUAGE Haskell2010, ImportQualifiedPost, OverloadedRecordDot, OverloadedStrings, NoFieldSelectors  #-}++-- | Patches an input FDF file guided by the specified difference file in the following format:+--+-- output = (line "\n")*+-- line = "< " path ("=" value)?+--      | "> " path ("=" value)?+--      | "! " path ": " value "->" value+-- path = name ("/" name)*+-- name = <any printable character except "/" and "=">*+-- value = <any printable character except ">">*++module Main (main) where++import Data.Bifunctor (first)+import Data.ByteString qualified as ByteString+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Semigroup (Endo(..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text.IO+import Options.Applicative qualified as OptsAp++import Text.FDF (FDF)+import Text.FDF qualified as FDF+import Common (Difference(Deletion, Addition, Change), readFDF)+++data Options = Options {+  diff :: FilePath,+  input :: FilePath}++optionsParser :: OptsAp.Parser Options+optionsParser =+  Options+  <$> OptsAp.strArgument (OptsAp.metavar "<diff file input>")+  <*> OptsAp.strArgument (OptsAp.metavar "<form file input>")++parseLine :: Text -> ([Text], Difference)+parseLine line = case Text.splitAt 2 line of+  ("< ", rest)+    | let (path, eqValue) = Text.break (== '=') rest,+      Just value <- Text.stripPrefix "=" eqValue+    -> (Text.split (== '/') path, Deletion value)+  ("> ", rest)+    | let (path, eqValue) = Text.break (== '=') rest,+      Just value <- Text.stripPrefix "=" eqValue+    -> (Text.split (== '/') path, Addition value)+  ("! ", rest)+    | let (path, colonValues) = Text.breakOn ": " rest,+      Just values <- Text.stripPrefix ": " colonValues,+      let (old, arrowNew) = Text.breakOn "->" values,+      Just new <- Text.stripPrefix "->" arrowNew+      -> (Text.split (== '/') path, Change old new)+  _ -> error ("Invalid diff syntax:\n" <> Text.unpack line)++patchFrom :: (NonEmpty Text, Difference) -> FDF -> FDF+patchFrom (path, Deletion v) = FDF.delete path v+patchFrom (path, Addition v) = FDF.insert path v+patchFrom (path, Change old new) = FDF.update path old new++process :: Options -> IO ()+process options = do+  diffs <- map parseLine . filter (not . Text.null) . Text.lines <$> Text.IO.readFile options.diff+  old <- readFDF options.input+  ByteString.putStr $ FDF.serialize $ appEndo (foldMap (Endo . patchFrom . first NonEmpty.fromList) diffs) $ old++main :: IO ()+main =+  OptsAp.execParser (OptsAp.info optionsParser+                     $ OptsAp.progDesc "Output the difference between two input FDF files")+  >>= process

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               forms-data-format-version:            0.2.1+version:            0.3  synopsis: Parse and serialize FDF, the Forms Data Format @@ -34,3 +34,21 @@                       parsers < 0.13, grammatical-parsers >= 0.5 && < 0.8     hs-source-dirs:   src     default-language: Haskell2010++executable fdfdiff+    main-is:          Diff.hs+    other-modules:    Common+    hs-source-dirs:   app+    default-language: Haskell2010+    build-depends:    base == 4.*, bytestring, text,+                      directory >= 1.2 && < 1.4, optparse-applicative >= 0.15 && < 0.19,+                      forms-data-format++executable fdfpatch+    main-is:          Patch.hs+    other-modules:    Common+    hs-source-dirs:   app+    default-language: Haskell2010+    build-depends:    base == 4.*, bytestring, text,+                      directory >= 1.2 && < 1.4, optparse-applicative >= 0.15 && < 0.19,+                      forms-data-format

@@ -5,7 +5,8 @@  -- | Parse and serialize between FDF files and `Map [Text] Text`. -module Text.FDF (FDF (FDF, body), Field (Field, name, value, kids),+module Text.FDF (FDF (FDF, body), Field (Field, name, content), FieldContent (FieldValue, Children),+                 insert, delete, update,                  mapWithKey, mapFieldWithKey,                  foldMapWithKey, foldMapFieldWithKey,                  traverseWithKey, traverseFieldWithKey,@@ -16,6 +17,7 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString import Data.Char (chr, digitToInt, isAscii, isSpace, ord)+import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8 (ByteStringUTF8)) import Data.Monoid.Textual (singleton, toString, toText) import Data.Text (Text)@@ -40,32 +42,102 @@  -- | The body of FDF is a tree of nestable 'Field's. data Field = Field {-  name :: Text,-  value :: Maybe Text,-  kids :: [Field]}-  deriving (Show)+    name :: Text,+    content :: FieldContent}+  deriving (Show, Eq, Ord) +data FieldContent+  = FieldValue Text+  | Children [Field]+  deriving (Show, Eq, Ord)++-- | Insert a value at a new path into the FDF+insert :: NonEmpty Text -> Text -> FDF -> FDF+insert key value x@FDF{body} = x{body = insertField key value body}++-- | Delete an existing field at the given path from the FDF+delete :: NonEmpty Text -> Text -> FDF -> FDF+delete key old x@FDF{body} = x{body = deleteField key old body}++-- | Update a value at a new path into the FDF+update :: NonEmpty Text -> Text -> Text -> FDF -> FDF+update key old new x@FDF{body} = x{body = updateField key old new body}++insertField :: NonEmpty Text -> Text -> Field -> Field+insertField (root :| path) new x@Field{name, content}+  | root /= name = error ("Insertion name mismatch: " <> show root <> "/=" <> show name)+  | otherwise = case nonEmpty path of+      Nothing+        | FieldValue old <- content -> error ("Insertion would overwrite value: " <> show old <> "->" <> show new)+        | otherwise -> error ("Insertion would prune " <> show root)+      Just path' -> case content of+        FieldValue old -> error ("Insertion ran out " <> show (root : path))+        Children kids -> x{content= Children $ insertAmong path' new kids}++deleteField :: NonEmpty Text -> Text -> Field -> Field+deleteField (root :| path) old x@Field{name, content}+  | root /= name = error ("Deletion name mismatch: " <> show root <> "/=" <> show name)+  | otherwise = case nonEmpty path of+      Nothing+        | Children{} <- content -> error ("Deletion would prune " <> show root)+        | content /= FieldValue old -> error ("Expected to delete " <> show old <> ", instead found " <> show content)+      Just path'+        | Children kids <- content -> x{content= Children $ deleteAmong path' old kids}+        | otherwise -> error ("Deletion ran out " <> show root)++updateField :: NonEmpty Text -> Text -> Text -> Field -> Field+updateField (root :| path) old new x@Field{name, content}+  | root /= name = error ("Update name mismatch: " <> show root <> "/=" <> show name)+  | otherwise = case nonEmpty path of+      Nothing+        | content /= FieldValue old -> error ("Expected to update " <> show old <> ", instead found " <> show content)+        | otherwise -> x{content= FieldValue new}+      Just path'+        | Children kids <- content -> x{content= Children $ updateAmong path' old new kids}++insertAmong :: NonEmpty Text -> Text -> [Field] -> [Field]+insertAmong path@(root :| _) new (x@Field{name} : xs)+  | root == name = insertField path new x : xs+  | otherwise = x : insertAmong path new xs+insertAmong (root :| path) new [] = case nonEmpty path of+  Nothing -> [Field{name=root, content = FieldValue new}]+  Just path' ->[Field{name=root, content = Children $ insertAmong path' new []}]++deleteAmong :: NonEmpty Text -> Text -> [Field] -> [Field]+deleteAmong path@(root :| rest) old (x@Field{name, content} : xs)+  | root /= name = x : deleteAmong path old xs+  | Just path' <- nonEmpty rest = deleteField path' old x : xs+  | content /= FieldValue old = error ("Expected to delete " <> show old <> ", instead found " <> show content)+  | otherwise = xs+deleteAmong path _ [] = error ("Can't find the path to delete, " <> show path)++updateAmong :: NonEmpty Text -> Text -> Text -> [Field] -> [Field]+updateAmong path@(root :| _) old new (x@Field{name} : xs)+  | root == name = updateField path old new x : xs+  | otherwise = x : updateAmong path old new xs+updateAmong path _ _ [] = error ("Can't find the path to update, " <> show path)+ 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}+mapFieldWithKey f x@Field{name, content=FieldValue v} = x{content = FieldValue $ f [name] v}+mapFieldWithKey f x@Field{name, content=Children kids} = x{content = Children $ 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+foldMapFieldWithKey f Field{name, content = FieldValue v} = f [name] v+foldMapFieldWithKey f Field{name, content = Children kids} = 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+traverseFieldWithKey f Field{name, content = FieldValue v} = Field name . FieldValue <$> f [name] v+traverseFieldWithKey f Field{name, content = Children kids} =+  Field name . Children <$> traverse (traverseFieldWithKey $ f . (name:)) kids  serialize :: FDF -> ByteString serialize FDF{header, body, trailer} =@@ -83,10 +155,14 @@   <> "%%EOF\n"  serializeField :: Field -> ByteString-serializeField Field{name, value, kids} =+serializeField Field{name, content = FieldValue v} =   "<<\n"   <> "/T (" <> encodeUtf8 name <> ")\n"-  <> foldMap (\v-> "/V (" <> serializeValue v <> ")\n") value+  <> "/V (" <> serializeValue v <> ")\n"+  <> ">>"+serializeField Field{name, content = Children kids} =+  "<<\n"+  <> "/T (" <> encodeUtf8 name <> ")\n"   <> (if null kids then "" else "/Kids [\n" <> ByteString.intercalate "\n" (serializeField <$> kids) <> "]\n")   <> ">>" @@ -134,28 +210,30 @@ field :: Parser ByteStringUTF8 Field field = Field <$ begin   <*> strictText (string "/T (" *> takeCharsWhile (`notElem` [')', '\r', '\n']) <* string ")" <* lineEnd <?> "name")-  <*> optional (strictText $-                admit (string "/V ("-                       *> commit ((string (ByteStringUTF8 utf16beBOM) *> (utf8from16 <$> Text.Grampa.takeWhile (/= ")"))-                                   <|> concatMany (takeCharsWhile1 (`notElem` [')', '\r', '\n', '\\']) <|> escape))-                                  <* string ")" <* lineEnd)-                       <|> string "/V /" *> commit (takeCharsWhile (`notElem` ['\r', '\n']) <* lineEnd)-                       <?> "value"))-  <*> admit (string "/Kids [" *> commit (lineEnd *> takeSome field <* string "]" <* lineEnd <?> "kids")-             <|> commit mempty)+  <*> (FieldValue <$> fieldValue <|> Children <$> children)   <* end-  where escape = char '\\'-                 *> (singleton <$> (char 'n' *> pure '\n'-                                    <|> char 'r' *> pure '\r'-                                    <|> char 't' *> pure '\t'-                                    <|> char 'b' *> pure '\b'-                                    <|> char 'f' *> pure '\f'-                                    <|> char '(' *> pure '('-                                    <|> char ')' *> pure ')'-                                    <|> char '\\' *> pure '\\'-                                    <|> chr . sum <$> sequenceA [(64 *) <$> octalDigit, (8 *) <$> octalDigit, octalDigit]))-        octalDigit = digitToInt <$> octDigit-        utf8from16 (ByteStringUTF8 bs) = ByteStringUTF8 (encodeUtf8 $ decodeUtf16BE bs)+  where+    fieldValue = strictText $+                 admit (string "/V ("+                        *> commit ((string (ByteStringUTF8 utf16beBOM) *> (utf8from16 <$> Text.Grampa.takeWhile (/= ")"))+                                    <|> concatMany (takeCharsWhile1 (`notElem` [')', '\r', '\n', '\\']) <|> escape))+                                   <* string ")" <* lineEnd)+                        <|> string "/V /" *> commit (takeCharsWhile (`notElem` ['\r', '\n']) <* lineEnd)+                        <?> "value")+    children = admit (string "/Kids [" *> commit (lineEnd *> takeSome field <* string "]" <* lineEnd <?> "kids")+                      <|> commit mempty)+    escape = char '\\'+             *> (singleton <$> (char 'n' *> pure '\n'+                                <|> char 'r' *> pure '\r'+                                <|> char 't' *> pure '\t'+                                <|> char 'b' *> pure '\b'+                                <|> char 'f' *> pure '\f'+                                <|> char '(' *> pure '('+                                <|> char ')' *> pure ')'+                                <|> char '\\' *> pure '\\'+                                <|> chr . sum <$> sequenceA [(64 *) <$> octalDigit, (8 *) <$> octalDigit, octalDigit]))+    octalDigit = digitToInt <$> octDigit+    utf8from16 (ByteStringUTF8 bs) = ByteStringUTF8 (encodeUtf8 $ decodeUtf16BE bs)  begin :: Parser ByteStringUTF8 ByteStringUTF8 begin = string "<<" *> lineEnd <?> "<<"