mini-2.2.0.0: src/Mini/String/XML.hs

-- | XML 1.0 (Fifth Edition): <https://www.w3.org/TR/2008/REC-xml-20081126>
module Mini.String.XML (
  -- * Types
  Document (
    Document
  ),
  Element (
    Element
  ),
  Node (
    NodeCData,
    NodeComment,
    NodeElement,
    NodePI
  ),
  Misc (
    MiscComment,
    MiscPI,
    MiscSpace
  ),
  PI (
    PI
  ),
  Attributes (
    Attributes
  ),
  EType (
    EType
  ),
  CData (
    CData
  ),
  Key (
    Key
  ),
  Value (
    Value
  ),
  Comment (
    Comment
  ),
  Target (
    Target
  ),
  Instruction (
    Instruction
  ),
  Space (
    Space
  ),

  -- * Parsers
  document,

  -- * Encoding
  encode,
  decode,
) where

import Control.Applicative (
  empty,
  many,
  optional,
  some,
  (<|>),
 )
import Data.Bits (
  shiftL,
 )
import Data.Bool (
  bool,
 )
import Data.Char (
  digitToInt,
 )
import Mini.Data.Map (
  Map,
 )
import qualified Mini.Data.Map as Map (
  foldrWith,
  insert,
  member,
 )
import Mini.Hash.Class (
  Hashable,
  toBytes,
 )
import Mini.Transformers.Parser (
  ParserT,
  accept,
  noneOf,
  oneOf,
  reject,
  sat,
  string,
  symbol,
  till,
 )
import Prelude (
  Char,
  Eq,
  Maybe,
  Monad,
  Ord,
  Show,
  String,
  concatMap,
  dropWhile,
  foldl,
  fromEnum,
  maybe,
  mempty,
  null,
  pure,
  show,
  toEnum,
  ($),
  (&&),
  (*),
  (*>),
  (+),
  (.),
  (<$),
  (<$>),
  (<*),
  (<*>),
  (<=),
  (<>),
  (==),
  (>=),
  (>>=),
  (||),
 )

-- Types

-- | An XML document
data Document = Document [Misc] Element [Misc]
  deriving (Eq, Ord)

