{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- | A 'Markup' parser and printer of strict 'ByteString's focused on optimising performance. 'Markup' is a representation of data such as HTML, SVG or XML but the parsing is not always at standards.
module MarkupParse
  ( -- * Usage

    --
    -- $usage

    -- * Markup
    Markup (..),
    Standard (..),
    markup,
    markup_,
    RenderStyle (..),
    markdown,
    markdown_,
    normalize,
    normContent,
    wellFormed,
    isWellFormed,

    -- * Warnings
    MarkupWarning (..),
    Warn,
    warnError,
    warnEither,
    warnMaybe,

    -- * Element
    Element,
    element,
    element_,
    emptyElem,
    elementc,
    content,
    contentRaw,

    -- * Token components
    NameTag,
    selfClosers,
    doctypeHtml,
    doctypeXml,
    AttrName,
    AttrValue,
    Attr (..),
    addAttrs,
    attrsP,
    nameP,

    -- * Tokens
    OpenTagType (..),
    Token (..),
    tokenize,
    tokenize_,
    tokenP,
    detokenize,
    gather,
    gather_,
    degather,
    degather_,

    -- * XML specific Parsers
    xmlVersionInfoP,
    xmlEncodingDeclP,
    xmlStandaloneP,
    xmlVersionNumP,
    xmlEncNameP,
    xmlYesNoP,

    -- * bytestring support
    utf8ToStr,
    strToUtf8,
    escapeChar,
    escape,

    -- * Tree support
    Tree (..),
  )
where

import Control.Category ((>>>))
import Control.DeepSeq
import Control.Monad
import Data.Bifunctor
import Data.Bool
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.Char hiding (isDigit)
import Data.Foldable
import Data.Function
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.String.Interpolate
import Data.These
import Data.Tree
import Data.TreeDiff
import FlatParse.Basic hiding (Result, cut, take)
import GHC.Generics
import MarkupParse.FlatParse
import Prelude hiding (replicate)

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> :set -XQuasiQuotes
-- >>> :set -XOverloadedStrings
-- >>> import MarkupParse
-- >>> import MarkupParse.Patch
-- >>> import MarkupParse.FlatParse
-- >>> import FlatParse.Basic
-- >>> import Data.String.Interpolate
-- >>> import Data.ByteString.Char8 qualified as B
-- >>> import Data.Tree

-- $usage
--
-- > import MarkupParse
-- > import Data.ByteString qualified as B
-- >
-- > bs <- B.readFile "other/line.svg"
-- > m = markup_ bs
--
-- @'markdown_' . 'markup_'@ is an isomorphic round trip from 'Markup' to 'ByteString' to 'Markup':
--
-- - This is subject to the 'Markup' being 'wellFormed'.
--
-- - The round-trip @'markup_' . 'markdown_'@ is not isomorphic as parsing forgets whitespace within tags, comments and declarations.
--
-- - The underscores represent versions of main functions that throw an exception on warnings encountered along the way.
--
-- At a lower level, a round trip pipeline might look something like:
--
-- > tokenize Html >=>
--
-- - 'tokenize' converts a 'ByteString' to a 'Token' list.
--
-- > gather Html >=>
--
-- - 'gather' takes the tokens and gathers them into 'Tree's of 'Token's which is what 'Markup' is.
--
-- > (normalize >>> pure) >=>
--
-- - 'normalize' concatenates content, and normalizes attributes,
--
-- > degather Html >=>
--
-- - 'degather' turns the markup tree back into a token list. Finally,
--
-- > fmap (detokenize Html) >>> pure
--
-- - 'detokenize' turns a token back into a bytestring.
--
-- Along the way, the kleisi fishies and compose forward usage accumulates any warnings via the 'These' monad instance, which is wrapped into a type synonym named 'Warn'.

-- | From a parsing pov, Html & Xml (& Svg) are close enough that they share a lot of parsing logic, so that parsing and printing just need some tweaking.
--
-- The xml parsing logic is based on the XML productions found in https://www.w3.org/TR/xml/
--
-- The html parsing was based on a reading of <https://hackage.haskell.org/package/html-parse html-parse>, but ignores the various '\x00' to '\xfffd' & eof directives that form part of the html standards.
data Standard = Html | Xml deriving (Standard -> Standard -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Standard -> Standard -> Bool
$c/= :: Standard -> Standard -> Bool
== :: Standard -> Standard -> Bool
$c== :: Standard -> Standard -> Bool
Eq, Int -> Standard -> ShowS
[Standard] -> ShowS
Standard -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Standard] -> ShowS
$cshowList :: [Standard] -> ShowS
show :: Standard -> String
$cshow :: Standard -> String
showsPrec :: Int -> Standard -> ShowS
$cshowsPrec :: Int -> Standard -> ShowS
Show, Eq Standard
Standard -> Standard -> Bool
Standard -> Standard -> Ordering
Standard -> Standard -> Standard
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Standard -> Standard -> Standard
$cmin :: Standard -> Standard -> Standard
max :: Standard -> Standard -> Standard
$cmax :: Standard -> Standard -> Standard
>= :: Standard -> Standard -> Bool
$c>= :: Standard -> Standard -> Bool
> :: Standard -> Standard -> Bool
$c> :: Standard -> Standard -> Bool
<= :: Standard -> Standard -> Bool
$c<= :: Standard -> Standard -> Bool
< :: Standard -> Standard -> Bool
$c< :: Standard -> Standard -> Bool
compare :: Standard -> Standard -> Ordering
$ccompare :: Standard -> Standard -> Ordering
Ord, forall x. Rep Standard x -> Standard
forall x. Standard -> Rep Standard x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Standard x -> Standard
$cfrom :: forall x. Standard -> Rep Standard x
Generic, Standard -> ()
forall a. (a -> ()) -> NFData a
rnf :: Standard -> ()
$crnf :: Standard -> ()
NFData, [Standard] -> Expr
Standard -> Expr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [Standard] -> Expr
$clistToExpr :: [Standard] -> Expr
toExpr :: Standard -> Expr
$ctoExpr :: Standard -> Expr
ToExpr)

-- | A list of 'Element's or 'Tree' 'Token's
--
-- >>> markup Html "<foo class=\"bar\">baz</foo>"
-- That (Markup {elements = [Node {rootLabel = OpenTag StartTag "foo" [Attr {attrName = "class", attrValue = "bar"}], subForest = [Node {rootLabel = Content "baz", subForest = []}]}]})
newtype Markup = Markup {Markup -> [Element]
elements :: [Element]}
  deriving stock (Int -> Markup -> ShowS
[Markup] -> ShowS
Markup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Markup] -> ShowS
$cshowList :: [Markup] -> ShowS
show :: Markup -> String
$cshow :: Markup -> String
showsPrec :: Int -> Markup -> ShowS
$cshowsPrec :: Int -> Markup -> ShowS
Show, Markup -> Markup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Markup -> Markup -> Bool
$c/= :: Markup -> Markup -> Bool
== :: Markup -> Markup -> Bool
$c== :: Markup -> Markup -> Bool
Eq, Eq Markup
Markup -> Markup -> Bool
Markup -> Markup -> Ordering
Markup -> Markup -> Markup
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Markup -> Markup -> Markup
$cmin :: Markup -> Markup -> Markup
max :: Markup -> Markup -> Markup
$cmax :: Markup -> Markup -> Markup
>= :: Markup -> Markup -> Bool
$c>= :: Markup -> Markup -> Bool
> :: Markup -> Markup -> Bool
$c> :: Markup -> Markup -> Bool
<= :: Markup -> Markup -> Bool
$c<= :: Markup -> Markup -> Bool
< :: Markup -> Markup -> Bool
$c< :: Markup -> Markup -> Bool
compare :: Markup -> Markup -> Ordering
$ccompare :: Markup -> Markup -> Ordering
Ord, forall x. Rep Markup x -> Markup
forall x. Markup -> Rep Markup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Markup x -> Markup
$cfrom :: forall x. Markup -> Rep Markup x
Generic)
  deriving anyclass (Markup -> ()
forall a. (a -> ()) -> NFData a
rnf :: Markup -> ()
$crnf :: Markup -> ()
NFData, [Markup] -> Expr
Markup -> Expr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [Markup] -> Expr
$clistToExpr :: [Markup] -> Expr
toExpr :: Markup -> Expr
$ctoExpr :: Markup -> Expr
ToExpr)
  deriving newtype (NonEmpty Markup -> Markup
Markup -> Markup -> Markup
forall b. Integral b => b -> Markup -> Markup
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Markup -> Markup
$cstimes :: forall b. Integral b => b -> Markup -> Markup
sconcat :: NonEmpty Markup -> Markup
$csconcat :: NonEmpty Markup -> Markup
<> :: Markup -> Markup -> Markup
$c<> :: Markup -> Markup -> Markup
Semigroup, Semigroup Markup
Markup
[Markup] -> Markup
Markup -> Markup -> Markup
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Markup] -> Markup
$cmconcat :: [Markup] -> Markup
mappend :: Markup -> Markup -> Markup
$cmappend :: Markup -> Markup -> Markup
mempty :: Markup
$cmempty :: Markup
Monoid)

