{-# LANGUAGE OverloadedStrings #-}

module Text.XmlHtml.XML.Parse where

import           Control.Applicative
import           Control.Monad
import           Data.Char
import           Data.List
import           Data.Maybe
import           Text.XmlHtml.Common
import           Text.XmlHtml.TextParser

import qualified Text.Parsec as P

import           Data.Map (Map)
import qualified Data.Map as M

import           Data.Text (Text)
import qualified Data.Text as T


------------------------------------------------------------------------------
-- | This is my best guess as to the best rule for handling document fragments
-- for processing.  It is essentially modeled after document, but allowing
-- multiple nodes.
docFragment :: Encoding -> Parser Document
docFragment :: Encoding -> Parser Document
docFragment Encoding
e = do
    (dt, nodes1) <- Parser (Maybe DocType, [Node])
prolog
    nodes2       <- content
    return $ XmlDocument e dt (nodes1 ++ nodes2)


------------------------------------------------------------------------------
-- Everything from here forward is translated from the XML specification.   --
------------------------------------------------------------------------------

{-
    Map from numbered productions in the XML specification to symbols here:

    PROD  SPEC NAME          PARSER NAME           NOTES
    -----|------------------|---------------------|-------
    [1]   document           document
    [2]   Char                                     {2}
    [3]   S                  whiteSpace
    [4]   NameStartChar      isNameStartChar       {1}
    [4a]  NameChar           isNameChar            {1}
    [5]   Name               name
    [6]   Names              names
    [7]   Nmtoken            nmtoken
    [8]   Nmtokens           nmtokens
    [9]   EntityValue                              {4}
    [10]  AttValue           attrValue
    [11]  SystemLiteral      systemLiteral
    [12]  PubidLiteral       pubIdLiteral
    [13]  PubidChar          isPubIdChar           {1}
    [14]  CharData           charData
    [15]  Comment            comment
    [16]  PI                 processingInstruction
    [17]  PITarget           piTarget
    [18]  CDSect             cdSect
    [19]  CDStart            cdSect                {3}
    [20]  CData              cdSect                {3}
    [21]  CDEnd              cdSect                {3}
    [22]  prolog             prolog
    [23]  XMLDecl            xmlDecl
    [24]  VersionInfo        versionInfo
    [25]  Eq                 eq
    [26]  VersionNum         versionInfo           {3}
    [27]  Misc               misc
    [28]  doctypedecl        docTypeDecl
    [28a] DeclSep                                  {4}
    [28b] intSubset                                {4}
    [29]  markupdecl                               {4}
    [30]  extSubset                                {4}
    [31]  extSubsetDecl                            {4}
    [32]  SDDecl             sdDecl
    [39]  element            element
    [40]  STag               emptyOrStartTag
    [41]  Attribute          attribute
    [42]  ETag               endTag
    [43]  content            content
    [44]  EmptyElemTag       emptyOrStartTag
    [45]  elementDecl                              {4}
    [46]  contentSpec                              {4}
    [47]  children                                 {4}
    [48]  cp                                       {4}
    [49]  choice                                   {4}
    [50]  seq                                      {4}
    [51]  Mixed                                    {4}
    [52]  AttlistDecl                              {4}
    [53]  AttDef                                   {4}
    [54]  AttType                                  {4}
    [55]  StringType                               {4}
    [56]  TokenizedType                            {4}
    [57]  EnumeratedType                           {4}
    [58]  NotationType                             {4}
    [59]  Enumeration                              {4}
    [60]  DefaultDecl                              {4}
    [61]  conditionalSect                          {4}
    [62]  includeSect                              {4}
    [63]  ignoreSect                               {4}
    [64]  ignoreSectContents                       {4}
    [65]  Ignore                                   {4}
    [66]  CharRef            charRef
    [67]  Reference          reference
    [68]  EntityRef          entityRef
    [69]  PEReference                              {4}
    [70]  EntityDecl                               {4}
    [71]  GEDecl                                   {4}
    [72]  PEDecl                                   {4}
    [73]  EntityDef                                {4}
    [74]  PEDef                                    {4}
    [75]  ExternalID         externalID
    [76]  NDataDecl                                {4}
    [77]  TextDecl           textDecl
    [78]  extParsedEnt       extParsedEnt
    [80]  EncodingDecl       encodingDecl
    [81]  EncName            encodingDecl          {3}
    [82]  NotationDecl                             {4}
    [83]  PublicID                                 {4}
    [84]  Letter                                   {5}
    [85]  BaseChar                                 {5}
    [86]  Ideographic                              {5}
    [87]  CombiningChar                            {5}
    [88]  Digit                                    {5}
    [89]  Extender                                 {5}

    Notes:
        {1} - These productions match single characters, and so are
              implemented as predicates instead of parsers.
        {3} - Denotes a production which is not exposed as a top-level symbol
              because it is trivial and included in another definition.
        {4} - This module does not contain a parser for the DTD subsets, so
              grammar that occurs only in DTD subsets is not defined.
        {5} - These are orphaned productions for character classes.
-}


------------------------------------------------------------------------------
whiteSpace :: Parser ()
whiteSpace :: Parser ()
whiteSpace = ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ',Char
'\t',Char
'\r',Char
'\n'])) ParsecT Text () Identity String -> Parser () -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


