{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
-- | Parse and serialize between FDF files and `Map [Text] Text`.
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.ByteString qualified as ByteString
import Data.Char (chr, digitToInt, isAscii, isSpace, ord)
import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8 (ByteStringUTF8))
import Data.Monoid.Textual (singleton, toString, toText)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf16BE, encodeUtf8, encodeUtf16BE)
import Numeric (showOct)
import Rank2 qualified
import Text.Grampa
import Text.Grampa.Combinators
import Text.Parser.Char (octDigit)
import Text.Parser.Combinators (manyTill)
import Text.Grampa.PEG.Backtrack qualified as PEG
type Parser = PEG.Parser (Rank2.Only FDF)
-- | Parsed FDF data structure
data FDF = FDF {
header :: ByteString,
body :: Field,
trailer :: ByteString}
deriving (Show)
-- | The body of FDF is a tree of nestable 'Field's.
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"
<> serializeField body <> "\n"
<> "]\n"
<> ">>\n"
<> ">>\n"
<> trailer
<> "%%EOF\n"
serializeField :: Field -> ByteString
serializeField Field{name, value, kids} =
"<<\n"
<> "/T (" <> encodeUtf8 name <> ")\n"
<> foldMap (\v-> "/V (" <> serializeValue v <> ")\n") value
<> (if null kids then "" else "/Kids [\n" <> ByteString.intercalate "\n" (serializeField <$> kids) <> "]\n")
<> ">>"
serializeValue :: Text -> ByteString
serializeValue t
| Text.isAscii t = encodeUtf8 (plain <> escaped)
| otherwise = utf16beBOM <> encodeUtf16BE t
where (plain, special) = Text.span (\c -> c >= ' ' && c `notElem` ['(', ')', '\\']) t
escaped = Text.concatMap escape special
escape '(' = Text.pack "\\("
escape ')' = "\\)"
escape '\\' = "\\\\"
escape '\n' = "\\n"
escape '\r' = "\\r"
escape '\t' = "\\t"
escape '\b' = "\\b"
escape c
| c < ' ' = "\\" <> Text.justifyRight 3 '0' (Text.pack $ showOct (ord c) "")
| otherwise = Text.singleton c
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 ((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)
<* 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)
begin :: Parser ByteStringUTF8 ByteStringUTF8
begin = string "<<" *> lineEnd <?> "<<"
end :: Parser ByteStringUTF8 ByteStringUTF8
end = string ">>" *> takeCharsWhile (== ' ') *> moptional lineEnd *> pure mempty <?> ">>"
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
utf16beBOM :: ByteString
utf16beBOM = "\xFE\xFF"