-- | markup-parse generally tries to continue on parse errors, and return what has/can still be parsed, together with any warnings.
data MarkupWarning
  = -- | A tag ending with "/>" that is not an element of 'selfClosers' (Html only).
    BadEmptyElemTag
  | -- | A tag ending with "/>" that has children. Cannot happen in the parsing phase.
    SelfCloserWithChildren
  | -- | Only a 'StartTag' can have child tokens.
    LeafWithChildren
  | -- | A CloseTag with a different name to the currently open StartTag.
    TagMismatch NameTag NameTag
  | -- | An EndTag with no corresponding StartTag.
    UnmatchedEndTag
  | -- | An StartTag with no corresponding EndTag.
    UnclosedTag
  | -- | An EndTag should never appear in 'Markup'
    EndTagInTree
  | -- | Empty Content, Comment, Decl or Doctype
    EmptyContent
  | -- | Badly formed declaration
    BadDecl
  | MarkupParser ParserWarning
  deriving (MarkupWarning -> MarkupWarning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MarkupWarning -> MarkupWarning -> Bool
$c/= :: MarkupWarning -> MarkupWarning -> Bool
== :: MarkupWarning -> MarkupWarning -> Bool
$c== :: MarkupWarning -> MarkupWarning -> Bool
Eq, Int -> MarkupWarning -> ShowS
[MarkupWarning] -> ShowS
MarkupWarning -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MarkupWarning] -> ShowS
$cshowList :: [MarkupWarning] -> ShowS
show :: MarkupWarning -> String
$cshow :: MarkupWarning -> String
showsPrec :: Int -> MarkupWarning -> ShowS
$cshowsPrec :: Int -> MarkupWarning -> ShowS
Show, Eq MarkupWarning
MarkupWarning -> MarkupWarning -> Bool
MarkupWarning -> MarkupWarning -> Ordering
MarkupWarning -> MarkupWarning -> MarkupWarning
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MarkupWarning -> MarkupWarning -> MarkupWarning
$cmin :: MarkupWarning -> MarkupWarning -> MarkupWarning
max :: MarkupWarning -> MarkupWarning -> MarkupWarning
$cmax :: MarkupWarning -> MarkupWarning -> MarkupWarning
>= :: MarkupWarning -> MarkupWarning -> Bool
$c>= :: MarkupWarning -> MarkupWarning -> Bool
> :: MarkupWarning -> MarkupWarning -> Bool
$c> :: MarkupWarning -> MarkupWarning -> Bool
<= :: MarkupWarning -> MarkupWarning -> Bool
$c<= :: MarkupWarning -> MarkupWarning -> Bool
< :: MarkupWarning -> MarkupWarning -> Bool
$c< :: MarkupWarning -> MarkupWarning -> Bool
compare :: MarkupWarning -> MarkupWarning -> Ordering
$ccompare :: MarkupWarning -> MarkupWarning -> Ordering
Ord, forall x. Rep MarkupWarning x -> MarkupWarning
forall x. MarkupWarning -> Rep MarkupWarning x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MarkupWarning x -> MarkupWarning
$cfrom :: forall x. MarkupWarning -> Rep MarkupWarning x
Generic, MarkupWarning -> ()
forall a. (a -> ()) -> NFData a
rnf :: MarkupWarning -> ()
$crnf :: MarkupWarning -> ()
NFData)

showWarnings :: [MarkupWarning] -> String
showWarnings :: [MarkupWarning] -> String
showWarnings = forall a. Eq a => [a] -> [a]
List.nub forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [String] -> String
unlines

-- | A type synonym for the common returning type of many functions. A common computation pipeline is to take advantage of the 'These' Monad instance eg
--
-- > markup s bs = bs & (tokenize s >=> gather s) & second (Markup s)
type Warn a = These [MarkupWarning] a

-- | Convert any warnings to an 'error'
--
-- >>> warnError $ (tokenize Html) "<foo"
-- *** Exception: MarkupParser (ParserLeftover "<foo")
-- ...
warnError :: Warn a -> a
warnError :: forall a. Warn a -> a
warnError = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these ([MarkupWarning] -> String
showWarnings forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. HasCallStack => String -> a
error) forall a. a -> a
id (\[MarkupWarning]
xs a
a -> forall a. a -> a -> Bool -> a
bool (forall a. HasCallStack => String -> a
error ([MarkupWarning] -> String
showWarnings [MarkupWarning]
xs)) a
a ([MarkupWarning]
xs forall a. Eq a => a -> a -> Bool
== []))

-- | Returns Left on any warnings
--
-- >>> warnEither $ (tokenize Html) "<foo><baz"
-- Left [MarkupParser (ParserLeftover "<baz")]
warnEither :: Warn a -> Either [MarkupWarning] a
warnEither :: forall a. Warn a -> Either [MarkupWarning] a
warnEither = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these forall a b. a -> Either a b
Left forall a b. b -> Either a b
Right (\[MarkupWarning]
xs a
a -> forall a. a -> a -> Bool -> a
bool (forall a b. a -> Either a b
Left [MarkupWarning]
xs) (forall a b. b -> Either a b
Right a
a) ([MarkupWarning]
xs forall a. Eq a => a -> a -> Bool
== []))

-- | Returns results, if any, ignoring warnings.
--
-- >>> warnMaybe $ (tokenize Html) "<foo><baz"
-- Just [OpenTag StartTag "foo" []]
warnMaybe :: Warn a -> Maybe a
warnMaybe :: forall a. Warn a -> Maybe a
warnMaybe = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just (\[MarkupWarning]
_ a
a -> forall a. a -> Maybe a
Just a
a)

-- | Convert bytestrings to 'Markup'
--
-- >>> markup Html "<foo><br></foo><baz"
-- These [MarkupParser (ParserLeftover "<baz")] (Markup {elements = [Node {rootLabel = OpenTag StartTag "foo" [], subForest = [Node {rootLabel = OpenTag StartTag "br" [], subForest = []}]}]})
markup :: Standard -> ByteString -> Warn Markup
markup :: Standard -> NameTag -> Warn Markup
markup Standard
s NameTag
bs = NameTag
bs forall a b. a -> (a -> b) -> b
& (Standard -> NameTag -> Warn [Token]
tokenize Standard
s forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Standard -> [Token] -> Warn Markup
gather Standard
s)

-- | 'markup' but errors on warnings.
markup_ :: Standard -> ByteString -> Markup
markup_ :: Standard -> NameTag -> Markup
markup_ Standard
s NameTag
bs = Standard -> NameTag -> Warn Markup
markup Standard
s NameTag
bs forall a b. a -> (a -> b) -> b
& forall a. Warn a -> a
warnError

-- | Concatenate sequential content and normalize attributes; unwording class values and removing duplicate attributes (taking last).
--
-- >>> B.putStr $ warnError $ markdown Compact Xml $ normalize (markup_ Xml [i|<foo class="a" class="b" bar="first" bar="last"/>|])
-- <foo bar="last" class="a b"/>
normalize :: Markup -> Markup
normalize :: Markup -> Markup
normalize Markup
m = Markup -> Markup
normContent forall a b. (a -> b) -> a -> b
$ [Element] -> Markup
Markup forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Token
normTokenAttrs) (Markup -> [Element]
elements Markup
m)

-- | Are the trees in the markup well-formed?
isWellFormed :: Standard -> Markup -> Bool
isWellFormed :: Standard -> Markup -> Bool
isWellFormed Standard
s = (forall a. Eq a => a -> a -> Bool
== []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Standard -> Markup -> [MarkupWarning]
wellFormed Standard
s

-- | Check for well-formedness and return warnings encountered.
--
-- >>> wellFormed Html $ Markup [Node (Comment "") [], Node (EndTag "foo") [], Node (OpenTag EmptyElemTag "foo" []) [Node (Content "bar") []], Node (OpenTag EmptyElemTag "foo" []) []]
-- [EmptyContent,EndTagInTree,LeafWithChildren,BadEmptyElemTag]
wellFormed :: Standard -> Markup -> [MarkupWarning]
wellFormed :: Standard -> Markup -> [MarkupWarning]
wellFormed Standard
s (Markup [Element]
trees) = forall a. Eq a => [a] -> [a]
List.nub forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree Token -> [[MarkupWarning]] -> [MarkupWarning]
checkNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element]
trees)
  where
    checkNode :: Token -> [[MarkupWarning]] -> [MarkupWarning]
