{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module: Vestigia.Xml
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- A reader for the XML memcheck writes: elements and text, with
-- the declaration, comments, and attributes skipped and the
-- standard entities decoded. It is not a general XML parser, and
-- refuses what it does not understand rather than guessing.

module Vestigia.Xml (
    Node(..)
  , parseDocument
  , children
  , child
  , textOf
  ) where

import Data.Char (chr, isAlphaNum, isDigit, isHexDigit, isSpace)
import qualified Data.Text as T
import Numeric (readDec, readHex)

-- | An element (its name and contents) or a run of text.
data Node =
    Element !T.Text ![Node]
  | Text !T.Text
  deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
/= :: Node -> Node -> Bool
Eq, Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show)

-- | The document's root element.
--
-- >>> parseDocument "<?xml version=\"1.0\"?><a><b>x &amp; y</b></a>"
-- Right (Element "a" [Element "b" [Text "x & y"]])
parseDocument :: T.Text -> Either String Node
parseDocument :: Text -> Either String Node
parseDocument Text
t = do
  (root, rest) <- Text -> Either String (Node, Text)
element (Text -> Text
misc Text
t)
  if T.null (misc rest)
    then pure root
    else Left "trailing content after the root element"

-- | The child elements of a node with the given name.
children :: T.Text -> Node -> [Node]
children :: Text -> Node -> [Node]
children Text
name Node
n = case Node
n of
  Element Text
_ [Node]
cs -> [ Node
c | c :: Node
c@(Element Text
m [Node]
_) <- [Node]
cs, Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name ]
  Text Text
_ -> []

-- | The first child element with the given name.
child :: T.Text -> Node -> Maybe Node
child :: Text -> Node -> Maybe Node
child Text
name Node
n = case Text -> Node -> [Node]
children Text
name Node
n of
  (Node
c : [Node]
_) -> Node -> Maybe Node
forall a. a -> Maybe a
Just Node
c
  [] -> Maybe Node
forall a. Maybe a
Nothing

-- | The text a node holds, stripped.
textOf :: Node -> T.Text
textOf :: Node -> Text
textOf Node
n = case Node
n of
  Text Text
t -> Text -> Text
T.strip Text
t
  Element Text
_ [Node]
cs -> Text -> Text
T.strip ([Text] -> Text
T.concat [ Text
t | Text Text
t <- [Node]
cs ])

-- whitespace, the declaration, comments, and a doctype
misc :: T.Text -> T.Text
misc :: Text -> Text
misc Text
t0 =
  let t :: Text
t = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t0
  in if Text
"<?" Text -> Text -> Bool
`T.isPrefixOf` Text
t then Text -> Text
misc (Text -> Text -> Text
after Text
"?>" Text
t)
     else if Text
"<!--" Text -> Text -> Bool
`T.isPrefixOf` Text
t then Text -> Text
misc (Text -> Text -> Text
after Text
"-->" Text
t)
     else if Text
"<!" Text -> Text -> Bool
`T.isPrefixOf` Text
t then Text -> Text
misc (Text -> Text -> Text
after Text
">" Text
t)
     else Text
t

after :: T.Text -> T.Text -> T.Text
after :: Text -> Text -> Text
after Text
delim Text
t = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
delim) ((Text, Text) -> Text
forall a b. (a, b) -> b
snd (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
delim Text
t))

element :: T.Text -> Either String (Node, T.Text)
element :: Text -> Either String (Node, Text)
element Text
t0 = case Text -> Maybe (Char, Text)
T.uncons Text
t0 of
  Just (Char
'<', Text
t1) -> do
    let (Text
name, Text
t2) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
nameChar Text
t1
    if Text -> Bool
T.null Text
name then String -> Either String (Node, Text)
forall a b. a -> Either a b
Left String
"an element without a name" else do
      let t3 :: Text
t3 = Text -> Text
skipAttributes Text
t2
      if Text
"/>" Text -> Text -> Bool
`T.isPrefixOf` Text
t3
        then (Node, Text) -> Either String (Node, Text)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Node] -> Node
Element Text
name [], Int -> Text -> Text
T.drop Int
2 Text
t3)
        else case Text -> Maybe (Char, Text)
T.uncons Text
t3 of
          Just (Char
'>', Text
t4) -> do
            (cs, t5) <- Text -> Text -> [Node] -> Either String ([Node], Text)
content Text
name Text
t4 []
            pure (Element name (reverse cs), t5)
          Maybe (Char, Text)