------------------------------------------------------------------------------
isNameStartChar :: Char -> Bool
isNameStartChar :: Char -> Bool
isNameStartChar Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'                         = Bool
True
                  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'                         = Bool
True
                  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a'       Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z'       = Bool
True
                  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A'       Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z'       = Bool
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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
True
                  | 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' = Bool
True
                  | Bool
otherwise                        = Bool
False


------------------------------------------------------------------------------
isNameChar :: Char -> Bool
isNameChar :: Char -> Bool
isNameChar Char
c | Char -> Bool
isNameStartChar Char
c                = Bool
True
             | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'                         = Bool
True
             | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'                         = Bool
True
             | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xb7'                      = Bool
True
             | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0'       Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'       = Bool
True
             | 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
True
             | 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'  = Bool
True
             | Bool
otherwise                        = Bool
False


------------------------------------------------------------------------------
name :: Parser Text
name :: Parser Text
name = do
    c <- (Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy Char -> Bool
isNameStartChar
    r <- takeWhile0 isNameChar
    return $ T.cons c r


------------------------------------------------------------------------------
attrValue :: Parser Text
attrValue :: Parser Text
attrValue = ([Text] -> Text) -> ParsecT Text () Identity [Text] -> Parser Text
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
T.concat (ParsecT Text () Identity [Text]
singleQuoted ParsecT Text () Identity [Text]
-> ParsecT Text () Identity [Text]
-> ParsecT Text () Identity [Text]
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text () Identity [Text]
doubleQuoted)
  where
    singleQuoted :: ParsecT Text () Identity [Text]
singleQuoted = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\'' ParsecT Text () Identity Char
-> ParsecT Text () Identity [Text]
-> ParsecT Text () Identity [Text]
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT Text () Identity [Text]
forall {t :: * -> *}.
Foldable t =>
t Char -> ParsecT Text () Identity [Text]
refTill [Char
'<',Char
'&',Char
'\''] ParsecT Text () Identity [Text]
-> ParsecT Text () Identity Char -> ParsecT Text () Identity [Text]
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\''
    doubleQuoted :: ParsecT Text () Identity [Text]
doubleQuoted = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'"'  ParsecT Text () Identity Char
-> ParsecT Text () Identity [Text]
-> ParsecT Text () Identity [Text]
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT Text () Identity [Text]
forall {t :: * -> *}.
Foldable t =>
t Char -> ParsecT Text () Identity [Text]
refTill [Char
'<',Char
'&',Char
'"']  ParsecT Text () Identity [Text]
-> ParsecT Text () Identity Char -> ParsecT Text () Identity [Text]
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'"'
    refTill :: t Char -> ParsecT Text () Identity [Text]
refTill t Char
end = Parser Text -> ParsecT Text () Identity [Text]
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Text
takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> t Char -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
end)) Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
reference)