checkNode (OpenTag OpenTagType
StartTag NameTag
_ [Attr]
_) [[MarkupWarning]]
xs = forall a. Monoid a => [a] -> a
mconcat [[MarkupWarning]]
xs
    checkNode (OpenTag OpenTagType
EmptyElemTag NameTag
n [Attr]
_) [] =
      forall a. a -> a -> Bool -> a
bool [] [MarkupWarning
BadEmptyElemTag] (Bool -> Bool
not (NameTag
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NameTag]
selfClosers) Bool -> Bool -> Bool
&& Standard
s forall a. Eq a => a -> a -> Bool
== Standard
Html)
    checkNode (EndTag NameTag
_) [] = [MarkupWarning
EndTagInTree]
    checkNode (Content NameTag
bs) [] = forall a. a -> a -> Bool -> a
bool [] [MarkupWarning
EmptyContent] (NameTag
bs forall a. Eq a => a -> a -> Bool
== NameTag
"")
    checkNode (Comment NameTag
bs) [] = forall a. a -> a -> Bool -> a
bool [] [MarkupWarning
EmptyContent] (NameTag
bs forall a. Eq a => a -> a -> Bool
== NameTag
"")
    checkNode (Decl NameTag
bs [Attr]
as) []
      | NameTag
bs forall a. Eq a => a -> a -> Bool
== NameTag
"" = [MarkupWarning
EmptyContent]
      | Standard
s forall a. Eq a => a -> a -> Bool
== Standard
Html Bool -> Bool -> Bool
&& [Attr]
as forall a. Eq a => a -> a -> Bool
/= [] = [MarkupWarning
BadDecl]
      | Standard
s forall a. Eq a => a -> a -> Bool
== Standard
Xml Bool -> Bool -> Bool
&& (NameTag
"version" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Attr -> NameTag
attrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attr]
as)) Bool -> Bool -> Bool
&& (NameTag
"encoding" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Attr -> NameTag
attrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attr]
as)) =
          [MarkupWarning
BadDecl]
      | Bool
otherwise = []
    checkNode (Doctype NameTag
bs) [] = forall a. a -> a -> Bool -> a
bool [] [MarkupWarning
EmptyContent] (NameTag
bs forall a. Eq a => a -> a -> Bool
== NameTag
"")
    checkNode Token
_ [[MarkupWarning]]
_ = [MarkupWarning
LeafWithChildren]

-- | Name of token
type NameTag = ByteString

-- | Whether an opening tag is a start tag or an empty element tag.
data OpenTagType = StartTag | EmptyElemTag deriving (Int -> OpenTagType -> ShowS
[OpenTagType] -> ShowS
OpenTagType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpenTagType] -> ShowS
$cshowList :: [OpenTagType] -> ShowS
show :: OpenTagType -> String
$cshow :: OpenTagType -> String
showsPrec :: Int -> OpenTagType -> ShowS
$cshowsPrec :: Int -> OpenTagType -> ShowS
Show, Eq OpenTagType
OpenTagType -> OpenTagType -> Bool
OpenTagType -> OpenTagType -> Ordering
OpenTagType -> OpenTagType -> OpenTagType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OpenTagType -> OpenTagType -> OpenTagType
$cmin :: OpenTagType -> OpenTagType -> OpenTagType
max :: OpenTagType -> OpenTagType -> OpenTagType
$cmax :: OpenTagType -> OpenTagType -> OpenTagType
>= :: OpenTagType -> OpenTagType -> Bool
$c>= :: OpenTagType -> OpenTagType -> Bool
> :: OpenTagType -> OpenTagType -> Bool
$c> :: OpenTagType -> OpenTagType -> Bool
<= :: OpenTagType -> OpenTagType -> Bool
$c<= :: OpenTagType -> OpenTagType -> Bool
< :: OpenTagType -> OpenTagType -> Bool
$c< :: OpenTagType -> OpenTagType -> Bool
compare :: OpenTagType -> OpenTagType -> Ordering
$ccompare :: OpenTagType -> OpenTagType -> Ordering
Ord, OpenTagType -> OpenTagType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpenTagType -> OpenTagType -> Bool
$c/= :: OpenTagType -> OpenTagType -> Bool
== :: OpenTagType -> OpenTagType -> Bool
$c== :: OpenTagType -> OpenTagType -> Bool
Eq, forall x. Rep OpenTagType x -> OpenTagType
forall x. OpenTagType -> Rep OpenTagType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OpenTagType x -> OpenTagType
$cfrom :: forall x. OpenTagType -> Rep OpenTagType x
Generic, OpenTagType -> ()
forall a. (a -> ()) -> NFData a
rnf :: OpenTagType -> ()
$crnf :: OpenTagType -> ()
NFData, [OpenTagType] -> Expr
OpenTagType -> Expr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [OpenTagType] -> Expr
$clistToExpr :: [OpenTagType] -> Expr
toExpr :: OpenTagType -> Expr
$ctoExpr :: OpenTagType -> Expr
ToExpr)

-- | A Markup token. The term is borrowed from <https://www.w3.org/html/wg/spec/tokenization.html#tokenization HTML> standards but is used across 'Html' and 'Xml' in this library.
--
-- Note that the 'Token' type is used in two slightly different contexts:
--
-- - As an intermediary representation of markup between 'ByteString' and 'Markup'.
--
-- - As the primitives of 'Markup' 'Element's
--
-- Specifically, an 'EndTag' will occur in a list of tokens, but not as a primitive in 'Markup'. It may turn out to be better to have two different types for these two uses and future iterations of this library may head in this direction.
--
-- >>> runParser_ (many (tokenP Html)) [i|<foo>content</foo>|]
-- [OpenTag StartTag "foo" [],Content "content",EndTag "foo"]
--
-- >>> runParser_ (tokenP Xml) [i|<foo/>|]
-- OpenTag EmptyElemTag "foo" []
--
-- >>> runParser_ (tokenP Html) "<!-- Comment -->"
-- Comment " Comment "
--
-- >>> runParser_ (tokenP Xml) [i|<?xml version="1.0" encoding="UTF-8"?>|]
-- Decl "xml" [Attr {attrName = "version", attrValue = " version=\"1.0\""},Attr {attrName = "encoding", attrValue = "UTF-8"}]
--
-- >>> runParser_ (tokenP Html) "<!DOCTYPE html>"
-- Doctype "DOCTYPE html"
--
-- >>> runParser_ (tokenP Xml) "<!DOCTYPE foo [ declarations ]>"
-- Doctype "DOCTYPE foo [ declarations ]"
--
-- >>> runParser (tokenP Html) [i|<foo a="a" b="b" c=c check>|]
-- OK (OpenTag StartTag "foo" [Attr {attrName = "a", attrValue = "a"},Attr {attrName = "b", attrValue = "b"},Attr {attrName = "c", attrValue = "c"},Attr {attrName = "check", attrValue = ""}]) ""
--
-- >>> runParser (tokenP Xml) [i|<foo a="a" b="b" c=c check>|]
-- Fail
data Token
  = -- | A tag. https://developer.mozilla.org/en-US/docs/Glossary/Tag
    OpenTag !OpenTagType !NameTag ![Attr]
  | -- | A closing tag.
    EndTag !NameTag
  | -- | The content between tags.
    Content !ByteString
  | -- | Contents of a comment.
    Comment !ByteString
  | -- | Contents of a declaration
    Decl !ByteString ![Attr]
  | -- | Contents of a doctype declaration.
    Doctype !ByteString
  deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Eq Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmax :: Token -> Token -> Token
>= :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c< :: Token -> Token -> Bool
compare :: Token -> Token -> Ordering
$ccompare :: Token -> Token -> Ordering
Ord, Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, forall x. Rep Token x -> Token
forall x. Token -> Rep Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Token x -> Token
$cfrom :: forall x. Token -> Rep Token x
Generic, Token -> ()
forall a. (a -> ()) -> NFData a
rnf :: Token -> ()
$crnf :: Token -> ()
NFData, [Token] -> Expr
Token -> Expr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [Token] -> Expr
$clistToExpr :: [Token] -> Expr
toExpr :: Token -> Expr
$ctoExpr :: Token -> Expr
ToExpr)

-- | Escape a single character.
escapeChar :: Char -> ByteString
escapeChar :: Char -> NameTag
escapeChar Char
'<' = NameTag
"&lt;"
escapeChar Char
'>' = NameTag
"&gt;"
escapeChar Char
'&' = NameTag
"&amp;"
escapeChar Char
'\'' = NameTag
"&apos;"
escapeChar Char
'"' = NameTag
"&quot;"
escapeChar Char
x = Char -> NameTag
B.singleton Char
x

