xml-syntax-0.1.0.1: src/Xml.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}

module Xml
  ( Node (..)
  , Content (..)
  , Attribute (..)
  , decode
  ) where

import Data.Builder.ST (Builder)
import Data.Bytes (Bytes)
import Data.Bytes.Parser (Parser)
import Data.Chunks (Chunks)
import Data.Primitive (SmallArray)
import Data.Text.Short (ShortText)
import Data.Word (Word8)
import GHC.Exts (Char (C#), Char#)

import qualified Data.Builder.ST as Builder
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Parser as Parser
import qualified Data.Bytes.Parser.Latin as Latin
import qualified Data.Bytes.Parser.Rebindable as R
import qualified Data.Bytes.Parser.Unsafe as Unsafe
import qualified Data.Bytes.Parser.Utf8 as Utf8
import qualified Data.Chunks as Chunks
import qualified Data.Text.Short as TS
import qualified Data.Text.Short.Unsafe as TS

data Node
  = Text !ShortText
  | Element {-# UNPACK #-} !Content
  deriving (Show, Eq)

data Content = Content
  { tag :: !ShortText
  , attributes :: !(SmallArray Attribute)
  , children :: !(SmallArray Node)
  }
  deriving (Show, Eq)

data Attribute = Attribute
  { name :: !ShortText
  , value :: !ShortText
  }
  deriving (Show, Eq)

decode :: Bytes -> Maybe Node
decode !b = Parser.parseBytesMaybe elementNodeParser b

elementNodeParser :: Parser () s Node
elementNodeParser = do
  Latin.char () '<'
  btag <- Parser.takeWhile (\w -> not (isXmlSpace w) && w /= 0x3E && w /= 0x2F)
  case Bytes.length btag of
    0 -> Parser.fail ()
    _ -> pure ()
  tag <- case TS.fromShortByteString (Bytes.toShortByteStringClone btag) of
    Nothing -> Parser.fail ()
    Just ttag -> pure ttag
  -- Note that parserAttributes consumes leading and trailing whitespace.
  attrs <- parserAttributes =<< Parser.effect Builder.new
  let !attributes = Chunks.concat attrs
  Latin.any () >>= \case
    '>' -> do
      nodes <- childrenParser tag
      pure (Element Content {tag, attributes, children = Chunks.concat nodes})
    '/' -> do
      Latin.char () '>'
      pure (Element Content {tag, attributes, children = mempty})
    _ -> Parser.fail ()

textNodeParser :: Parser () s Node
textNodeParser = do
  raw <- Parser.takeWhile (\w -> w /= 0x3C)
  case Bytes.any (\w -> w > 0x7F || w == 0x26) raw of
    True -> Parser.fail () -- TODO: escape or check UTF-8 encoding here instead
    False -> pure (Text (TS.fromShortByteStringUnsafe (Bytes.toShortByteStringClone raw)))

-- This eats the closing tag as well.
childrenParser ::
  ShortText -> -- opening tag name, looking for a closing tag that matches
  Parser () s (Chunks Node)
childrenParser !tag = do
  b0 <- Parser.effect Builder.new
  childrenParserLoop tag b0

childrenParserLoop ::
  ShortText -> -- opening tag name, looking for a closing tag that matches
  Builder s Node ->
  Parser () s (Chunks Node)
childrenParserLoop !tag !b0 =
  Latin.any () >>= \case
    '<' ->
      Latin.any () >>= \case
        '/' -> do
          Utf8.shortText () tag
          Parser.skipWhile isXmlSpace
          Latin.char () '>'
          Parser.effect (Builder.freeze b0)
        _ -> do
          Unsafe.unconsume 2
          node <- elementNodeParser
          b1 <- Parser.effect (Builder.push node b0)
          childrenParserLoop tag b1
    _ -> do
      Unsafe.unconsume 1
      node <- textNodeParser
      b1 <- Parser.effect (Builder.push node b0)
      childrenParserLoop tag b1

isXmlSpace :: Word8 -> Bool
isXmlSpace = \case
  0x20 -> True
  0x09 -> True
  0x0D -> True
  0x0A -> True
  _ -> False

parserAttributes :: Builder s Attribute -> Parser () s (Chunks Attribute)
parserAttributes !b0 = do
  Parser.skipWhile isXmlSpace
  peekIsNameStartChar >>= \case
    True -> do
      attr <- parserAttribute
      b1 <- Parser.effect (Builder.push attr b0)
      parserAttributes b1
    False -> do
      Parser.skipWhile isXmlSpace
      Parser.effect (Builder.freeze b0)

-- From the spec, we have:
--   Attribute ::= Name Eq AttValue
--   Eq        ::= S? '=' S?
--   Name      ::= NameStartChar (NameChar)*
--
-- Precondition A: The first character is a NameStartChar. This parser
-- does not check this.
parserAttribute :: Parser () s Attribute
parserAttribute = do
  bname <- Parser.takeWhile (\w -> not (isXmlSpace w) && w /= 0x3D)
  -- We may assume that length of bname is at least one because of
  -- precondition A.
  !name <- case TS.fromShortByteString (Bytes.toShortByteStringClone bname) of
    Nothing -> Parser.fail ()
    Just tname -> pure tname
  Parser.skipWhile isXmlSpace
  Latin.char () '='
  Parser.skipWhile isXmlSpace
  !value <- parserAttributeValue
  pure Attribute {name, value}

-- TODO: This is woefully incomplete
parserAttributeValue :: Parser () s ShortText
parserAttributeValue = do
  Latin.any () >>= \case
    '"' -> do
      bval <- Parser.takeWhile (\w -> w /= 0x22)
      Latin.char () '"'
      case TS.fromShortByteString (Bytes.toShortByteStringClone bval) of
        Nothing -> Parser.fail ()
        Just tval -> pure tval
    '\'' -> do
      bval <- Parser.takeWhile (\w -> w /= 0x27)
      Latin.char () '\''
      case TS.fromShortByteString (Bytes.toShortByteStringClone bval) of
        Nothing -> Parser.fail ()
        Just tval -> pure tval
    _ -> Parser.fail ()

peekIsNameStartChar :: Parser () s Bool
peekIsNameStartChar =
  Unsafe.cursor R.>>= \pos ->
    Utf8.any# () R.>>= \c ->
      Unsafe.jump pos R.>>= \_ ->
        R.pure (isNameStartChar c)

isNameStartChar :: Char# -> Bool
isNameStartChar c = case C# c of
  ':' -> True
  '_' -> True
  _ | C# c >= 'A' && C# c <= 'Z' -> True
  _ | C# c >= 'a' && C# c <= 'z' -> True
  _ -> False