------------------------------------------------------------------------------
systemLiteral :: Parser Text
systemLiteral :: Parser Text
systemLiteral = Parser Text
singleQuoted Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
doubleQuoted
  where
    singleQuoted :: Parser Text
singleQuoted = do
        _ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\''
        x <- takeWhile0 (not . (== '\''))
        _ <- P.char '\''
        return x
    doubleQuoted :: Parser Text
doubleQuoted = do
        _ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"'
        x <- takeWhile0 (not . (== '\"'))
        _ <- P.char '\"'
        return x


------------------------------------------------------------------------------
pubIdLiteral :: Parser Text
pubIdLiteral :: Parser Text
pubIdLiteral = Parser Text
singleQuoted Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
doubleQuoted
  where
    singleQuoted :: Parser Text
singleQuoted = do
        _ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\''
        x <- takeWhile0 (\Char
c -> Char -> Bool
isPubIdChar Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'')
        _ <- P.char '\''
        return x
    doubleQuoted :: Parser Text
doubleQuoted = do
        _ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"'
        x <- takeWhile0 isPubIdChar
        _ <- P.char '\"'
        return x


------------------------------------------------------------------------------
isPubIdChar :: Char -> Bool
isPubIdChar :: Char -> Bool
isPubIdChar Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z'                 = Bool
True
              | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z'                 = Bool
True
              | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'                 = Bool
True
              | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
otherChars                  = Bool
True
              | Bool
otherwise                            = Bool
False
  where
    otherChars :: String
otherChars = String
" \r\n-\'()+,./:=?;!*#@$_%" :: [Char]

------------------------------------------------------------------------------
-- | The requirement to not contain "]]>" is for SGML compatibility.  We
-- deliberately choose to not enforce it.  This makes the parser accept
-- strictly more documents than a standards-compliant parser.
charData :: Parser Node
charData :: Parser Node
charData = Text -> Node
TextNode (Text -> Node) -> Parser Text -> Parser Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'<',Char
'&']))


------------------------------------------------------------------------------
comment :: Parser (Maybe Node)
comment :: Parser (Maybe Node)
comment = Text -> Parser Text
text Text
"<!--" Parser Text -> Parser (Maybe Node) -> Parser (Maybe Node)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> (Text -> Node) -> Text -> Maybe Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Node
Comment (Text -> Maybe Node) -> Parser Text -> Parser (Maybe Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
commentText) Parser (Maybe Node) -> Parser Text -> Parser (Maybe Node)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
text Text
"-->"
  where
    commentText :: Parser Text
commentText = ([Text] -> Text) -> ParsecT Text () Identity [Text] -> Parser Text
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
T.concat (ParsecT Text () Identity [Text] -> Parser Text)
-> ParsecT Text () Identity [Text] -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser Text -> ParsecT Text () Identity [Text]
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text -> ParsecT Text () Identity [Text])
-> Parser Text -> ParsecT Text () Identity [Text]
forall a b. (a -> b) -> a -> b
$
        Parser Text
