{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.Pandoc.XMLFormat
  ( decodeAttrName,
    encodeAttrName,
    atNameAlignment,
    atNameApiVersion,
    atNameCitationHash,
    atNameCitationMode,
    atNameCitationNoteNum,
    atNameColspan,
    atNameColWidth,
    atNameFormat,
    atNameImageUrl,
    atNameLevel,
    atNameLinkUrl,
    atNameMathType,
    atNameMetaBoolValue,
    atNameMetaMapEntryKey,
    atNameNumberDelim,
    atNameNumberStyle,
    atNameQuoteType,
    atNameRowHeadColumns,
    atNameRowspan,
    atNameSpaceCount,
    atNameStart,
    atNameStrContent,
    atNameTitle,
    tgNameBodyBody,
    tgNameBodyHeader,
    tgNameCitations,
    tgNameCitationPrefix,
    tgNameCitationSuffix,
    tgNameColspecs,
    tgNameDefListDef,
    tgNameDefListItem,
    tgNameDefListTerm,
    tgNameLineItem,
    tgNameListItem,
    tgNameMetaMapEntry,
    tgNameShortCaption,
  )
where

import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, ord, toUpper)
import Data.Text (Text)
import qualified Data.Text as T
import Numeric (showHex)

-- | Encode an attribute name so that it is a valid XML name.
-- Characters that are not allowed in XML names -- and colons, which
-- XML parsers treat as namespace separators -- are encoded as
-- _xHHHH_, where HHHH is the hexadecimal code of the character
-- (uppercase, at least four digits).  An underscore that introduces
-- a literal "_x" is encoded as _x005F_, so that decoding is
-- unambiguous.  For example, "typst:property" is encoded as
-- "typst_x003A_property".
encodeAttrName :: Text -> Text
encodeAttrName :: Text -> Text
encodeAttrName Text
name =
  case Text -> String
T.unpack Text
name of
    [] -> Text
name
    Char
c : String
cs
      | Char -> Bool
isNameStartChar Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isNameChar String
cs Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
"_x" Text -> Text -> Bool
`T.isInfixOf` Text
name) ->
          Text
name
      | Bool
otherwise ->
          String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> [String]
go Char -> Bool
isNameStartChar (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs)
  where
    go :: (Char -> Bool) -> String -> [String]
go Char -> Bool
_ [] = []
    go Char -> Bool
ok (Char
c : String
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
&& Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
cs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"x" = Char -> String
encodeChar Char
'_' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
go Char -> Bool
isNameChar String
cs
      | Char -> Bool
ok Char
c = [Char
c] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
go Char -> Bool
isNameChar String
cs
      | Bool
otherwise = Char -> String
encodeChar Char
c String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
go Char -> Bool
isNameChar String
cs
    encodeChar :: Char -> String
encodeChar Char
c = String
"_x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
      where
        h :: String
h = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Integral a => a -> String -> String
showHex (Char -> Int
ord Char
c) String
""

-- | Decode an attribute name encoded by 'encodeAttrName': _xHHHH_
-- sequences (four to six hexadecimal digits) are decoded to the
-- character with the given code.
decodeAttrName :: Text -> Text
decodeAttrName :: Text -> Text
decodeAttrName Text
name
  | Text
"_x" Text -> Text -> Bool
`T.isInfixOf` Text
name = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
go Text
name
  | Bool
otherwise = Text
name
  where
    go :: Text -> [Text]
go Text
t =
      case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"_x" Text
t of
        (Text
pre, Text
rest)
          | Text -> Bool
T.null Text
rest -> [Text
pre]
          | Bool
otherwise ->
              let body :: Text
body = Int -> Text -> Text
T.drop Int
2 Text
rest
                  digits :: Text
digits = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isHexDigit Text
body
                  n :: Int
n = Text -> Int
T.length Text
digits
                  code :: Int
code = (Int -> Char -> Int) -> Int -> Text -> Int
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (\Int
acc Char
d -> Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
d) Int
0 Text
digits
               in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4
                    Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6
                    Bool -> Bool -> Bool
&& Text
"_" Text -> Text -> Bool
`T.isPrefixOf` Int -> Text -> Text
T.drop Int
n Text
body
                    Bool -> Bool -> Bool
&& Int -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
validChar Int
code
                    then Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Char -> Text
T.singleton (Int -> Char
chr Int
code) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
go (Int -> Text -> Text
T.drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
body)
                    else Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"_x" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
go Text
body
    validChar :: a -> Bool
validChar a
code = a
code a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x10FFFF Bool -> Bool -> Bool
&& Bool -> Bool
not (a
code a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0xD800 Bool -> Bool -> Bool
&& a
code a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0xDFFF)

-- the XML NameStartChar production, without the colon (which XML
-- parsers treat as a namespace separator)
isNameStartChar :: Char -> Bool
isNameStartChar :: Char -> Bool
isNameStartChar Char
c =
  Char -> Bool
isAsciiUpper Char
c
    Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xC0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xD6')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xD8' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xF6')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xF8' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2FF')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x370' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x37D')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x37F' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x1FFF')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x200C' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x200D')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x2070' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x218F')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x2C00' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2FEF')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x3001' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xD7FF')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xF900' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFDCF')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFDF0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFFFD')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x10000' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xEFFFF')

-- the XML NameChar production, without the colon
isNameChar :: Char -> Bool
isNameChar :: Char -> Bool
isNameChar Char
c =
  Char -> Bool
isNameStartChar Char
c
    Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xB7'
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x300' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x36F')
    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x203F' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2040')