_ -> String -> Either String (Node, Text)
forall a b. a -> Either a b
Left (String
"malformed start tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
  Maybe (Char, Text)
_ -> String -> Either String (Node, Text)
forall a b. a -> Either a b
Left String
"expected an element"

-- attributes carry nothing memcheck's reader needs
skipAttributes :: T.Text -> T.Text
skipAttributes :: Text -> Text
skipAttributes Text
t = case Text -> Maybe (Char, Text)
T.uncons ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t) of
  Just (Char
c, Text
_) | 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
'/' -> (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t
  Just (Char, Text)
_ ->
    let t1 :: Text
t1 = (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> 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
'/')
               ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t)
    in case Text -> Maybe (Char, Text)
T.uncons Text
t1 of
         Just (Char
'"', Text
t2) ->
           Text -> Text
skipAttributes (Int -> Text -> Text
T.drop Int
1 ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') Text
t2))
         Maybe (Char, Text)
_ -> Text
t1
  Maybe (Char, Text)
Nothing -> Text
t

content
  :: T.Text -> T.Text -> [Node] -> Either String ([Node], T.Text)
content :: Text -> Text -> [Node] -> Either String ([Node], Text)
content Text
name Text
t [Node]
acc
  | Text -> Bool
T.null Text
t = String -> Either String ([Node], Text)
forall a b. a -> Either a b
Left (String
"unclosed element: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
  | Text
"</" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
      let (Text
close, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
nameChar (Int -> Text -> Text
T.drop Int
2 Text
t)
          rest' :: Text
rest' = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
rest
      in if Text
close Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
name
           then String -> Either String ([Node], Text)
forall a b. a -> Either a b
Left (String
"mismatched close tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
close)
           else case Text -> Maybe (Char, Text)
T.uncons Text
rest' of
             Just (Char
'>', Text
r) -> ([Node], Text) -> Either String ([Node], Text)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node]
acc, Text
r)
             Maybe (Char, Text)
_ -> String -> Either String ([Node], Text)
forall a b. a -> Either a b
Left (String
"malformed close tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
close)
  | Text
"<!--" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text -> Text -> [Node] -> Either String ([Node], Text)
content Text
name (Text -> Text -> Text
after Text
"-->" Text
t) [Node]
acc
  | Text
"<" Text -> Text -> Bool
`T.isPrefixOf` Text
t = do
      (n, rest) <- Text -> Either String (Node, Text)
element Text
t
      content name rest (n : acc)
  | Bool
otherwise = do
      let (Text
raw, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<') Text
t
      txt <- Text -> Either String Text
entities Text
raw
      content name rest (Text txt : acc)

nameChar :: Char -> Bool
nameChar :: Char -> Bool
nameChar Char
c = Char -> Bool
isAlphaNum 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
'.'
  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'

entities :: T.Text -> Either String T.Text
entities :: Text -> Either String Text
entities Text
t = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"&" Text
t of
  (Text
pre, Text
rest)
    | Text -> Bool
T.null Text
rest -> Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
pre
    | Bool
otherwise -> do
        let (Text
ent, Text
rest') = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
";" (Int -> Text -> Text
T.drop Int
1 Text
rest)
        if Text -> Bool
T.null Text
rest' then String -> Either String Text
forall a b. a -> Either a b
Left String
"an unterminated entity" else do
          c <- Text -> Either String Char
entity Text
ent
          more <- entities (T.drop 1 rest')
          pure (pre <> T.singleton c <> more)

entity :: T.Text -> Either String Char
entity :: Text -> Either String Char
entity Text
e = case Text -> String
T.unpack Text
e of
  String
"amp" -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'&'
  String
"lt" -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'<'
  String
"gt" -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'>'
  String
"quot" -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'"'
  String
"apos" -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\''
  (Char
'#' : Char
'x' : String
hs) | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hs), (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit String
hs ->
    [(Int, String)] -> Either String Char
forall {a}. (Eq a, IsString a) => [(Int, a)] -> Either String Char
code (ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
hs)
  (Char
'#' : String
ds) | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds), (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
ds -> [(Int, String)] -> Either String Char
forall {a}. (Eq a, IsString a) => [(Int, a)] -> Either String Char
code (ReadS Int
forall a. (Eq a, Num a) => ReadS a
readDec String
ds)
  String
_ -> String -> Either String Char
forall a b. a -> Either a b
Left (String
"an unknown entity: &" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
";")
  where
    code :: [(Int, a)] -> Either String Char
code [(Int, a)]
rs = case [(Int, a)]
rs of
      [ (Int
n, a
"") ] | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF -> Char -> Either String Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Char
chr Int
n)
      [(Int, a)]
_ -> String -> Either String Char
forall a b. a -> Either a b
Left (String
"a malformed character reference: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
e)