diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/app/Common.hs b/app/Common.hs new file mode 100644 --- /dev/null +++ b/app/Common.hs @@ -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 diff --git a/app/Diff.hs b/app/Diff.hs new file mode 100644 --- /dev/null +++ b/app/Diff.hs @@ -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 = ">* + +{-# 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 "" + <> 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 "") + <*> OptsAp.strArgument (OptsAp.metavar "") + <*> 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 diff --git a/app/Patch.hs b/app/Patch.hs new file mode 100644 --- /dev/null +++ b/app/Patch.hs @@ -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 = ">* + +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 "") + <*> OptsAp.strArgument (OptsAp.metavar "
") + +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 diff --git a/forms-data-format.cabal b/forms-data-format.cabal --- a/forms-data-format.cabal +++ b/forms-data-format.cabal @@ -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 diff --git a/src/Text/FDF.hs b/src/Text/FDF.hs --- a/src/Text/FDF.hs +++ b/src/Text/FDF.hs @@ -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 "<<"