nonDash Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text -> Parser Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (Char -> Text -> Text
T.cons (Char -> Text -> Text)
-> ParsecT Text () Identity Char
-> ParsecT Text () Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'-' ParsecT Text () Identity (Text -> Text)
-> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity (a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
nonDash)
    nonDash :: Parser Text
nonDash = (Char -> Bool) -> Parser Text
takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'))


------------------------------------------------------------------------------
-- | Always returns Nothing since there's no representation for a PI in the
-- document tree.
processingInstruction :: Parser (Maybe Node)
processingInstruction :: Parser (Maybe Node)
processingInstruction = do
    _ <- Text -> Parser Text
text Text
"<?"
    _ <- piTarget
    _ <- emptyEnd <|> contentEnd
    return Nothing
  where
    emptyEnd :: ParsecT Text u Identity String
emptyEnd   = ParsecT Text u Identity String -> ParsecT Text u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (String -> ParsecT Text u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"?>")
    contentEnd :: ParsecT Text () Identity String
contentEnd = ParsecT Text () Identity String -> ParsecT Text () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT Text () Identity String
 -> ParsecT Text () Identity String)
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall a b. (a -> b) -> a -> b
$ do
        _ <- Parser ()
whiteSpace
        P.manyTill P.anyChar (P.try $ text "?>")

------------------------------------------------------------------------------
piTarget :: Parser ()
piTarget :: Parser ()
piTarget = do
    n <- Parser Text
name
    when (T.map toLower n == "xml") $ fail "xml declaration can't occur here"


------------------------------------------------------------------------------
cdata :: [Char] -> Parser a -> Parser Node
cdata :: forall a. String -> Parser a -> Parser Node
cdata String
cs Parser a
end = Text -> Node
TextNode (Text -> Node) -> ([Text] -> Text) -> [Text] -> Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Text
T.concat ([Text] -> Node) -> ParsecT Text () Identity [Text] -> Parser Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser a -> ParsecT Text () Identity [Text]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
P.manyTill Parser Text
part Parser a
end
  where part :: Parser Text
part = (Char -> Bool) -> Parser Text
takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs))
             Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Text
T.singleton (Char -> Text) -> ParsecT Text () Identity Char -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.anyChar


------------------------------------------------------------------------------
cdSect :: Parser (Maybe Node)
cdSect :: Parser (Maybe Node)
cdSect = Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Parser Node -> Parser (Maybe Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    _ <- Text -> Parser Text
text Text
"<![CDATA["
    cdata "]" (text "]]>")


------------------------------------------------------------------------------
prolog :: Parser (Maybe DocType, [Node])
prolog :: Parser (Maybe DocType, [Node])
prolog = do
    _      <- ParsecT Text () Identity (Maybe Text)
-> ParsecT Text () Identity (Maybe (Maybe Text))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Text () Identity (Maybe Text)
xmlDecl
    nodes1 <- many misc
    rest   <- optional $ do
        dt     <- docTypeDecl
        nodes2 <- many misc
        return (dt, nodes2)
    case rest of
        Maybe (DocType, [Maybe Node])
Nothing           -> (Maybe DocType, [Node]) -> Parser (Maybe DocType, [Node])
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DocType
forall a. Maybe a
Nothing, [Maybe Node] -> [Node]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Node]
nodes1)
        Just (DocType
dt, [Maybe Node]
nodes2) -> (Maybe DocType, [Node]) -> Parser (Maybe DocType, [Node])
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DocType -> Maybe DocType
forall a. a -> Maybe a
Just DocType
dt, [Maybe Node] -> [Node]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Node]
nodes1 [Maybe Node] -> [Maybe Node] -> [Maybe Node]
forall a. [a] -> [a] -> [a]
++ [Maybe Node]
nodes2))


------------------------------------------------------------------------------
-- | Return value is the encoding, if present.
xmlDecl :: Parser (Maybe Text)
xmlDecl :: ParsecT Text () Identity (Maybe Text)
xmlDecl = do
    _ <- Text -> Parser Text
text Text
"<?xml"
    _ <- versionInfo
    e <- optional encodingDecl
    _ <- optional sdDecl
    _ <- optional whiteSpace
    _ <- text "?>"
    return e


------------------------------------------------------------------------------
versionInfo :: Parser ()
versionInfo :: Parser ()
versionInfo = do
    Parser ()