-- the attribute carrying the API version of pandoc types in the main Pandoc element
atNameApiVersion :: Text
atNameApiVersion :: Text
atNameApiVersion = Text
"api-version"

-- the element of a <meta> or <MetaMap> entry
tgNameMetaMapEntry :: Text
tgNameMetaMapEntry :: Text
tgNameMetaMapEntry = Text
"entry"

-- the attribute carrying the key name of a <meta> or <MetaMap> entry
atNameMetaMapEntryKey :: Text
atNameMetaMapEntryKey :: Text
atNameMetaMapEntryKey = Text
"key"

-- the attribute carrying the boolean value ("true" or "false") of a MetaBool
atNameMetaBoolValue :: Text
atNameMetaBoolValue :: Text
atNameMetaBoolValue = Text
"value"

-- level of a Header
atNameLevel :: Text
atNameLevel :: Text
atNameLevel = Text
"level"

-- start number of an OrderedList
atNameStart :: Text
atNameStart :: Text
atNameStart = Text
"start"

-- number delimiter of an OrderedList
atNameNumberDelim :: Text
atNameNumberDelim :: Text
atNameNumberDelim = Text
"number-delim"

-- number style of an OrderedList
atNameNumberStyle :: Text
atNameNumberStyle :: Text
atNameNumberStyle = Text
"number-style"

-- target title in Image and Link
atNameTitle :: Text
atNameTitle :: Text
atNameTitle = Text
"title"

-- target url in Image
atNameImageUrl :: Text
atNameImageUrl :: Text
atNameImageUrl = Text
"src"

-- target url in Link
atNameLinkUrl :: Text
atNameLinkUrl :: Text
atNameLinkUrl = Text
"href"

-- QuoteType of a Quoted
atNameQuoteType :: Text
atNameQuoteType :: Text
atNameQuoteType = Text
"quote-type"

-- MathType of a Math
atNameMathType :: Text
atNameMathType :: Text
atNameMathType = Text
"math-type"

-- format of a RawInline or a RawBlock
atNameFormat :: Text
atNameFormat :: Text
atNameFormat = Text
"format"

-- alignment attribute in a ColSpec or in a Cell
atNameAlignment :: Text
atNameAlignment :: Text
atNameAlignment = Text
"alignment"

-- ColWidth attribute in a ColSpec
atNameColWidth :: Text
atNameColWidth :: Text
atNameColWidth = Text
"col-width"

-- RowHeadColumns attribute in a TableBody
atNameRowHeadColumns :: Text
atNameRowHeadColumns :: Text
atNameRowHeadColumns = Text
"row-head-columns"

-- RowSpan attribute in a Cell
atNameRowspan :: Text
atNameRowspan :: Text
atNameRowspan = Text
"row-span"

-- ColSpan attribute in a Cell
atNameColspan :: Text
atNameColspan :: Text
atNameColspan = Text
"col-span"

-- the citationMode of a Citation
atNameCitationMode :: Text
atNameCitationMode :: Text
atNameCitationMode = Text
"mode"

-- the citationHash of a Citation
atNameCitationHash :: Text
atNameCitationHash :: Text
atNameCitationHash = Text
"hash"

-- the citationNoteNum of a Citation
atNameCitationNoteNum :: Text
atNameCitationNoteNum :: Text
atNameCitationNoteNum = Text
"note-num"

-- the number of consecutive spaces of the <Space> element
atNameSpaceCount :: Text
atNameSpaceCount :: Text
atNameSpaceCount = Text
"count"

-- the content of the <Str> element
atNameStrContent :: Text
atNameStrContent :: Text
atNameStrContent = Text
"content"

-- container of Citation elements in Cite inlines
tgNameCitations :: Text
tgNameCitations :: Text
tgNameCitations = Text
"citations"

-- element around the prefix inlines of a Citation
tgNameCitationPrefix :: Text
tgNameCitationPrefix :: Text
tgNameCitationPrefix = Text
"prefix"

-- element around the suffix inlines of a Citation
tgNameCitationSuffix :: Text
tgNameCitationSuffix :: Text
tgNameCitationSuffix = Text
"suffix"

-- list item for BulletList and OrderedList
tgNameListItem :: Text
tgNameListItem :: Text
tgNameListItem = Text
"item"

-- list item for DefinitionList
tgNameDefListItem :: Text
tgNameDefListItem :: Text
tgNameDefListItem = Text
"item"

-- element around the inlines of the term of a DefinitionList item
tgNameDefListTerm :: Text
tgNameDefListTerm :: Text
tgNameDefListTerm = Text
"term"

-- element around the blocks of a definition in a DefinitionList item
tgNameDefListDef :: Text
tgNameDefListDef :: Text
tgNameDefListDef = Text
"def"

-- optional element of the ShortCaption
tgNameShortCaption :: Text
tgNameShortCaption :: Text
tgNameShortCaption = Text
"ShortCaption"

-- element around the ColSpec of a Table
tgNameColspecs :: Text
tgNameColspecs :: Text
tgNameColspecs = Text
"colspecs"

-- element around the header rows of a TableBody
tgNameBodyHeader :: Text
tgNameBodyHeader :: Text
tgNameBodyHeader = Text
"header"

-- element around the body rows of a TableBody
tgNameBodyBody :: Text
tgNameBodyBody :: Text
tgNameBodyBody = Text
"body"

-- element around the inlines of a line in a LineBlock
tgNameLineItem :: Text
tgNameLineItem :: Text
tgNameLineItem = Text
"line"