instance Show Document where
  show (Document ms e ms') = concatMap show ms <> show e <> concatMap show ms'

instance Hashable Document where
  toBytes = toBytes . show

-- | An element
data Element = Element EType Attributes [Node]
  deriving (Eq, Ord)

instance Show Element where
  show (Element t as ns) =
    "<"
      <> show t
      <> show as
      <> bool
        ( ">"
            <> concatMap show ns
            <> "</"
            <> show t
            <> ">"
        )
        ("/>")
        (null ns)

instance Hashable Element where
  toBytes = toBytes . show

-- | An element node
data Node
  = NodeCData CData
  | NodeComment Comment
  | NodeElement Element
  | NodePI PI
  deriving (Eq, Ord)

instance Show Node where
  show (NodeCData cd) = show cd
  show (NodeComment c) = show c
  show (NodeElement e) = show e
  show (NodePI p) = show p

instance Hashable Node where
  toBytes = toBytes . show

-- | A miscellaneous component
data Misc
  = MiscComment Comment
  | MiscPI PI
  | MiscSpace Space
  deriving (Eq, Ord)

instance Show Misc where
  show (MiscComment c) = show c
  show (MiscPI p) = show p
  show (MiscSpace s) = show s

instance Hashable Misc where
  toBytes = toBytes . show

-- | Element attributes
newtype Attributes = Attributes (Map Key Value)
  deriving (Eq, Ord)

-- | Values are shown within double quotes
instance Show Attributes where
  show (Attributes as) =
    Map.foldrWith
      (\k v b -> " " <> show k <> "=\"" <> show v <> "\"" <> b)
      []
      as

instance Hashable Attributes where
  toBytes = toBytes . show

-- | A processing instruction
data PI = PI Target (Maybe Instruction)
  deriving (Eq, Ord)

instance Show PI where
  show (PI t i) = "<?" <> show t <> maybe "" ((' ' :) . show) i <> "?>"

instance Hashable PI where
  toBytes = toBytes . show

-- | An element type
newtype EType = EType String
  deriving (Eq, Ord)

instance Show EType where
  show (EType t) = t

instance Hashable EType where
  toBytes = toBytes . show

-- | Character data
newtype CData = CData String
  deriving (Eq, Ord)

-- | Encodes @<&@ into predefined entities
instance Show CData where
  show (CData cd) = concatMap enc cd
   where
    enc '&' = "&amp;"
    enc '<' = "&lt;"
    enc c = [c]

instance Hashable CData where
  toBytes = toBytes . show

-- | An attribute key
newtype Key = Key String
  deriving (Eq, Ord)

instance Show Key where
  show (Key k) = k

instance Hashable Key where
  toBytes = toBytes . show

-- | An attribute value
newtype Value
  = -- | without the surrounding quotes
    Value String
  deriving (Eq, Ord)

-- | Encodes @<&"@ into predefined entities
instance Show Value where
  show (Value v) = concatMap enc v
   where
    enc '&' = "&amp;"
    enc '<' = "&lt;"
    enc '"' = "&quot;"
    enc c = [c]

instance Hashable Value where
  toBytes = toBytes . show

-- | A comment
newtype Comment
  = -- | without the leading @"<!--"@ and trailing @"-->"@
    Comment String
  deriving (Eq, Ord)

instance Show Comment where
  show (Comment c) = "<!--" <> c <> "-->"

instance Hashable Comment where
  toBytes = toBytes . show

-- | A PI target
newtype Target = Target String
  deriving (Eq, Ord)

instance Show Target where
  show (Target t) = t

instance Hashable Target where
  toBytes = toBytes . show

-- | A PI instruction
newtype Instruction = Instruction String
  deriving (Eq, Ord)

instance Show Instruction where
  show (Instruction i) = i

instance Hashable Instruction where
  toBytes = toBytes . show

-- | Miscellaneous whitespace
newtype Space = Space String
  deriving (Eq, Ord)

instance Show Space where
  show (Space s) = s

instance Hashable Space where
  toBytes = toBytes . show

-- Parsers

-- | Parse an XML document.
--
-- Enforces well-formedness constraints /Element Type Match/, /Unique Att Spec/,
-- and /Legal Character/.
--
-- Rejects documents containing a document type declaration or non-predefined
-- entity references.
--
-- Normalizes line breaks according to section 2.11 /End-of-Line Handling/.
--
-- Decodes predefined entity references and numeric references.
document :: (Monad m) => ParserT Char m Document
document = Document <$> prolog <*> element <*> many misc

-- Encoding

-- | Turn a character into a predefined or decimal reference
encode :: Char -> String
encode '&' = "&amp;"
encode '<' = "&lt;"
encode '>' = "&gt;"
encode '"' = "&quot;"
encode '\'' = "&apos;"
encode c = "&#" <> show (fromEnum c) <> ";"

-- | Parse a predefined or numeric reference into a legal character
decode :: (Monad m) => ParserT Char m Char
decode = symbol '&' *> (entityRef <|> charRef) <* symbol ';'
 where
  entityRef =
    ('&' <$ string "amp")
      <|> ('<' <$ string "lt")
      <|> ('>' <$ string "gt")
      <|> ('"' <$ string "quot")
      <|> ('\'' <$ string "apos")
  charRef = symbol '#' *> (dec <|> hex)
  dec =
    some (oneOf ['0' .. '9'])
      >>= ( \n ->
              bool
                empty
                (pure $ toEnum n)
                $ isLegal n
          )
        . foldl (\b a -> digitToInt a + b * 10) 0
        . dropWhile (== '0')
  hex =
    (symbol 'x' *> some (oneOf $ ['0' .. '9'] <> ['a' .. 'f'] <> ['A' .. 'F']))
      >>= ( \n ->
              bool
                empty
                (pure $ toEnum n)
                $ isLegal n
          )
        . foldl (\b a -> digitToInt a + (b `shiftL` 4)) 0
        . dropWhile (== '0')
  isLegal =
    ( \n ->
        n == 0x9
          || n == 0xA
          || n == 0xD
          || n >= 0x20 && n <= 0xD7FF
          || n >= 0xE000 && n <= 0xFFFD
          || n >= 0x10000 && n <= 0x10FFFF
    )
      . fromEnum

-- Helpers

char :: (Monad m) => ParserT Char m Char
char =
  ('\n' <$ string "\r\n")
    <|> ('\n' <$ symbol '\r')
    <|> ( sat $
            ( \n ->
                n == 0x9
                  || n == 0xA
                  || n >= 0x20 && n <= 0xD7FF
                  || n >= 0xE000 && n <= 0xFFFD
                  || n >= 0x10000 && n <= 0x10FFFF
            )
              . fromEnum
        )

space :: (Monad m) => ParserT Char m Space
space =
  Space
    <$> ( some . sat $
            (\n -> n == 0x20 || n == 0x9 || n == 0xD || n == 0xA) . fromEnum
        )

nameStartChar :: (Monad m) => ParserT Char m Char
nameStartChar =
  symbol ':'
    <|> oneOf ['A' .. 'Z']
    <|> symbol '_'
    <|> oneOf ['a' .. 'z']
    <|> sat
      ( ( \n ->
            n >= 0xC0 && n <= 0xD6
              || n >= 0xD8 && n <= 0xF6
              || n >= 0xF8 && n <= 0x2FF
              || n >= 0x370 && n <= 0x37D
              || n >= 0x37F && n <= 0x1FFF
              || n >= 0x200C && n <= 0x200D
              || n >= 0x2070 && n <= 0x218F
              || n >= 0x2C00 && n <= 0x2FEF
              || n >= 0x3001 && n <= 0xD7FF
              || n >= 0xF900 && n <= 0xFDCF
              || n >= 0xFDF0 && n <= 0xFFFD
              || n >= 0x10000 && n <= 0xEFFFF
        )
          . fromEnum
      )

nameChar :: (Monad m) => ParserT Char m Char
nameChar =
  nameStartChar
    <|> symbol '-'
    <|> symbol '.'
    <|> oneOf ['0' .. '9']
    <|> sat
      ( ( \n ->
            n == 0xB7
              || n >= 0x0300 && n <= 0x036F
              || n >= 0x203F && n <= 0x2040
        )
          . fromEnum
      )

name :: (Monad m) => ParserT Char m String
name = (:) <$> nameStartChar <*> many nameChar

value :: (Monad m) => ParserT Char m Value
value =
  Value
    <$> ( (doubleQuoted $ many (noneOf "<&\"" <|> decode))
            <|> (singleQuoted $ many (noneOf "<&'" <|> decode))
        )

cData :: (Monad m) => ParserT Char m CData
cData = CData <$> (some $ reject (string "]]>") *> exclude "<&")

comment :: (Monad m) => ParserT Char m Comment
comment =
  Comment
    <$> ( string "<!--"
            *> many (reject (string "--") *> char)
            <* string "-->"
        )

pi :: (Monad m) => ParserT Char m PI
pi =
  PI
    <$> (string "<?" *> target)
    <*> optional
      (Instruction <$> (space *> many (reject (string "?>") *> char)))
    <* string "?>"

target :: (Monad m) => ParserT Char m Target
target = Target <$> (reject (oneOf "Xx" *> oneOf "Mm" *> oneOf "Ll") *> name)

cdSect :: (Monad m) => ParserT Char m CData
cdSect = CData <$> (string "<![CDATA[" *> (char `till` string "]]>"))

-- NOTE: rejecting doctypedecl
prolog :: (Monad m) => ParserT Char m [Misc]
prolog = optional xmlDecl *> many misc

xmlDecl :: (Monad m) => ParserT Char m ()
xmlDecl =
  ()
    <$ ( string "<?xml"
           *> versionInfo
           *> optional encodingDecl
           *> optional sdDecl
           *> optional space
           *> string "?>"
       )

versionInfo :: (Monad m) => ParserT Char m ()
versionInfo =
  ()
    <$ ( space
           *> string "version"
           *> eq
           *> (doubleQuoted versionNum <|> singleQuoted versionNum)
       )

eq :: (Monad m) => ParserT Char m Char
eq = optional space *> symbol '=' <* optional space

versionNum :: (Monad m) => ParserT Char m ()
versionNum = () <$ (string "1." *> some (oneOf ['0' .. '9']))

misc :: (Monad m) => ParserT Char m Misc
misc =
  (MiscComment <$> comment)
    <|> (MiscPI <$> pi)
    <|> (MiscSpace <$> space)

sdDecl :: (Monad m) => ParserT Char m ()
sdDecl =
  ()
    <$ ( space
           *> string "standalone"
           *> eq
           *> ( doubleQuoted (string "yes" <|> string "no")
                  <|> singleQuoted (string "yes" <|> string "no")
              )
       )

element :: (Monad m) => ParserT Char m Element
element = do
  t <- symbol '<' *> (EType <$> name)
  as <- attributes
  (Element t as [] <$ string "/>")
    <|> ( do
            ns <- symbol '>' *> nodes
            t' <-
              string "</"
                *> (EType <$> name)
                <* optional space
                <* symbol '>'
            bool
              empty
              (pure $ Element t as ns)
              $ t == t'
        )

attributes :: (Monad m) => ParserT Char m Attributes
attributes = (many (space *> attribute) <* optional space) >>= go mempty
 where
  go t ((k, v) : as) = bool (go (Map.insert k v t) as) empty $ k `Map.member` t
  go t [] = pure $ Attributes t

attribute :: (Monad m) => ParserT Char m (Key, Value)
attribute = (,) <$> (Key <$> name) <* eq <*> value

nodes :: (Monad m) => ParserT Char m [Node]
nodes = go <$> many node
 where
  go (NodeCData (CData cd) : NodeCData (CData cd') : rest) =
    NodeCData (CData $ cd <> cd') : go rest
  go (n : ns) = n : go ns
  go [] = []

node :: (Monad m) => ParserT Char m Node
node =
  ( NodeCData
      <$> ( cData
              <|> (CData <$> (pure <$> decode))
              <|> cdSect
          )
  )
    <|> (NodeComment <$> comment)
    <|> (NodeElement <$> element)
    <|> (NodePI <$> pi)

encodingDecl :: (Monad m) => ParserT Char m ()
encodingDecl =
  ()
    <$ ( space
           *> string "encoding"
           *> eq
           *> (doubleQuoted encName <|> singleQuoted encName)
       )

encName :: (Monad m) => ParserT Char m ()
encName =
  ()
    <$ ( (:)
           <$> oneOf (['A' .. 'Z'] <> ['a' .. 'z'])
           <*> many
             ( oneOf
                 ( ['A' .. 'Z']
                     <> ['a' .. 'z']
                     <> ['0' .. '9']
                     <> "._-"
                 )
             )
       )

doubleQuoted :: (Monad m) => ParserT Char m a -> ParserT Char m a
doubleQuoted p = symbol '"' *> p <* symbol '"'

singleQuoted :: (Monad m) => ParserT Char m a -> ParserT Char m a
singleQuoted p = symbol '\'' *> p <* symbol '\''

exclude :: (Monad m) => String -> ParserT Char m Char
exclude str = accept (noneOf str) *> char