whiteSpace Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
text Text
"version" Parser Text -> Parser () -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
eq Parser () -> Parser () -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser ()
singleQuoted Parser () -> Parser () -> Parser ()
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
doubleQuoted)
  where
    singleQuoted :: Parser ()
singleQuoted = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\'' ParsecT Text () Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
versionNum Parser () -> ParsecT Text () Identity Char -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\''
    doubleQuoted :: Parser ()
doubleQuoted = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"' ParsecT Text () Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
versionNum Parser () -> ParsecT Text () Identity Char -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"'
    versionNum :: Parser ()
versionNum   = do
        _ <- Text -> Parser Text
text Text
"1."
        _ <- some (P.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'))
        return ()


------------------------------------------------------------------------------
eq :: Parser ()
eq :: Parser ()
eq = Parser () -> ParsecT Text () Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
whiteSpace ParsecT Text () Identity (Maybe ())
-> ParsecT Text () Identity Char -> ParsecT Text () Identity Char
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'=' ParsecT Text () Identity Char
-> ParsecT Text () Identity (Maybe ())
-> ParsecT Text () Identity (Maybe ())
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Text () Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
whiteSpace ParsecT Text () Identity (Maybe ()) -> Parser () -> Parser ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


------------------------------------------------------------------------------
misc :: Parser (Maybe Node)
misc :: Parser (Maybe Node)
misc = Parser (Maybe Node)
comment Parser (Maybe Node) -> Parser (Maybe Node) -> Parser (Maybe Node)
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Maybe Node)
processingInstruction Parser (Maybe Node) -> Parser (Maybe Node) -> Parser (Maybe Node)
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ()
whiteSpace Parser () -> Parser (Maybe Node) -> Parser (Maybe Node)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Node -> Parser (Maybe Node)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Node
forall a. Maybe a
Nothing)


------------------------------------------------------------------------------
-- | Internal subset is parsed, but ignored since we don't have data types to
-- store it.
docTypeDecl :: Parser DocType
docTypeDecl :: Parser DocType
docTypeDecl = do
    _      <- Text -> Parser Text
text Text
"<!DOCTYPE"
    whiteSpace
    tag    <- name
    _      <- optional whiteSpace
    extid  <- externalID
    _      <- optional whiteSpace
    intsub <- internalDoctype
    _      <- P.char '>'
    return (DocType tag extid intsub)


------------------------------------------------------------------------------
-- | States for the DOCTYPE internal subset state machine.
data InternalDoctypeState = IDSStart
                          | IDSScanning Int
                          | IDSInQuote Int Char
                          | IDSCommentS1 Int
                          | IDSCommentS2 Int
                          | IDSCommentS3 Int
                          | IDSComment Int
                          | IDSCommentD1 Int
                          | IDSCommentE1 Int


------------------------------------------------------------------------------
-- | Internal DOCTYPE subset.  We don't actually parse this; just scan through
-- and look for the end, and store it in a block of text.
internalDoctype :: Parser InternalSubset
internalDoctype :: Parser InternalSubset
internalDoctype = Text -> InternalSubset
InternalText (Text -> InternalSubset)
-> (String -> Text) -> String -> InternalSubset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Text
T.pack (String -> InternalSubset)
-> ParsecT Text () Identity String -> Parser InternalSubset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ScanState) -> ParsecT Text () Identity String
scanText (InternalDoctypeState -> Char -> ScanState
dfa InternalDoctypeState
IDSStart)
              Parser InternalSubset
-> Parser InternalSubset -> Parser InternalSubset
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> InternalSubset -> Parser InternalSubset
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return InternalSubset
NoInternalSubset
  where dfa :: InternalDoctypeState -> Char -> ScanState
dfa InternalDoctypeState
IDSStart Char
'[' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
0))
        dfa InternalDoctypeState
IDSStart Char
_   = String -> ScanState
ScanFail String
"Not a DOCTYPE internal subset"
        dfa (IDSInQuote Int
n Char
c) Char
d
          | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d                = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
n))
          | Bool