-- | Escape the following predefined character entity references:
--
-- @
-- escapeChar \'<\' = "&lt;"
-- escapeChar \'>\' = "&gt;"
-- escapeChar \'&\' = "&amp;"
-- escapeChar '\'' = "&apos;"
-- escapeChar '"' = "&quot;"
-- @
--
-- No attempt is made to meet the <https://en.wikipedia.org/wiki/List_of_XML_and_HTML_character_entity_references HTML Standards>
--
-- >>> escape [i|<foo class="a" bar='b'>|]
-- "&lt;foo class=&quot;a&quot; bar=&apos;b&apos;&gt;"
escape :: ByteString -> ByteString
escape :: NameTag -> NameTag
escape NameTag
bs = (Char -> NameTag) -> NameTag -> NameTag
B.concatMap Char -> NameTag
escapeChar NameTag
bs

-- | Append attributes to an existing Token attribute list. Returns Nothing for tokens that do not have attributes.
addAttrs :: [Attr] -> Token -> Maybe Token
addAttrs :: [Attr] -> Token -> Maybe Token
addAttrs [Attr]
as (OpenTag OpenTagType
t NameTag
n [Attr]
as') = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ OpenTagType -> NameTag -> [Attr] -> Token
OpenTag OpenTagType
t NameTag
n ([Attr]
as forall a. Semigroup a => a -> a -> a
<> [Attr]
as')
addAttrs [Attr]
_ Token
_ = forall a. Maybe a
Nothing

-- | Standard Html Doctype
--
-- >>> markdown_ Compact Html doctypeHtml
-- "<!DOCTYPE html>"
doctypeHtml :: Markup
doctypeHtml :: Markup
doctypeHtml = [Element] -> Markup
Markup forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameTag -> Token
Doctype NameTag
"DOCTYPE html")

-- | Standard Xml Doctype
--
-- >>> markdown_ Compact Xml doctypeXml
-- "<?xml version=\"1.0\" encoding=\"utf-8\"?><!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n    \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">"
doctypeXml :: Markup
doctypeXml :: Markup
doctypeXml =
  [Element] -> Markup
Markup
    [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NameTag -> [Attr] -> Token
Decl NameTag
"xml" [NameTag -> NameTag -> Attr
Attr NameTag
"version" NameTag
"1.0", NameTag -> NameTag -> Attr
Attr NameTag
"encoding" NameTag
"utf-8"],
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NameTag -> Token
Doctype NameTag
"DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n    \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\""
    ]

-- | A flatparse 'Token' parser.
--
-- >>> runParser (tokenP Html) "<foo>content</foo>"
-- OK (OpenTag StartTag "foo" []) "content</foo>"
tokenP :: Standard -> Parser e Token
tokenP :: forall e. Standard -> Parser e Token
tokenP Standard
Html = forall e. Parser e Token
tokenHtmlP
tokenP Standard
Xml = forall e. Parser e Token
tokenXmlP

-- | Parse a bytestring into tokens
--
-- >>> tokenize Html [i|<foo>content</foo>|]
-- That [OpenTag StartTag "foo" [],Content "content",EndTag "foo"]
tokenize :: Standard -> ByteString -> Warn [Token]
tokenize :: Standard -> NameTag -> Warn [Token]
tokenize Standard
s NameTag
bs = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserWarning -> MarkupWarning
MarkupParser) forall a b. (a -> b) -> a -> b
$ forall a. Parser NameTag a -> NameTag -> These ParserWarning a
runParserWarn (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall e. Standard -> Parser e Token
tokenP Standard
s)) NameTag
bs

-- | tokenize but errors on warnings.
tokenize_ :: Standard -> ByteString -> [Token]
tokenize_ :: Standard -> NameTag -> [Token]
tokenize_ Standard
s NameTag
bs = Standard -> NameTag -> Warn [Token]
tokenize Standard
s NameTag
bs forall a b. a -> (a -> b) -> b
& forall a. Warn a -> a
warnError

-- | Html tags that self-close
selfClosers :: [NameTag]
selfClosers :: [NameTag]
selfClosers =
  [ NameTag
"area",
    NameTag
"base",
    NameTag
"br",
    NameTag
"col",
    NameTag
"embed",
    NameTag
"hr",
    NameTag
"img",
    NameTag
"input",
    NameTag
"link",
    NameTag
"meta",
    NameTag
"param",
    NameTag
"source",
    NameTag
"track",
    NameTag
"wbr"
  ]

-- | Most functions return a 'Markup' rather than an 'Element' because it is often more ergonomic to use the free monoid (aka a list) in preference to returning a 'Maybe' 'Element' (say).
type Element = Tree Token

-- | Create 'Markup' from a name tag and attributes that wraps some other markup.
--
-- >>> element "div" [] (element_ "br" [])
-- Markup {elements = [Node {rootLabel = OpenTag StartTag "div" [], subForest = [Node {rootLabel = OpenTag StartTag "br" [], subForest = []}]}]}
element :: NameTag -> [Attr] -> Markup -> Markup
element :: NameTag -> [Attr] -> Markup -> Markup
element NameTag
n [Attr]
as (Markup [Element]
xs) = [Element] -> Markup
Markup [forall a. a -> [Tree a] -> Tree a
Node (OpenTagType -> NameTag -> [Attr] -> Token
OpenTag OpenTagType
StartTag NameTag
n [Attr]
as) [Element]
xs]

-- | Create 'Markup' from a name tag and attributes that doesn't wrap some other markup. The 'OpenTagType' used is 'StartTag'. Use 'emptyElem' if you want to create 'EmptyElemTag' based markup.
--
-- >>> (element_ "br" [])
-- Markup {elements = [Node {rootLabel = OpenTag StartTag "br" [], subForest = []}]}
element_ :: NameTag -> [Attr] -> Markup
element_ :: NameTag -> [Attr] -> Markup
element_ NameTag
n [Attr]
as = [Element] -> Markup
Markup [forall a. a -> [Tree a] -> Tree a
Node (OpenTagType -> NameTag -> [Attr] -> Token
OpenTag OpenTagType
StartTag NameTag
n [Attr]
as) []]

-- | Create 'Markup' from a name tag and attributes using 'EmptyElemTag', that doesn't wrap some other markup. No checks are made on whether this creates well-formed markup.
--
-- >>> emptyElem "br" []
-- Markup {elements = [Node {rootLabel = OpenTag EmptyElemTag "br" [], subForest = []}]}
emptyElem :: NameTag -> [Attr] -> Markup
emptyElem :: NameTag -> [Attr] -> Markup
emptyElem NameTag
n [Attr]
as = [Element] -> Markup
Markup [forall a. a -> [Tree a] -> Tree a
Node (OpenTagType -> NameTag -> [Attr] -> Token
OpenTag OpenTagType
EmptyElemTag NameTag
n [Attr]
as) []]

-- | Create 'Markup' from a name tag and attributes that wraps some 'Content'. No escaping is performed.
--
-- >>> elementc "div" [] "content"
-- Markup {elements = [Node {rootLabel = OpenTag StartTag "div" [], subForest = [Node {rootLabel = Content "content", subForest = []}]}]}
elementc :: NameTag -> [Attr] -> ByteString -> Markup
elementc :: NameTag -> [Attr] -> NameTag -> Markup
elementc NameTag
n [Attr]
as NameTag
bs = NameTag -> [Attr] -> Markup -> Markup
element NameTag
n [Attr]
as (NameTag -> Markup
contentRaw NameTag
bs)

-- | Create 'Markup' 'Content' from a bytestring, escaping the usual characters.
--
-- >>> content "<content>"
-- Markup {elements = [Node {rootLabel = Content "&lt;content&gt;", subForest = []}]}
content :: ByteString -> Markup
content :: NameTag -> Markup
content NameTag
bs = [Element] -> Markup
Markup [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NameTag -> Token
Content (NameTag -> NameTag
escape NameTag
bs)]

-- | Create a Markup element from a bytestring, not escaping the usual characters.
--
-- >>> contentRaw "<content>"
-- Markup {elements = [Node {rootLabel = Content "<content>", subForest = []}]}
--
-- >>> markup_ Html $ markdown_ Compact Html $ contentRaw "<content>"
-- *** Exception: UnclosedTag
-- ...
contentRaw :: ByteString -> Markup
contentRaw :: NameTag -> Markup
contentRaw NameTag
bs = [Element] -> Markup
Markup [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NameTag -> Token
Content NameTag
bs]

-- | Name of an attribute.
type AttrName = ByteString

-- | Value of an attribute. "" is equivalent to true with respect to boolean attributes.
type AttrValue = ByteString