otherwise             = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
c))
        dfa (IDSScanning Int
n) Char
'['   = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))
        dfa (IDSScanning Int
0) Char
']'   = ScanState
ScanFinish
        dfa (IDSScanning Int
n) Char
']'   = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)))
        dfa (IDSScanning Int
n) Char
'\''  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\''))
        dfa (IDSScanning Int
n) Char
'\"'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\"'))
        dfa (IDSScanning Int
n) Char
'<'   = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSCommentS1 Int
n))
        dfa (IDSScanning Int
n) Char
_     = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
n))
        dfa (IDSCommentS1 Int
n) Char
'['  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))
        dfa (IDSCommentS1 Int
0) Char
']'  = ScanState
ScanFinish
        dfa (IDSCommentS1 Int
n) Char
']'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)))
        dfa (IDSCommentS1 Int
n) Char
'\'' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\''))
        dfa (IDSCommentS1 Int
n) Char
'\"' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\"'))
        dfa (IDSCommentS1 Int
n) Char
'!'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSCommentS2 Int
n))
        dfa (IDSCommentS1 Int
n) Char
_    = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
n))
        dfa (IDSCommentS2 Int
n) Char
'['  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))
        dfa (IDSCommentS2 Int
0) Char
']'  = ScanState
ScanFinish
        dfa (IDSCommentS2 Int
n) Char
']'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)))
        dfa (IDSCommentS2 Int
n) Char
'\'' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\''))
        dfa (IDSCommentS2 Int
n) Char
'\"' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\"'))
        dfa (IDSCommentS2 Int
n) Char
'-'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSCommentS3 Int
n))
        dfa (IDSCommentS2 Int
n) Char
_    = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
n))
        dfa (IDSCommentS3 Int
n) Char
'['  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))
        dfa (IDSCommentS3 Int
0) Char
']'  = ScanState
ScanFinish
        dfa (IDSCommentS3 Int
n) Char
']'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)))
        dfa (IDSCommentS3 Int
n) Char
'\'' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\''))
        dfa (IDSCommentS3 Int
n) Char
'\"' = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> Char -> InternalDoctypeState
IDSInQuote Int
n Char
'\"'))
        dfa (IDSCommentS3 Int
n) Char
'-'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSComment Int
n))
        dfa (IDSCommentS3 Int
n) Char
_    = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
n))
        dfa (IDSComment Int
n) Char
'-'    = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSCommentD1 Int
n))
        dfa (IDSComment Int
n) Char
_      = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSComment Int
n))
        dfa (IDSCommentD1 Int
n) Char
'-'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSCommentE1 Int
n))
        dfa (IDSCommentD1 Int
n) Char
_    = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSComment Int
n))
        dfa (IDSCommentE1 Int
n) Char
'>'  = (Char -> ScanState) -> ScanState
ScanNext (InternalDoctypeState -> Char -> ScanState
dfa (Int -> InternalDoctypeState
IDSScanning Int
n))
        dfa (IDSCommentE1 Int
_) Char
_    = String -> ScanState
ScanFail String
"Poorly formatted comment"


------------------------------------------------------------------------------
sdDecl :: Parser ()
sdDecl :: Parser ()
sdDecl = do
    _ <- Parser Text -> Parser Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
whiteSpace Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
text Text
"standalone"
    eq
    _ <- single <|> double
    return ()
  where
    single :: Parser Text
single = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\'' ParsecT Text () Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
yesno Parser Text -> ParsecT Text () Identity Char -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\''
    double :: Parser Text
double = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"' ParsecT Text () Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
yesno Parser Text -> ParsecT Text () Identity Char -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"'
    yesno :: Parser Text
yesno  = Text -> Parser Text
text Text
"yes" Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
text Text
"no"


------------------------------------------------------------------------------
element :: Parser Node
element :: Parser Node
element = do
    (t,a,b) <- Parser (Text, [(Text, Text)], Bool)
emptyOrStartTag
    if b then return (Element t a [])
         else nonEmptyElem t a
  where
    nonEmptyElem :: Text -> [(Text, Text)] -> Parser Node
nonEmptyElem Text
t [(Text, Text)]
a = do
        c <- Parser [Node]
content
        endTag t
        return (Element t a c)


------------------------------------------------------------------------------
-- | Results are (tag name, attributes, isEmpty)
emptyOrStartTag :: Parser (Text, [(Text, Text)], Bool)
emptyOrStartTag :: Parser (Text, [(Text, Text)], Bool)
emptyOrStartTag = do
    t <- Parser Text -> Parser Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'<' ParsecT Text () Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
name
    a <- many $ P.try $ do
        whiteSpace
        attribute
    when (hasDups a) $ fail "Duplicate attribute names in element"
    _ <- optional whiteSpace
    e <- optional (P.char '/')
    _ <- P.char '>'
    return (t, a, isJust e)
  where
    hasDups :: [(a, b)] -> Bool
hasDups [(a, b)]
a = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
a)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(a, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
a


------------------------------------------------------------------------------
attribute :: Parser (Text, Text)
attribute :: ParsecT Text () Identity (Text, Text)
attribute = do
    n <- Parser Text
name
    eq
    v <- attrValue
    return (n,v)


------------------------------------------------------------------------------
endTag :: Text -> Parser ()
endTag :: Text -> Parser ()
endTag Text
s = do
    _ <- Text -> Parser Text
text Text
"</"
    t <- name
    when (s /= t) $ fail $ "mismatched tags: </" ++ T.unpack t ++
                           "> found inside <" ++ T.unpack s ++ "> tag"
    _ <- optional whiteSpace
    _ <- text ">"
    return ()


------------------------------------------------------------------------------
content :: Parser [Node]
content :: Parser [Node]
content = do
    n  <- Parser Node -> Parser (Maybe Node)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Node
charData
    ns <- fmap concat $ many $ do
        s <- ((Just <$> TextNode <$> reference)
               <|> cdSect
               <|> processingInstruction
               <|> comment
               <|> fmap Just element)
        t <- optional charData
        return [s,t]
    return $ coalesceText $ catMaybes (n:ns)
  where
    coalesceText :: [Node] -> [Node]
coalesceText (TextNode Text
s : TextNode Text
t : [Node]
ns)
        = [Node] -> [Node]
coalesceText (Text -> Node
TextNode (Text -> Text -> Text
T.append Text
s Text
t) Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
ns)
    coalesceText (Node
n:[Node]
ns)
        = Node
n Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node] -> [Node]
coalesceText [Node]
ns
    coalesceText []
        = []


------------------------------------------------------------------------------
charRef :: Parser Text
charRef :: Parser Text
charRef = Parser Text
hexCharRef Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
decCharRef
  where
    decCharRef :: Parser Text
decCharRef = do
        _ <- Text -> Parser Text
text Text
"&#"
        ds <- some digit
        _ <- P.char ';'
        c <- safeChr $ foldl' (\Int
a Int
b -> Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) 0 ds
        when (not (isValidChar c)) $ fail $
            "Reference is not a valid character"
        return $ T.singleton c
      where
        digit :: ParsecT Text u Identity Int
digit = do
            d <- (Char -> Bool) -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
            return (ord d - ord '0')
    hexCharRef :: Parser Text
hexCharRef = do
        _ <- Text -> Parser Text
text Text
"&#x"
        ds <- some digit
        _ <- P.char ';'
        c <- safeChr $ foldl' (\Int
a Int
b -> Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) 0 ds
        when (not (isValidChar c)) $ fail $
            "Reference is not a valid character"
        return $ T.singleton c
      where
        digit :: ParsecT Text u Identity Int