-- | An attribute of a tag
--
-- In parsing, boolean attributes, which are not required to have a value in HTML,
-- will be set a value of "", which is ok. But this will then be rendered.
--
-- >>> detokenize Html <$> tokenize_ Html [i|<input checked>|]
-- ["<input checked=\"\">"]
data Attr = Attr {Attr -> NameTag
attrName :: !AttrName, Attr -> NameTag
attrValue :: !AttrValue}
  deriving (forall x. Rep Attr x -> Attr
forall x. Attr -> Rep Attr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Attr x -> Attr
$cfrom :: forall x. Attr -> Rep Attr x
Generic, Int -> Attr -> ShowS
[Attr] -> ShowS
Attr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attr] -> ShowS
$cshowList :: [Attr] -> ShowS
show :: Attr -> String
$cshow :: Attr -> String
showsPrec :: Int -> Attr -> ShowS
$cshowsPrec :: Int -> Attr -> ShowS
Show, Attr -> Attr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c== :: Attr -> Attr -> Bool
Eq, Eq Attr
Attr -> Attr -> Bool
Attr -> Attr -> Ordering
Attr -> Attr -> Attr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Attr -> Attr -> Attr
$cmin :: Attr -> Attr -> Attr
max :: Attr -> Attr -> Attr
$cmax :: Attr -> Attr -> Attr
>= :: Attr -> Attr -> Bool
$c>= :: Attr -> Attr -> Bool
> :: Attr -> Attr -> Bool
$c> :: Attr -> Attr -> Bool
<= :: Attr -> Attr -> Bool
$c<= :: Attr -> Attr -> Bool
< :: Attr -> Attr -> Bool
$c< :: Attr -> Attr -> Bool
compare :: Attr -> Attr -> Ordering
$ccompare :: Attr -> Attr -> Ordering
Ord)

instance NFData Attr

instance ToExpr Attr

normTokenAttrs :: Token -> Token
normTokenAttrs :: Token -> Token
normTokenAttrs (OpenTag OpenTagType
t NameTag
n [Attr]
as) = OpenTagType -> NameTag -> [Attr] -> Token
OpenTag OpenTagType
t NameTag
n ([Attr] -> [Attr]
normAttrs [Attr]
as)
normTokenAttrs Token
x = Token
x

-- | normalize an attribution list, removing duplicate AttrNames, and space concatenating class values.
normAttrs :: [Attr] -> [Attr]
normAttrs :: [Attr] -> [Attr]
normAttrs [Attr]
as =
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NameTag -> NameTag -> Attr
Attr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              ( \Map NameTag NameTag
s (Attr NameTag
n NameTag
v) ->
                  forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWithKey
                    ( \NameTag
k NameTag
new NameTag
old ->
                        case NameTag
k of
                          NameTag
"class" -> NameTag
old forall a. Semigroup a => a -> a -> a
<> NameTag
" " forall a. Semigroup a => a -> a -> a
<> NameTag
new
                          NameTag
_ -> NameTag
new
                    )
                    NameTag
n
                    NameTag
v
                    Map NameTag NameTag
s
              )
              forall k a. Map k a
Map.empty
              [Attr]
as
        )

-- | render attributes
renderAttrs :: [Attr] -> ByteString
renderAttrs :: [Attr] -> NameTag
renderAttrs [] = forall a. Monoid a => a
mempty
renderAttrs [Attr]
xs = Char -> NameTag
B.singleton Char
' ' forall a. Semigroup a => a -> a -> a
<> ([NameTag] -> NameTag
B.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attr -> NameTag
renderAttr forall a b. (a -> b) -> a -> b
$ [Attr]
xs)

-- | render an attribute
--
-- Does not attempt to escape double quotes.
renderAttr :: Attr -> ByteString
renderAttr :: Attr -> NameTag
renderAttr (Attr NameTag
k NameTag
v) = [i|#{k}="#{v}"|]

-- | bytestring representation of 'Token'.
--
-- >>> detokenize Html (OpenTag StartTag "foo" [])
-- "<foo>"
detokenize :: Standard -> Token -> ByteString
detokenize :: Standard -> Token -> NameTag
detokenize Standard
s = \case
  (OpenTag OpenTagType
StartTag NameTag
n []) -> [i|<#{n}>|]
  (OpenTag OpenTagType
StartTag NameTag
n [Attr]
as) -> [i|<#{n}#{renderAttrs as}>|]
  (OpenTag OpenTagType
EmptyElemTag NameTag
n [Attr]
as) ->
    forall a. a -> a -> Bool -> a
bool
      [i|<#{n}#{renderAttrs as}/>|]
      [i|<#{n}#{renderAttrs as} />|]
      (Standard
s forall a. Eq a => a -> a -> Bool
== Standard
Html)
  (EndTag NameTag
n) -> [i|</#{n}>|]
  (Content NameTag
t) -> NameTag
t
  (Comment NameTag
t) -> [i|<!--#{t}-->|]
  (Doctype NameTag
t) -> [i|<!#{t}>|]
  (Decl NameTag
t [Attr]
as) -> forall a. a -> a -> Bool -> a
bool [i|<?#{t}#{renderAttrs as}?>|] [i|<!#{t}!>|] (Standard
s forall a. Eq a => a -> a -> Bool
== Standard
Html)

-- | @Indented 0@ puts newlines in between the tags.
data RenderStyle = Compact | Indented Int deriving (RenderStyle -> RenderStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenderStyle -> RenderStyle -> Bool
$c/= :: RenderStyle -> RenderStyle -> Bool
== :: RenderStyle -> RenderStyle -> Bool
$c== :: RenderStyle -> RenderStyle -> Bool
Eq, Int -> RenderStyle -> ShowS
[RenderStyle] -> ShowS
RenderStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenderStyle] -> ShowS
$cshowList :: [RenderStyle] -> ShowS
show :: RenderStyle -> String
$cshow :: RenderStyle -> String
showsPrec :: Int -> RenderStyle -> ShowS
$cshowsPrec :: Int -> RenderStyle -> ShowS
Show, forall x. Rep RenderStyle x -> RenderStyle
forall x. RenderStyle -> Rep RenderStyle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RenderStyle x -> RenderStyle
$cfrom :: forall x. RenderStyle -> Rep RenderStyle x
Generic)

indentChildren :: RenderStyle -> [ByteString] -> [ByteString]
indentChildren :: RenderStyle -> [NameTag] -> [NameTag]
indentChildren RenderStyle
Compact = forall a. a -> a
id
indentChildren (Indented Int
x) =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char -> NameTag
B.replicate Int
x Char
' ' <>)

finalConcat :: RenderStyle -> [ByteString] -> ByteString
finalConcat :: RenderStyle -> [NameTag] -> NameTag
finalConcat RenderStyle
Compact = forall a. Monoid a => [a] -> a
mconcat
finalConcat (Indented Int
_) =
  NameTag -> [NameTag] -> NameTag
B.intercalate (Char -> NameTag
B.singleton Char
'\n')
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= NameTag
"")

-- | Convert 'Markup' to bytestrings
--
-- >>> markdown (Indented 4) Html (markup_ Html [i|<foo><br></foo>|])
-- That "<foo>\n    <br>\n</foo>"
markdown :: RenderStyle -> Standard -> Markup -> Warn ByteString
markdown :: RenderStyle -> Standard -> Markup -> Warn NameTag
markdown RenderStyle
r Standard
s Markup
m = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [NameTag] -> NameTag
finalConcat RenderStyle
r) forall a b. (a -> b) -> a -> b
$ forall a. [Warn [a]] -> Warn [a]
concatWarns forall a b. (a -> b) -> a -> b
$ forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (RenderStyle
-> Standard -> Token -> [Warn [NameTag]] -> Warn [NameTag]
renderBranch RenderStyle
r Standard
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Markup -> [Element]
elements forall a b. (a -> b) -> a -> b
$ Markup -> Markup
normContent Markup
m)

-- | Convert 'Markup' to 'ByteString' and error on warnings.
--
-- >>> B.putStr $ markdown_ (Indented 4) Html (markup_ Html [i|<foo><br></foo>|])
-- <foo>
--     <br>
-- </foo>
markdown_ :: RenderStyle -> Standard -> Markup -> ByteString
markdown_ :: RenderStyle -> Standard -> Markup -> NameTag
markdown_ RenderStyle
r Standard
s = RenderStyle -> Standard -> Markup -> Warn NameTag
markdown RenderStyle
r Standard
s forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Warn a -> a
warnError

-- note that renderBranch adds in EndTags for StartTags when needed
renderBranch :: RenderStyle -> Standard -> Token -> [Warn [ByteString]] -> Warn [ByteString]
renderBranch :: RenderStyle
-> Standard -> Token -> [Warn [NameTag]] -> Warn [NameTag]
renderBranch RenderStyle
r Standard
std s :: Token
s@(OpenTag OpenTagType
StartTag NameTag
n [Attr]
_) [Warn [NameTag]]
xs
  | NameTag
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NameTag]
selfClosers Bool -> Bool -> Bool
&& Standard
std forall a. Eq a => a -> a -> Bool
== Standard
Html =
      forall a b. b -> These a b
That [Standard -> Token -> NameTag
detokenize Standard
std Token
s] forall a. Semigroup a => a -> a -> a
<> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [NameTag] -> [NameTag]
indentChildren RenderStyle
r) (forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [NameTag]]
xs)
  | Bool
otherwise =
      forall a b. b -> These a b
That [Standard -> Token -> NameTag
detokenize Standard
std Token
s] forall a. Semigroup a => a -> a -> a
<> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [NameTag] -> [NameTag]
indentChildren RenderStyle
r) (forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [NameTag]]
xs) forall a. Semigroup a => a -> a -> a
<> forall a b. b -> These a b
That [Standard -> Token -> NameTag
detokenize Standard
std (NameTag -> Token
EndTag NameTag
n)]
renderBranch RenderStyle
_ Standard
std Token
x [] =
  forall a b. b -> These a b