digit = ParsecT Text u Identity Int
forall {u}. ParsecT Text u Identity Int
num ParsecT Text u Identity Int
-> ParsecT Text u Identity Int -> ParsecT Text u Identity Int
forall a.
ParsecT Text u Identity a
-> ParsecT Text u Identity a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text u Identity Int
forall {u}. ParsecT Text u Identity Int
upper ParsecT Text u Identity Int
-> ParsecT Text u Identity Int -> ParsecT Text u Identity Int
forall a.
ParsecT Text u Identity a
-> ParsecT Text u Identity a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text u Identity Int
forall {u}. ParsecT Text u Identity Int
lower
        num :: ParsecT Text u Identity Int
num = do
            d <- (Char -> Bool) -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
            return (ord d - ord '0')
        upper :: ParsecT Text u Identity Int
upper = do
            d <- (Char -> Bool) -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F')
            return (10 + ord d - ord 'A')
        lower :: ParsecT Text u Identity Int
lower = do
            d <- (Char -> Bool) -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f')
            return (10 + ord d - ord 'a')


------------------------------------------------------------------------------
reference :: Parser Text
reference :: Parser Text
reference = Parser Text
charRef Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
entityRef


------------------------------------------------------------------------------
entityRef :: Parser Text
entityRef :: Parser Text
entityRef = do
    _ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'&'
    n <- name
    _ <- P.char ';'
    case M.lookup n entityRefLookup of
        Maybe Text
Nothing -> String -> Parser Text
forall a. String -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Text) -> String -> Parser Text
forall a b. (a -> b) -> a -> b
$ String
"Unknown entity reference: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
n
        Just Text
t  -> Text -> Parser Text
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
  where
    entityRefLookup :: Map Text Text
    entityRefLookup :: Map Text Text
entityRefLookup = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
        (Text
"amp", Text
"&"),
        (Text
"lt", Text
"<"),
        (Text
"gt", Text
">"),
        (Text
"apos", Text
"\'"),
        (Text
"quot", Text
"\"")
        ]


------------------------------------------------------------------------------
externalID :: Parser ExternalID
externalID :: Parser ExternalID
externalID = Parser ExternalID
systemID Parser ExternalID -> Parser ExternalID -> Parser ExternalID
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ExternalID
publicID Parser ExternalID -> Parser ExternalID -> Parser ExternalID
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExternalID -> Parser ExternalID
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ExternalID
NoExternalID
  where
    systemID :: Parser ExternalID
systemID = do
        _ <- Text -> Parser Text
text Text
"SYSTEM"
        whiteSpace
        fmap System systemLiteral
    publicID :: Parser ExternalID
publicID = do
        _ <- Text -> Parser Text
text Text
"PUBLIC"
        whiteSpace
        pid <- pubIdLiteral
        whiteSpace
        sid <- systemLiteral
        return (Public pid sid)


------------------------------------------------------------------------------
encodingDecl :: Parser Text
encodingDecl :: Parser Text
encodingDecl = do
    _ <- Parser Text -> Parser Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
whiteSpace Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
text Text
"encoding"
    _ <- eq
    singleQuoted <|> doubleQuoted
  where
    singleQuoted :: Parser Text
singleQuoted = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\'' ParsecT Text () Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
encName Parser Text -> ParsecT Text () Identity Char -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\''
    doubleQuoted :: Parser Text
doubleQuoted = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"' ParsecT Text () Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
encName Parser Text -> ParsecT Text () Identity Char -> Parser Text
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\"'
    encName :: Parser Text
encName      = do
        c  <- (Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy Char -> Bool
isEncStart
        cs <- takeWhile0 isEnc
        return (T.cons c cs)
    isEncStart :: Char -> Bool
isEncStart Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Bool
True
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Bool
True
                 | Bool
otherwise = Bool
False
    isEnc :: Char -> Bool
isEnc      Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Bool
True
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Bool
True
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Bool
True
                 | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'.',Char
'_',Char
'-'] = Bool
True
                 | Bool
otherwise = Bool
False