That [Standard -> Token -> NameTag
detokenize Standard
std Token
x]
renderBranch RenderStyle
r Standard
std Token
x [Warn [NameTag]]
xs =
  forall a b. a -> b -> These a b
These [MarkupWarning
LeafWithChildren] [Standard -> Token -> NameTag
detokenize Standard
std Token
x] forall a. Semigroup a => a -> a -> a
<> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [NameTag] -> [NameTag]
indentChildren RenderStyle
r) (forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [NameTag]]
xs)

-- | Normalise Content in Markup, concatenating adjacent Content, and removing mempty Content.
--
-- >>> normContent $ content "a" <> content "" <> content "b"
-- Markup {elements = [Node {rootLabel = Content "ab", subForest = []}]}
normContent :: Markup -> Markup
normContent :: Markup -> Markup
normContent (Markup [Element]
trees) = [Element] -> Markup
Markup forall a b. (a -> b) -> a -> b
$ forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (\Token
x [Element]
xs -> forall a. a -> [Tree a] -> Tree a
Node Token
x (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= NameTag -> Token
Content NameTag
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
rootLabel) forall a b. (a -> b) -> a -> b
$ [Element] -> [Element]
concatContent [Element]
xs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element] -> [Element]
concatContent [Element]
trees

concatContent :: [Tree Token] -> [Tree Token]
concatContent :: [Element] -> [Element]
concatContent = \case
  ((Node (Content NameTag
t) [Element]
_) : (Node (Content NameTag
t') [Element]
_) : [Element]
ts) -> [Element] -> [Element]
concatContent forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Node (NameTag -> Token
Content (NameTag
t forall a. Semigroup a => a -> a -> a
<> NameTag
t')) [] forall a. a -> [a] -> [a]
: [Element]
ts
  (Element
t : [Element]
ts) -> Element
t forall a. a -> [a] -> [a]
: [Element] -> [Element]
concatContent [Element]
ts
  [] -> []

-- | Gather together token trees from a token list, placing child elements in nodes and removing EndTags.
--
-- >>> gather Html =<< tokenize Html "<foo class=\"bar\">baz</foo>"
-- That (Markup {elements = [Node {rootLabel = OpenTag StartTag "foo" [Attr {attrName = "class", attrValue = "bar"}], subForest = [Node {rootLabel = Content "baz", subForest = []}]}]})
gather :: Standard -> [Token] -> Warn Markup
gather :: Standard -> [Token] -> Warn Markup
gather Standard
s [Token]
ts = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Element] -> Markup
Markup forall a b. (a -> b) -> a -> b
$
  case ([Element]
finalSibs, [(Token, [Element])]
finalParents, [MarkupWarning]
warnings) of
    ([Element]
sibs, [], []) -> forall a b. b -> These a b
That (forall a. [a] -> [a]
reverse [Element]
sibs)
    ([], [], [MarkupWarning]
xs) -> forall a b. a -> These a b
This [MarkupWarning]
xs
    ([Element]
sibs, [(Token, [Element])]
ps, [MarkupWarning]
xs) ->
      forall a b. a -> b -> These a b
These ([MarkupWarning]
xs forall a. Semigroup a => a -> a -> a
<> [MarkupWarning
UnclosedTag]) (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Element]
ss' (Token
p, [Element]
ss) -> forall a. a -> [Tree a] -> Tree a
Node Token
p (forall a. [a] -> [a]
reverse [Element]
ss') forall a. a -> [a] -> [a]
: [Element]
ss) [Element]
sibs [(Token, [Element])]
ps)
  where
    (Cursor [Element]
finalSibs [(Token, [Element])]
finalParents, [MarkupWarning]
warnings) =
      forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Cursor
c, [MarkupWarning]
xs) Token
t -> Standard -> Token -> Cursor -> (Cursor, Maybe MarkupWarning)
incCursor Standard
s Token
t Cursor
c forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Maybe a -> [a]
maybeToList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall a. Semigroup a => a -> a -> a
<> [MarkupWarning]
xs))) ([Element] -> [(Token, [Element])] -> Cursor
Cursor [] [], []) [Token]
ts

-- | 'gather' but errors on warnings.
gather_ :: Standard -> [Token] -> Markup
gather_ :: Standard -> [Token] -> Markup
gather_ Standard
s [Token]
ts = Standard -> [Token] -> Warn Markup
gather Standard
s [Token]
ts forall a b. a -> (a -> b) -> b
& forall a. Warn a -> a
warnError

incCursor :: Standard -> Token -> Cursor -> (Cursor, Maybe MarkupWarning)
-- Only StartTags are ever pushed on to the parent list, here:
incCursor :: Standard -> Token -> Cursor -> (Cursor, Maybe MarkupWarning)
incCursor Standard
Xml t :: Token
t@(OpenTag OpenTagType
StartTag NameTag
_ [Attr]
_) (Cursor [Element]
ss [(Token, [Element])]
ps) = ([Element] -> [(Token, [Element])] -> Cursor
Cursor [] ((Token
t, [Element]
ss) forall a. a -> [a] -> [a]
: [(Token, [Element])]
ps), forall a. Maybe a
Nothing)
incCursor Standard
Html t :: Token
t@(OpenTag OpenTagType
StartTag NameTag
n [Attr]
_) (Cursor [Element]
ss [(Token, [Element])]
ps) =
  (forall a. a -> a -> Bool -> a
bool ([Element] -> [(Token, [Element])] -> Cursor
Cursor [] ((Token
t, [Element]
ss) forall a. a -> [a] -> [a]
: [(Token, [Element])]
ps)) ([Element] -> [(Token, [Element])] -> Cursor
Cursor (forall a. a -> [Tree a] -> Tree a
Node Token
t [] forall a. a -> [a] -> [a]
: [Element]
ss) [(Token, [Element])]
ps) (NameTag
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NameTag]
selfClosers), forall a. Maybe a
Nothing)
incCursor Standard
Xml t :: Token
t@(OpenTag OpenTagType
EmptyElemTag NameTag
_ [Attr]
_) (Cursor [Element]
ss [(Token, [Element])]
ps) = ([Element] -> [(Token, [Element])] -> Cursor
Cursor (forall a. a -> [Tree a] -> Tree a
Node Token
t [] forall a. a -> [a] -> [a]
: [Element]
ss) [(Token, [Element])]
ps, forall a. Maybe a
Nothing)
incCursor Standard
Html t :: Token
t@(OpenTag OpenTagType
EmptyElemTag NameTag
n [Attr]
_) (Cursor [Element]
ss [(Token, [Element])]
ps) =
  ( [Element] -> [(Token, [Element])] -> Cursor
Cursor (forall a. a -> [Tree a] -> Tree a
Node Token
t [] forall a. a -> [a] -> [a]
: [Element]
ss) [(Token, [Element])]
ps,
    forall a. a -> a -> Bool -> a
bool (forall a. a -> Maybe a
Just MarkupWarning
BadEmptyElemTag) forall a. Maybe a
Nothing (NameTag
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NameTag]
selfClosers)
  )
incCursor Standard
_ (EndTag NameTag
n) (Cursor [Element]
ss ((p :: Token
p@(OpenTag OpenTagType
StartTag NameTag
n' [Attr]
_), [Element]
ss') : [(Token, [Element])]
ps)) =
  ( [Element] -> [(Token, [Element])] -> Cursor
Cursor (forall a. a -> [Tree a] -> Tree a
Node Token
p (forall a. [a] -> [a]
reverse [Element]
ss) forall a. a -> [a] -> [a]
: [Element]
ss') [(Token, [Element])]
ps,
    forall a. a -> a -> Bool -> a
bool (forall a. a -> Maybe a
Just (NameTag -> NameTag -> MarkupWarning
TagMismatch NameTag
n NameTag
n')) forall a. Maybe a
Nothing (NameTag
n forall a. Eq a => a -> a -> Bool
== NameTag
n')
  )
-- Non-StartTag on parent list
incCursor Standard
_ (EndTag NameTag
_) (Cursor [Element]
ss ((Token
p, [Element]
ss') : [(Token, [Element])]
ps)) =
  ( [Element] -> [(Token, [Element])] -> Cursor
Cursor (forall a. a -> [Tree a] -> Tree a
Node Token
p (forall a. [a] -> [a]
reverse [Element]
ss) forall a. a -> [a] -> [a]
: [Element]
ss') [(Token, [Element])]
ps,
    forall a. a -> Maybe a
Just MarkupWarning
LeafWithChildren
  )
incCursor Standard
_ (EndTag NameTag
_) (Cursor [Element]
ss []) =
  ( [Element] -> [(Token, [Element])] -> Cursor
Cursor [Element]
ss [],
    forall a. a -> Maybe a
Just MarkupWarning
UnmatchedEndTag
  )
incCursor Standard
_ Token
t (Cursor [Element]
ss [(Token, [Element])]
ps) = ([Element] -> [(Token, [Element])] -> Cursor
Cursor (forall a. a -> [Tree a] -> Tree a
Node Token
t [] forall a. a -> [a] -> [a]
: [Element]
ss) [(Token, [Element])]
ps, forall a. Maybe a
Nothing)

data Cursor = Cursor
  { -- siblings, not (yet) part of another element
    Cursor -> [Element]
_sibs :: [Tree Token],
    -- open elements and their siblings.
    Cursor -> [(Token, [Element])]
_stack :: [(Token, [Tree Token])]
  }

-- | Convert a markup into a token list, adding end tags.
--
-- >>> degather Html =<< markup Html "<foo class=\"bar\">baz</foo>"
-- That [OpenTag StartTag "foo" [Attr {attrName = "class", attrValue = "bar"}],Content "baz",EndTag "foo"]
degather :: Standard -> Markup -> Warn [Token]
degather :: Standard -> Markup -> Warn [Token]
degather Standard
s (Markup [Element]
tree) = forall a. [Warn [a]] -> Warn [a]
concatWarns forall a b. (a -> b) -> a -> b
$ forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (Standard -> Token -> [Warn [Token]] -> Warn [Token]
addCloseTags Standard
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element]
tree

-- | 'degather' but errors on warning
degather_ :: Standard -> Markup -> [Token]
degather_ :: Standard -> Markup -> [Token]
degather_ Standard
s Markup
m = Standard -> Markup -> Warn [Token]
degather Standard
s Markup
m forall a b. a -> (a -> b) -> b
& forall a. Warn a -> a
warnError

concatWarns :: [Warn [a]] -> Warn [a]
concatWarns :: forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [a]]
rs = case forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Monoid a => [a] -> a
mconcat forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. [These a b] -> ([a], [b])
partitionHereThere [Warn [a]]
rs of
  ([], [a]
xs) -> forall a b. b -> These a b
That [a]
xs
  ([MarkupWarning]
es, []) -> forall a b. a -> These a b
This [MarkupWarning]
es
  ([MarkupWarning]
es, [a]
xs) -> forall a b. a -> b -> These a b
These [MarkupWarning]
es [a]
xs

addCloseTags :: Standard -> Token -> [Warn [Token]] -> Warn [Token]
addCloseTags :: Standard -> Token -> [Warn [Token]] -> Warn [Token]
addCloseTags Standard
std s :: Token
s@(OpenTag OpenTagType
StartTag NameTag
n [Attr]
_) [Warn [Token]]
children
  | [Warn [Token]]
children forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& NameTag
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NameTag]
selfClosers Bool -> Bool -> Bool
&& Standard
std forall a. Eq a => a -> a -> Bool
== Standard
Html =
      forall a b. a -> b -> These a b
These [MarkupWarning
SelfCloserWithChildren] [Token
s] forall a. Semigroup a => a -> a -> a
<> forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [Token]]
children
  | NameTag
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NameTag]
selfClosers Bool -> Bool -> Bool
&& Standard
std forall a. Eq a => a -> a -> Bool
== Standard
Html =
      forall a b. b -> These a b
That [Token
s] forall a. Semigroup a => a -> a -> a
<> forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [Token]]
children
  | Bool
otherwise =
      forall a b. b -> These a b
That [Token
s] forall a. Semigroup a => a -> a -> a
<> forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [Token]]
children forall a. Semigroup a => a -> a -> a
<> forall a b. b -> These a b
That [NameTag -> Token
EndTag NameTag
n]
addCloseTags Standard
_ Token
x [Warn [Token]]
xs = case [Warn [Token]]
xs of
  [] -> forall a b. b -> These a b
That [Token
x]
  [Warn [Token]]
cs -> forall a b. a -> b -> These a b
These [MarkupWarning
LeafWithChildren] [Token
x] forall a. Semigroup a => a -> a -> a
<> forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [Token]]
cs

tokenXmlP :: Parser e Token
tokenXmlP :: forall e. Parser e Token
tokenXmlP =
  $( switch
       [|
         case _ of
           "<!--" -> commentP
           "<!" -> doctypeXmlP
           "</" -> endTagXmlP
           "<?" -> declXmlP
           "<" -> startTagsXmlP
           _ -> contentP
         |]
   )

-- [4]
nameStartCharP :: Parser e Char
nameStartCharP :: forall e. Parser e Char
nameStartCharP = forall (st :: ZeroBitType) e.
(Char -> Bool)
-> (Char -> Bool)
-> (Char -> Bool)
-> (Char -> Bool)
-> ParserT st e Char
fusedSatisfy Char -> Bool
isLatinLetter Char -> Bool
isNameStartChar Char -> Bool
isNameStartChar Char -> Bool
isNameStartChar

isNameStartChar :: Char -> Bool
isNameStartChar :: Char -> Bool
isNameStartChar Char
x =
  (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'z')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'Z')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
':')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'_')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xC0' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xD6')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xD8' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xF6')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xF8' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x2FF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x370' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x37D')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x37F' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x1FFF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x200C' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x200D')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x2070' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x218F')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x2C00' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x2FEF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x3001' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xD7FF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xF900' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xFDCF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xFDF0' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xFFFD')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x10000' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xEFFFF')

-- [4a]
nameCharP :: Parser e Char
nameCharP :: forall e. Parser e Char
nameCharP = forall (st :: ZeroBitType) e.
(Char -> Bool)
-> (Char -> Bool)
-> (Char -> Bool)
-> (Char -> Bool)
-> ParserT st e Char
fusedSatisfy Char -> Bool
isNameCharAscii Char -> Bool
isNameCharExt Char -> Bool
isNameCharExt Char -> Bool
isNameCharExt

isNameCharAscii :: Char -> Bool
isNameCharAscii :: Char -> Bool
isNameCharAscii Char
x =
  (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'z')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'Z')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'9')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
':')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'_')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'-')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'.')

isNameCharExt :: Char -> Bool
isNameCharExt :: Char -> Bool
isNameCharExt Char
x =
  (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'z')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'Z')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'9')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
':')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'_')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'-')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'.')
    Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'\xB7')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xC0' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xD6')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xD8' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xF6')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xF8' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x2FF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x300' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x36F')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x370' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x37D')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x37F' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x1FFF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x200C' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x200D')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x203F' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x2040')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x2070' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x218F')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x2C00' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\x2FEF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x3001' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xD7FF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xF900' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xFDCF')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\xFDF0' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xFFFD')
    Bool -> Bool -> Bool
|| (Char
x forall a. Ord a => a -> a -> Bool
>= Char
'\x10000' Bool -> Bool -> Bool
&& Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xEFFFF')

-- | name string according to xml production rule [5]
nameXmlP :: Parser e ByteString
nameXmlP :: forall e. Parser e NameTag
nameXmlP = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf (forall e. Parser e Char
nameStartCharP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall e. Parser e Char
nameCharP)

commentCloseP :: Parser e ()
commentCloseP :: forall e. Parser e ()
commentCloseP = $(string "-->")

charNotMinusP :: Parser e ByteString
charNotMinusP :: forall e. Parser e NameTag
charNotMinusP = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf forall a b. (a -> b) -> a -> b
$ forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'-')

minusPlusCharP :: Parser e ByteString
minusPlusCharP :: forall e. Parser e NameTag
minusPlusCharP = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf ($(char '-') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e NameTag
charNotMinusP)

commentP :: Parser e Token
commentP :: forall e. Parser e Token
commentP = NameTag -> Token
Comment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall e. Parser e NameTag
charNotMinusP forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> forall e. Parser e NameTag
minusPlusCharP)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
commentCloseP

contentP :: Parser e Token
contentP :: forall e. Parser e Token
contentP = NameTag -> Token
Content forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf (forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'<')))

-- | XML declaration as per production rule [23]
declXmlP :: Parser e Token
declXmlP :: forall e. Parser e Token
declXmlP = do
  ()
_ <- $(string "xml")
  Attr
av <- NameTag -> NameTag -> Attr
Attr NameTag
"version" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Parser e NameTag
xmlVersionInfoP
  Attr
en <- NameTag -> NameTag -> Attr
Attr NameTag
"encoding" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Parser e NameTag
xmlEncodingDeclP
  Maybe Attr
st <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ NameTag -> NameTag -> Attr
Attr NameTag
"standalone" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Parser e NameTag
xmlStandaloneP
  ()
_ <- forall e. Parser e ()
ws_
  ()
_ <- $(string "?>")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NameTag -> [Attr] -> Token
Decl NameTag
"xml" forall a b. (a -> b) -> a -> b
$ [Attr
av, Attr
en] forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList Maybe Attr
st

-- | xml production [24]
xmlVersionInfoP :: Parser e ByteString
xmlVersionInfoP :: forall e. Parser e NameTag
xmlVersionInfoP = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf forall a b. (a -> b) -> a -> b
$ forall e. Parser e ()
ws_ forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> $(string "version") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e ()
eq forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e a. Parser e a -> Parser e a
wrappedQNoGuard forall e. Parser e NameTag
xmlVersionNumP

-- | xml production [26]
xmlVersionNumP :: Parser e ByteString
xmlVersionNumP :: forall e. Parser e NameTag
xmlVersionNumP =
  forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf ($(string "1.") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isDigit))

-- | Doctype declaration as per production rule [28]
doctypeXmlP :: Parser e Token
doctypeXmlP :: forall e. Parser e Token
doctypeXmlP =
  NameTag -> Token
Doctype
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf
      ( $(string "DOCTYPE")
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e ()
ws_
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e NameTag
nameXmlP
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          -- optional (ws_ >> xmlExternalID) >>
          forall e. Parser e ()
ws_
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall e. Parser e String
bracketedSB
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e ()
ws_
      )
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '>')

-- | xml production [32]
xmlStandaloneP :: Parser e ByteString
xmlStandaloneP :: forall e. Parser e NameTag
xmlStandaloneP =
  forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf forall a b. (a -> b) -> a -> b
$
    forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(string "standalone") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e ()
eq forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e NameTag
xmlYesNoP

-- | xml yes/no
xmlYesNoP :: Parser e ByteString
xmlYesNoP :: forall e. Parser e NameTag
xmlYesNoP = forall e a. Parser e a -> Parser e a
wrappedQNoGuard (forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf forall a b. (a -> b) -> a -> b
$ $(string "yes") forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> $(string "no"))

-- | xml production [80]
xmlEncodingDeclP :: Parser e ByteString
xmlEncodingDeclP :: forall e. Parser e NameTag
xmlEncodingDeclP = forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(string "encoding") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e ()
eq forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e a. Parser e a -> Parser e a
wrappedQNoGuard forall e. Parser e NameTag
xmlEncNameP

-- | xml production [81]
xmlEncNameP :: Parser e ByteString
xmlEncNameP :: forall e. Parser e NameTag
xmlEncNameP = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfyAscii Char -> Bool
isLatinLetter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfyAscii (\Char
x -> Char -> Bool
isLatinLetter Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
x (String
"._-" :: [Char]))))

-- | open xml tag as per xml production rule [40]
--  self-closing xml tag as per [44]
startTagsXmlP :: Parser e Token
startTagsXmlP :: forall e. Parser e Token
startTagsXmlP = do
  !NameTag
n <- forall e. Parser e NameTag
nameXmlP
  ![Attr]
as <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e Attr
attrXmlP)
  ()
_ <- forall e. Parser e ()
ws_
  $( switch
       [|
         case _ of
           "/>" -> pure (OpenTag EmptyElemTag n as)
           ">" -> pure (OpenTag StartTag n as)
         |]
   )

attrXmlP :: Parser e Attr
attrXmlP :: forall e. Parser e Attr
attrXmlP = NameTag -> NameTag -> Attr
Attr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e. Parser e NameTag
nameXmlP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
eq) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e. Parser e NameTag
wrappedQ

-- | closing tag as per [42]
endTagXmlP :: Parser e Token
endTagXmlP :: forall e. Parser e Token
endTagXmlP = NameTag -> Token
EndTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e. Parser e NameTag
nameXmlP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '>'))

-- | Parse a single 'Token'.
tokenHtmlP :: Parser e Token
tokenHtmlP :: forall e. Parser e Token
tokenHtmlP =
  $( switch
       [|
         case _ of
           "<!--" -> commentP
           "<!" -> doctypeHtmlP
           "</" -> endTagHtmlP
           "<?" -> bogusCommentHtmlP
           "<" -> startTagsHtmlP
           _ -> contentP
         |]
   )

bogusCommentHtmlP :: Parser e Token
bogusCommentHtmlP :: forall e. Parser e Token
bogusCommentHtmlP = NameTag -> Token
Comment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf (forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'<')))

doctypeHtmlP :: Parser e Token
doctypeHtmlP :: forall e. Parser e Token
doctypeHtmlP =
  NameTag -> Token
Doctype
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf
      ( $(string "DOCTYPE")
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e ()
ws_
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e NameTag
nameHtmlP
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Parser e ()
ws_
      )
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '>')

startTagsHtmlP :: Parser e Token
startTagsHtmlP :: forall e. Parser e Token
startTagsHtmlP = do
  NameTag
n <- forall e. Parser e NameTag
nameHtmlP
  [Attr]
as <- forall a. Standard -> Parser a [Attr]
attrsP Standard
Html
  ()
_ <- forall e. Parser e ()
ws_
  $( switch
       [|
         case _ of
           "/>" -> pure (OpenTag EmptyElemTag n as)
           ">" -> pure (OpenTag StartTag n as)
         |]
   )

endTagHtmlP :: Parser e Token
endTagHtmlP :: forall e. Parser e Token
endTagHtmlP = NameTag -> Token
EndTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Parser e NameTag
nameHtmlP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '>')

-- | Parse a tag name. Each standard is slightly different.
nameP :: Standard -> Parser e ByteString
nameP :: forall e. Standard -> Parser e NameTag
nameP Standard
Html = forall e. Parser e NameTag
nameHtmlP
nameP Standard
Xml = forall e. Parser e NameTag
nameXmlP

nameHtmlP :: Parser e ByteString
nameHtmlP :: forall e. Parser e NameTag
nameHtmlP = do
  forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf (forall e. Parser e Char
nameStartCharHtmlP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isNameChar))

nameStartCharHtmlP :: Parser e Char
nameStartCharHtmlP :: forall e. Parser e Char
nameStartCharHtmlP = forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfyAscii Char -> Bool
isLatinLetter

isNameChar :: Char -> Bool
isNameChar :: Char -> Bool
isNameChar Char
x =
  Bool -> Bool
not
    ( Char -> Bool
isWhitespace Char
x
        Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'/')
        Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'<')
        Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'>')
    )

attrHtmlP :: Parser e Attr
attrHtmlP :: forall e. Parser e Attr
attrHtmlP =
  (NameTag -> NameTag -> Attr
Attr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e. Parser e NameTag
attrNameP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
eq) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e. Parser e NameTag
wrappedQ forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> forall e. Parser e NameTag
attrBooleanNameP))
    forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> ((NameTag -> NameTag -> Attr
`Attr` forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Parser e NameTag
attrBooleanNameP)

attrBooleanNameP :: Parser e ByteString
attrBooleanNameP :: forall e. Parser e NameTag
attrBooleanNameP = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e NameTag
byteStringOf forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isBooleanAttrName)

-- | Parse an 'Attr'
attrP :: Standard -> Parser a Attr
attrP :: forall a. Standard -> Parser a Attr
attrP Standard
Html = forall e. Parser e Attr
attrHtmlP
attrP Standard
Xml = forall e. Parser e Attr
attrXmlP

-- | Parse attributions
attrsP :: Standard -> Parser a [Attr]
attrsP :: forall a. Standard -> Parser a [Attr]
attrsP Standard
s = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Standard -> Parser a Attr
attrP Standard
s) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
ws_

attrNameP :: Parser e ByteString
attrNameP :: forall e. Parser e NameTag
attrNameP = forall e. (Char -> Bool) -> Parser e NameTag
isa Char -> Bool
isAttrName

isAttrName :: Char -> Bool
isAttrName :: Char -> Bool
isAttrName Char
x =
  Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
    Char -> Bool
isWhitespace Char
x
      Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'/')
      Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'>')
      Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'=')

isBooleanAttrName :: Char -> Bool
isBooleanAttrName :: Char -> Bool
isBooleanAttrName Char
x =
  Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
    Char -> Bool
isWhitespace Char
x
      Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'/')
      Bool -> Bool -> Bool
|| (Char
x forall a. Eq a => a -> a -> Bool
== Char
'>')