{-# LANGUAGE PackageImports  #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE TypeFamilies  #-}
{-|
Module: IHP.HSX.Parser
Description: Parser for HSX code
Copyright: (c) digitally induced GmbH, 2022
-}
module IHP.HSX.Parser
( parseHsx
, Node (..)
, Attribute (..)
, AttributeValue (..)
, collapseSpace
) where

import Prelude
import Data.Text
import Data.Set
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Void
import qualified Data.Char as Char
import qualified Data.Text as Text
import Control.Monad.Fail
import Data.String.Conversions
import qualified Data.List as List
import Control.Monad (unless)
import Prelude (show)
import qualified Language.Haskell.Meta as Haskell
import qualified Language.Haskell.TH.Syntax as Haskell
import qualified "template-haskell" Language.Haskell.TH as TH
import qualified Data.Set as Set
import qualified Data.Containers.ListUtils as List

data AttributeValue = TextValue !Text | ExpressionValue !Haskell.Exp deriving (AttributeValue -> AttributeValue -> Bool
(AttributeValue -> AttributeValue -> Bool)
-> (AttributeValue -> AttributeValue -> Bool) -> Eq AttributeValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeValue -> AttributeValue -> Bool
$c/= :: AttributeValue -> AttributeValue -> Bool
== :: AttributeValue -> AttributeValue -> Bool
$c== :: AttributeValue -> AttributeValue -> Bool
Eq, Int -> AttributeValue -> ShowS
[AttributeValue] -> ShowS
AttributeValue -> String
(Int -> AttributeValue -> ShowS)
-> (AttributeValue -> String)
-> ([AttributeValue] -> ShowS)
-> Show AttributeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeValue] -> ShowS
$cshowList :: [AttributeValue] -> ShowS
show :: AttributeValue -> String
$cshow :: AttributeValue -> String
showsPrec :: Int -> AttributeValue -> ShowS
$cshowsPrec :: Int -> AttributeValue -> ShowS
Show)

data Attribute = StaticAttribute !Text !AttributeValue | SpreadAttributes !Haskell.Exp deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq, Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show)

data Node = Node !Text ![Attribute] ![Node] !Bool
    | TextNode !Text
    | PreEscapedTextNode !Text -- ^ Used in @script@ or @style@ bodies
    | SplicedNode !Haskell.Exp -- ^ Inline haskell expressions like @{myVar}@ or @{f "hello"}@
    | Children ![Node]
    | CommentNode !Text
    deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq, Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show)

-- | Parses a HSX text and returns a 'Node'
--
-- __Example:__
--
-- > let filePath = "my-template"
-- > let line = 0
-- > let col = 0
-- > let position = Megaparsec.SourcePos filePath (Megaparsec.mkPos line) (Megaparsec.mkPos col)
-- > let hsxText = "<strong>Hello</strong>"
-- >
-- > let (Right node) = parseHsx position hsxText
parseHsx :: SourcePos -> Text -> Either (ParseErrorBundle Text Void) Node
parseHsx :: SourcePos -> Text -> Either (ParseErrorBundle Text Void) Node
parseHsx SourcePos
position Text
code = Parsec Void Text Node
-> String -> Text -> Either (ParseErrorBundle Text Void) Node
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (SourcePos -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => SourcePos -> m ()
setPosition SourcePos
position ParsecT Void Text Identity ()
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Node
parser) String
"" Text
code

type Parser = Parsec Void Text

setPosition :: SourcePos -> m ()
setPosition SourcePos
pstateSourcePos = (State s e -> State s e) -> m ()
forall e s (m :: * -> *).
MonadParsec e s m =>
(State s e -> State s e) -> m ()
updateParserState (\State s e
state -> State s e
state {
        statePosState :: PosState s
statePosState = (State s e -> PosState s
forall s e. State s e -> PosState s
statePosState State s e
state) { SourcePos
pstateSourcePos :: SourcePos
pstateSourcePos :: SourcePos
pstateSourcePos }
    })

parser :: Parser Node
parser :: Parsec Void Text Node
parser = do
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    Node
node <- Parsec Void Text Node
manyHsxElement Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxElement
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
    Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
node

hsxElement :: Parsec Void Text Node
hsxElement = Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Node
hsxComment Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Node
hsxSelfClosingElement Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxNormalElement

manyHsxElement :: Parsec Void Text Node
manyHsxElement = do
    [Node]
children <- Parsec Void Text Node -> ParsecT Void Text Identity [Node]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parsec Void Text Node
hsxChild
    Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> Node
Children ([Node] -> [Node]
stripTextNodeWhitespaces [Node]
children))

hsxSelfClosingElement :: Parsec Void Text Node
hsxSelfClosingElement = do
    Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'<'
    Text
name <- Parser Text
hsxElementName
    let isLeaf :: Bool
isLeaf = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
leafs
    [Attribute]
attributes <-
      if Bool
isLeaf
        then Parser Text -> Parser [Attribute]
forall a. Parser a -> Parser [Attribute]
hsxNodeAttributes (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
">" Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"/>")
        else Parser Text -> Parser [Attribute]
forall a. Parser a -> Parser [Attribute]
hsxNodeAttributes (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"/>")
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Attribute] -> [Node] -> Bool -> Node
Node Text
name [Attribute]
attributes [] Bool
isLeaf)

hsxNormalElement :: Parsec Void Text Node
hsxNormalElement = do
    (Text
name, [Attribute]
attributes) <- ParsecT Void Text Identity (Text, [Attribute])
hsxOpeningElement
    let parsePreEscapedTextChildren :: (Text -> Text) -> ParsecT Void Text Identity [Node]
parsePreEscapedTextChildren Text -> Text
transformText = do
                    let closingElement :: Text
closingElement = Text
"</" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
                    Text
text <- String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> Parser Text -> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
closingElement)
                    [Node] -> ParsecT Void Text Identity [Node]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Node
PreEscapedTextNode (Text -> Text
transformText Text
text)]
    let parseNormalHSXChildren :: ParsecT Void Text Identity [Node]
parseNormalHSXChildren = [Node] -> [Node]
stripTextNodeWhitespaces ([Node] -> [Node])
-> ParsecT Void Text Identity [Node]
-> ParsecT Void Text Identity [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Node]
-> ParsecT Void Text Identity [Node]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parsec Void Text Node
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Node]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Node
hsxChild) (ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, IsString (Tokens s), Semigroup (Tokens s),
 Token s ~ Char, Tokens s ~ Text) =>
Text -> m ()
hsxClosingElement Text
name))))

    -- script and style tags have special handling for their children. Inside those tags
    -- we allow any kind of content. Using a haskell expression like @<script>{myHaskellExpr}</script>@
    -- will just literally output the string @{myHaskellExpr}@ without evaluating the haskell expression itself.
    --
    -- Here is an example HSX code explaining the problem:
    -- [hsx|<style>h1 { color: red; }</style>|]
    -- The @{ color: red; }@ would be parsed as a inline haskell expression without the special handling
    --
    -- Additionally we don't do the usual escaping for style and script bodies, as this will make e.g. the
    -- javascript unusuable.
    [Node]
children <- case Text
name of
            Text
"script" -> (Text -> Text) -> ParsecT Void Text Identity [Node]
parsePreEscapedTextChildren Text -> Text
Text.strip
            Text
"style" -> (Text -> Text) -> ParsecT Void Text Identity [Node]
parsePreEscapedTextChildren (Text -> Text
collapseSpace (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip)
            Text
otherwise -> ParsecT Void Text Identity [Node]
parseNormalHSXChildren
    Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Attribute] -> [Node] -> Bool -> Node
Node Text
name [Attribute]
attributes [Node]
children Bool
False)

hsxOpeningElement :: ParsecT Void Text Identity (Text, [Attribute])
hsxOpeningElement = do
    Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'<'
    Text
name <- Parser Text
hsxElementName
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    [Attribute]
attributes <- ParsecT Void Text Identity Char -> Parser [Attribute]
forall a. Parser a -> Parser [Attribute]
hsxNodeAttributes (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'>')
    (Text, [Attribute])
-> ParsecT Void Text Identity (Text, [Attribute])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, [Attribute]
attributes)

hsxComment :: Parser Node
hsxComment :: Parsec Void Text Node
hsxComment = do
    Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"<!--"
    String
body :: String <- ParsecT Void Text Identity Char
-> Parser Text -> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)) (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-->")
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Node
CommentNode (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
body))


hsxNodeAttributes :: Parser a -> Parser [Attribute]
hsxNodeAttributes :: Parser a -> Parser [Attribute]
hsxNodeAttributes Parser a
end = Parser [Attribute]
staticAttributes
    where
        staticAttributes :: Parser [Attribute]
staticAttributes = do
            [Attribute]
attributes <- ParsecT Void Text Identity Attribute
-> Parser a -> Parser [Attribute]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (ParsecT Void Text Identity Attribute
hsxNodeAttribute ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Attribute
hsxSplicedAttributes) Parser a
end
            let staticAttributes :: [Attribute]
staticAttributes = (Attribute -> Bool) -> [Attribute] -> [Attribute]
forall a. (a -> Bool) -> [a] -> [a]
List.filter Attribute -> Bool
isStaticAttribute [Attribute]
attributes
            let keys :: [Text]
keys = (Attribute -> Text) -> [Attribute] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
List.map (\(StaticAttribute Text
name AttributeValue
_) -> Text
name) [Attribute]
staticAttributes
            let uniqueKeys :: [Text]
uniqueKeys = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
List.nubOrd [Text]
keys
            Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
keys [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
uniqueKeys) (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Duplicate attribute found in tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show ([Text]
keys [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [Text]
uniqueKeys))
            [Attribute] -> Parser [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Attribute]
attributes

isStaticAttribute :: Attribute -> Bool
isStaticAttribute (StaticAttribute Text
_ AttributeValue
_) = Bool
True
isStaticAttribute Attribute
_ = Bool
False

hsxSplicedAttributes :: Parser Attribute
hsxSplicedAttributes :: ParsecT Void Text Identity Attribute
hsxSplicedAttributes = do
    Text
name <- Parser Text -> Parser Text -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"{...") (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"}") (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'))
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    Exp
haskellExpression <- case String -> Either String Exp
Haskell.parseExp (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
name) of
            Right Exp
expression -> Exp -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp
patchExpr Exp
expression)
            Left String
error -> String -> ParsecT Void Text Identity Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall a. Show a => a -> String
show String
error)
    Attribute -> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Attribute
SpreadAttributes Exp
haskellExpression)

hsxNodeAttribute :: ParsecT Void Text Identity Attribute
hsxNodeAttribute = do
    Text
key <- Parser Text
hsxAttributeName
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

    -- Boolean attributes like <input disabled/> will be represented as <input disabled="disabled"/>
    -- as there is currently no other way to represent them with blaze-html.
    --
    -- There's a special case for data attributes: Data attributes like <form data-disable-javascript-submission/> will be represented as <form data-disable-javascript-submission="true"/>
    --
    -- See: https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes
    let attributeWithoutValue :: ParsecT Void Text Identity Attribute
attributeWithoutValue = do
            let value :: Text
value = if Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
key
                    then Text
"true"
                    else Text
key
            Attribute -> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AttributeValue -> Attribute
StaticAttribute Text
key (Text -> AttributeValue
TextValue Text
value))

    -- Parsing normal attributes like <input value="Hello"/>
    let attributeWithValue :: ParsecT Void Text Identity Attribute
attributeWithValue = do
            Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'='
            ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
            AttributeValue
value <- Parser AttributeValue
hsxQuotedValue Parser AttributeValue
-> Parser AttributeValue -> Parser AttributeValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser AttributeValue
hsxSplicedValue
            ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
            Attribute -> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AttributeValue -> Attribute
StaticAttribute Text
key AttributeValue
value)

    ParsecT Void Text Identity Attribute
attributeWithValue ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Attribute
attributeWithoutValue


hsxAttributeName :: Parser Text
hsxAttributeName :: Parser Text
hsxAttributeName = do
        Text
name <- Parser Text
ParsecT Void Text Identity (Tokens Text)
rawAttribute
        Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
isValidAttributeName Text
name) (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid attribute name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
name)
        Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name
    where
        isValidAttributeName :: Text -> Bool
isValidAttributeName Text
name =
            Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
            Bool -> Bool -> Bool
|| Text
"aria-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
            Bool -> Bool -> Bool
|| Text
"hx-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
            Bool -> Bool -> Bool
|| Text
"hx-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
            Bool -> Bool -> Bool
|| Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
attributes

        rawAttribute :: ParsecT Void Text Identity (Tokens Text)
rawAttribute = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')


hsxQuotedValue :: Parser AttributeValue
hsxQuotedValue :: Parser AttributeValue
hsxQuotedValue = do
    Text
value <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"'))
    AttributeValue -> Parser AttributeValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AttributeValue
TextValue Text
value)

hsxSplicedValue :: Parser AttributeValue
hsxSplicedValue :: Parser AttributeValue
hsxSplicedValue = do
    Text
value <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'}') (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'))
    Exp
haskellExpression <- case String -> Either String Exp
Haskell.parseExp (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
value) of
            Right Exp
expression -> Exp -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp
patchExpr Exp
expression)
            Left String
error -> String -> ParsecT Void Text Identity Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall a. Show a => a -> String
show String
error)
    AttributeValue -> Parser AttributeValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> AttributeValue
ExpressionValue Exp
haskellExpression)

hsxClosingElement :: Text -> m ()
hsxClosingElement Text
name = (Tokens s -> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, IsString (Tokens s), Semigroup (Tokens s),
 Token s ~ Char) =>
Tokens s -> m ()
hsxClosingElement' Text
Tokens s
name) m () -> String -> m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
friendlyErrorMessage
    where
        friendlyErrorMessage :: String
friendlyErrorMessage = ShowS
forall a. Show a => a -> String
show (Text -> String
Text.unpack (Text
"</" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"))
        hsxClosingElement' :: Tokens s -> m ()
hsxClosingElement' Tokens s
name = do
            Tokens s
_ <- Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Tokens s
"</" Tokens s -> Tokens s -> Tokens s
forall a. Semigroup a => a -> a -> a
<> Tokens s
name)
            m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
            Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char (Char
Token s
'>')
            () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

hsxChild :: Parsec Void Text Node
hsxChild = Parsec Void Text Node
hsxElement Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxSplicedNode Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> Parsec Void Text Node -> Parsec Void Text Node
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parsec Void Text Node
hsxElement) Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxText

-- | Parses a hsx text node
--
-- Stops parsing when hitting a variable, like `{myVar}`
hsxText :: Parser Node
hsxText :: Parsec Void Text Node
hsxText = Text -> Node
buildTextNode (Text -> Node) -> Parser Text -> Parsec Void Text Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"text") (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'<' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>')

-- | Builds a TextNode and strips all surround whitespace from the input string
buildTextNode :: Text -> Node
buildTextNode :: Text -> Node
buildTextNode Text
value = Text -> Node
TextNode (Text -> Text
collapseSpace Text
value)

data TokenTree = TokenLeaf Text | TokenNode [TokenTree] deriving (Int -> TokenTree -> ShowS
[TokenTree] -> ShowS
TokenTree -> String
(Int -> TokenTree -> ShowS)
-> (TokenTree -> String)
-> ([TokenTree] -> ShowS)
-> Show TokenTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenTree] -> ShowS
$cshowList :: [TokenTree] -> ShowS
show :: TokenTree -> String
$cshow :: TokenTree -> String
showsPrec :: Int -> TokenTree -> ShowS
$cshowsPrec :: Int -> TokenTree -> ShowS
Show)

hsxSplicedNode :: Parser Node
hsxSplicedNode :: Parsec Void Text Node
hsxSplicedNode = do
        Text
expression <- Parser Text
doParse
        Exp
haskellExpression <- case String -> Either String Exp
Haskell.parseExp (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
expression) of
                Right Exp
expression -> Exp -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp
patchExpr Exp
expression)
                Left String
error -> String -> ParsecT Void Text Identity Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall a. Show a => a -> String
show String
error)
        Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Node
SplicedNode Exp
haskellExpression)
    where
        doParse :: Parser Text
doParse = do
            TokenTree
tree <- ParsecT Void Text Identity TokenTree
node
            let value :: Text
value = (Text -> TokenTree -> Text
treeToString Text
"" TokenTree
tree)
            Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.init (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.tail Text
value

        parseTree :: ParsecT Void Text Identity TokenTree
parseTree = ParsecT Void Text Identity TokenTree
node ParsecT Void Text Identity TokenTree
-> ParsecT Void Text Identity TokenTree
-> ParsecT Void Text Identity TokenTree
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity TokenTree
leaf
        node :: ParsecT Void Text Identity TokenTree
node = [TokenTree] -> TokenTree
TokenNode ([TokenTree] -> TokenTree)
-> ParsecT Void Text Identity [TokenTree]
-> ParsecT Void Text Identity TokenTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [TokenTree]
-> ParsecT Void Text Identity [TokenTree]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'}') (ParsecT Void Text Identity TokenTree
-> ParsecT Void Text Identity [TokenTree]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity TokenTree
parseTree)
        leaf :: ParsecT Void Text Identity TokenTree
leaf = Text -> TokenTree
TokenLeaf (Text -> TokenTree)
-> Parser Text -> ParsecT Void Text Identity TokenTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
        treeToString :: Text -> TokenTree -> Text
        treeToString :: Text -> TokenTree -> Text
treeToString Text
acc (TokenLeaf Text
value)  = Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value
        treeToString Text
acc (TokenNode [])     = Text
acc
        treeToString Text
acc (TokenNode (TokenTree
x:[TokenTree]
xs)) = ((Text -> TokenTree -> Text
treeToString (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{") TokenTree
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (TokenTree -> Text) -> [TokenTree] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> TokenTree -> Text
treeToString Text
"") [TokenTree]
xs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"


hsxElementName :: Parser Text
hsxElementName :: Parser Text
hsxElementName = do
    Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier") (\Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
    let isValidParent :: Bool
isValidParent = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
parents
    let isValidLeaf :: Bool
isValidLeaf = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
leafs
    let isValidCustomWebComponent :: Bool
isValidCustomWebComponent = Text
"-" Text -> Text -> Bool
`Text.isInfixOf` Text
name
    Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isValidParent Bool -> Bool -> Bool
|| Bool
isValidLeaf Bool -> Bool -> Bool
|| Bool
isValidCustomWebComponent) (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid tag name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
name)
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name

hsxIdentifier :: Parser Text
hsxIdentifier :: Parser Text
hsxIdentifier = do
    Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier") (\Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
    Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name


attributes :: Set Text
attributes :: Set Text
attributes = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Text
"accept", Text
"accept-charset", Text
"accesskey", Text
"action", Text
"alt", Text
"async"
        , Text
"autocomplete", Text
"autofocus", Text
"autoplay", Text
"challenge", Text
"charset"
        , Text
"checked", Text
"cite", Text
"class", Text
"cols", Text
"colspan", Text
"content"
        , Text
"contenteditable", Text
"contextmenu", Text
"controls", Text
"coords", Text
"data"
        , Text
"datetime", Text
"defer", Text
"dir", Text
"disabled", Text
"draggable", Text
"enctype"
        , Text
"form", Text
"formaction", Text
"formenctype", Text
"formmethod", Text
"formnovalidate"
        , Text
"for"
        , Text
"formtarget", Text
"headers", Text
"height", Text
"hidden", Text
"high", Text
"href"
        , Text
"hreflang", Text
"http-equiv", Text
"icon", Text
"id", Text
"ismap", Text
"item", Text
"itemprop"
        , Text
"itemscope", Text
"itemtype"
        , Text
"keytype", Text
"label", Text
"lang", Text
"list", Text
"loop", Text
"low", Text
"manifest", Text
"max"
        , Text
"maxlength", Text
"media", Text
"method", Text
"min", Text
"multiple", Text
"name"
        , Text
"novalidate", Text
"onbeforeonload", Text
"onbeforeprint", Text
"onblur", Text
"oncanplay"
        , Text
"oncanplaythrough", Text
"onchange", Text
"oncontextmenu", Text
"onclick"
        , Text
"ondblclick", Text
"ondrag", Text
"ondragend", Text
"ondragenter", Text
"ondragleave"
        , Text
"ondragover", Text
"ondragstart", Text
"ondrop", Text
"ondurationchange", Text
"onemptied"
        , Text
"onended", Text
"onerror", Text
"onfocus", Text
"onformchange", Text
"onforminput"
        , Text
"onhaschange", Text
"oninput", Text
"oninvalid", Text
"onkeydown", Text
"onkeyup"
        , Text
"onload", Text
"onloadeddata", Text
"onloadedmetadata", Text
"onloadstart"
        , Text
"onmessage", Text
"onmousedown", Text
"onmousemove", Text
"onmouseout", Text
"onmouseover"
        , Text
"onmouseup", Text
"onmousewheel", Text
"ononline", Text
"onpagehide", Text
"onpageshow"
        , Text
"onpause", Text
"onplay", Text
"onplaying", Text
"onprogress", Text
"onpropstate"
        , Text
"onratechange", Text
"onreadystatechange", Text
"onredo", Text
"onresize", Text
"onscroll"
        , Text
"onseeked", Text
"onseeking", Text
"onselect", Text
"onstalled", Text
"onstorage"
        , Text
"onsubmit", Text
"onsuspend", Text
"ontimeupdate", Text
"onundo", Text
"onunload"
        , Text
"onvolumechange", Text
"onwaiting", Text
"open", Text
"optimum", Text
"pattern", Text
"ping"
        , Text
"placeholder", Text
"preload", Text
"pubdate", Text
"radiogroup", Text
"readonly", Text
"rel"
        , Text
"required", Text
"reversed", Text
"rows", Text
"rowspan", Text
"sandbox", Text
"scope"
        , Text
"scoped", Text
"seamless", Text
"selected", Text
"shape", Text
"size", Text
"sizes", Text
"span"
        , Text
"spellcheck", Text
"src", Text
"srcdoc", Text
"srcset", Text
"start", Text
"step", Text
"style", Text
"subject"
        , Text
"summary", Text
"tabindex", Text
"target", Text
"title", Text
"type", Text
"usemap", Text
"value"
        , Text
"width", Text
"wrap", Text
"xmlns"
        , Text
"ontouchstart", Text
"download"
        , Text
"allowtransparency", Text
"minlength", Text
"maxlength", Text
"property"
        , Text
"role"
        , Text
"d", Text
"viewBox", Text
"cx", Text
"cy", Text
"r", Text
"x", Text
"y", Text
"text-anchor", Text
"alignment-baseline"
        , Text
"line-spacing", Text
"letter-spacing"
        , Text
"integrity", Text
"crossorigin", Text
"poster"
        , Text
"accent-height", Text
"accumulate", Text
"additive", Text
"alphabetic", Text
"amplitude"
        , Text
"arabic-form", Text
"ascent", Text
"attributeName", Text
"attributeType", Text
"azimuth"
        , Text
"baseFrequency", Text
"baseProfile", Text
"bbox", Text
"begin", Text
"bias", Text
"by", Text
"calcMode"
        , Text
"cap-height", Text
"class", Text
"clipPathUnits", Text
"contentScriptType"
        , Text
"contentStyleType", Text
"cx", Text
"cy", Text
"d", Text
"descent", Text
"diffuseConstant", Text
"divisor"
        , Text
"dur", Text
"dx", Text
"dy", Text
"edgeMode", Text
"elevation", Text
"end", Text
"exponent"
        , Text
"externalResourcesRequired", Text
"filterRes", Text
"filterUnits", Text
"font-family"
        , Text
"font-size", Text
"font-stretch", Text
"font-style", Text
"font-variant", Text
"font-weight"
        , Text
"format", Text
"from", Text
"fx", Text
"fy", Text
"g1", Text
"g2", Text
"glyph-name", Text
"glyphRef"
        , Text
"gradientTransform", Text
"gradientUnits", Text
"hanging", Text
"height", Text
"horiz-adv-x"
        , Text
"horiz-origin-x", Text
"horiz-origin-y", Text
"id", Text
"ideographic", Text
"in", Text
"in2"
        , Text
"intercept", Text
"k", Text
"k1", Text
"k2", Text
"k3", Text
"k4", Text
"kernelMatrix", Text
"kernelUnitLength"
        , Text
"keyPoints", Text
"keySplines", Text
"keyTimes", Text
"lang", Text
"lengthAdjust"
        , Text
"limitingConeAngle", Text
"local", Text
"markerHeight", Text
"markerUnits", Text
"markerWidth"
        , Text
"maskContentUnits", Text
"maskUnits", Text
"mathematical", Text
"max", Text
"media", Text
"method"
        , Text
"min", Text
"mode", Text
"name", Text
"numOctaves", Text
"offset", Text
"onabort", Text
"onactivate"
        , Text
"onbegin", Text
"onclick", Text
"onend", Text
"onerror", Text
"onfocusin", Text
"onfocusout", Text
"onload"
        , Text
"onmousedown", Text
"onmousemove", Text
"onmouseout", Text
"onmouseover", Text
"onmouseup"
        , Text
"onrepeat", Text
"onresize", Text
"onscroll", Text
"onunload", Text
"onzoom", Text
"operator", Text
"order"
        , Text
"orient", Text
"orientation", Text
"origin", Text
"overline-position", Text
"overline-thickness"
        , Text
"panose-1", Text
"path", Text
"pathLength", Text
"patternContentUnits", Text
"patternTransform"
        , Text
"patternUnits", Text
"points", Text
"pointsAtX", Text
"pointsAtY", Text
"pointsAtZ"
        , Text
"preserveAlpha", Text
"preserveAspectRatio", Text
"primitiveUnits", Text
"r", Text
"radius"
        , Text
"refX", Text
"refY", Text
"rendering-intent", Text
"repeatCount", Text
"repeatDur"
        , Text
"requiredExtensions", Text
"requiredFeatures", Text
"restart", Text
"result", Text
"rotate", Text
"rx"
        , Text
"ry", Text
"scale", Text
"seed", Text
"slope", Text
"spacing", Text
"specularConstant"
        , Text
"specularExponent", Text
"spreadMethod", Text
"startOffset", Text
"stdDeviation", Text
"stemh"
        , Text
"stemv", Text
"stitchTiles", Text
"strikethrough-position", Text
"strikethrough-thickness"
        , Text
"string", Text
"style", Text
"surfaceScale", Text
"systemLanguage", Text
"tableValues", Text
"target"
        , Text
"targetX", Text
"targetY", Text
"textLength", Text
"title", Text
"to", Text
"transform", Text
"type", Text
"u1"
        , Text
"u2", Text
"underline-position", Text
"underline-thickness", Text
"unicode", Text
"unicode-range"
        , Text
"units-per-em", Text
"v-alphabetic", Text
"v-hanging", Text
"v-ideographic", Text
"v-mathematical"
        , Text
"values", Text
"version", Text
"vert-adv-y", Text
"vert-origin-x", Text
"vert-origin-y", Text
"viewBox"
        , Text
"viewTarget", Text
"width", Text
"widths", Text
"x", Text
"x-height", Text
"x1", Text
"x2"
        , Text
"xChannelSelector", Text
"xlink:actuate", Text
"xlink:arcrole", Text
"xlink:href"
        , Text
"xlink:role", Text
"xlink:show", Text
"xlink:title", Text
"xlink:type", Text
"xml:base"
        , Text
"xml:lang", Text
"xml:space", Text
"y", Text
"y1", Text
"y2", Text
"yChannelSelector", Text
"z", Text
"zoomAndPan"
        , Text
"alignment-baseline", Text
"baseline-shift", Text
"clip-path", Text
"clip-rule"
        , Text
"clip", Text
"color-interpolation-filters", Text
"color-interpolation"
        , Text
"color-profile", Text
"color-rendering", Text
"color", Text
"cursor", Text
"direction"
        , Text
"display", Text
"dominant-baseline", Text
"enable-background", Text
"fill-opacity"
        , Text
"fill-rule", Text
"fill", Text
"filter", Text
"flood-color", Text
"flood-opacity"
        , Text
"font-size-adjust", Text
"glyph-orientation-horizontal"
        , Text
"glyph-orientation-vertical", Text
"image-rendering", Text
"kerning", Text
"letter-spacing"
        , Text
"lighting-color", Text
"marker-end", Text
"marker-mid", Text
"marker-start", Text
"mask"
        , Text
"opacity", Text
"overflow", Text
"pointer-events", Text
"shape-rendering", Text
"stop-color"
        , Text
"stop-opacity", Text
"stroke-dasharray", Text
"stroke-dashoffset", Text
"stroke-linecap"
        , Text
"stroke-linejoin", Text
"stroke-miterlimit", Text
"stroke-opacity", Text
"stroke-width"
        , Text
"stroke", Text
"text-anchor", Text
"text-decoration", Text
"text-rendering", Text
"unicode-bidi"
        , Text
"visibility", Text
"word-spacing", Text
"writing-mode", Text
"is"
        , Text
"cellspacing", Text
"cellpadding", Text
"bgcolor", Text
"classes"
        , Text
"loading"
        , Text
"frameborder", Text
"allow", Text
"allowfullscreen", Text
"nonce", Text
"referrerpolicy"
        ]

parents :: Set Text
parents :: Set Text
parents = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
          [ Text
"a"
          , Text
"abbr"
          , Text
"address"
          , Text
"animate"
          , Text
"animateMotion"
          , Text
"animateTransform"
          , Text
"article"
          , Text
"aside"
          , Text
"audio"
          , Text
"b"
          , Text
"bdi"
          , Text
"bdo"
          , Text
"blink"
          , Text
"blockquote"
          , Text
"body"
          , Text
"button"
          , Text
"canvas"
          , Text
"caption"
          , Text
"circle"
          , Text
"cite"
          , Text
"clipPath"
          , Text
"code"
          , Text
"colgroup"
          , Text
"command"
          , Text
"data"
          , Text
"datalist"
          , Text
"dd"
          , Text
"defs"
          , Text
"del"
          , Text
"desc"
          , Text
"details"
          , Text
"dfn"
          , Text
"dialog"
          , Text
"discard"
          , Text
"div"
          , Text
"dl"
          , Text
"dt"
          , Text
"ellipse"
          , Text
"em"
          , Text
"feBlend"
          , Text
"feColorMatrix"
          , Text
"feComponentTransfer"
          , Text
"feComposite"
          , Text
"feConvolveMatrix"
          , Text
"feDiffuseLighting"
          , Text
"feDisplacementMap"
          , Text
"feDistantLight"
          , Text
"feDropShadow"
          , Text
"feFlood"
          , Text
"feFuncA"
          , Text
"feFuncB"
          , Text
"feFuncG"
          , Text
"feFuncR"
          , Text
"feGaussianBlur"
          , Text
"feImage"
          , Text
"feMerge"
          , Text
"feMergeNode"
          , Text
"feMorphology"
          , Text
"feOffset"
          , Text
"fePointLight"
          , Text
"feSpecularLighting"
          , Text
"feSpotLight"
          , Text
"feTile"
          , Text
"feTurbulence"
          , Text
"fieldset"
          , Text
"figcaption"
          , Text
"figure"
          , Text
"filter"
          , Text
"footer"
          , Text
"foreignObject"
          , Text
"form"
          , Text
"g"
          , Text
"h1"
          , Text
"h2"
          , Text
"h3"
          , Text
"h4"
          , Text
"h5"
          , Text
"h6"
          , Text
"hatch"
          , Text
"hatchpath"
          , Text
"head"
          , Text
"header"
          , Text
"hgroup"
          , Text
"html"
          , Text
"i"
          , Text
"iframe"
          , Text
"ins"
          , Text
"ion-icon"
          , Text
"kbd"
          , Text
"label"
          , Text
"legend"
          , Text
"li"
          , Text
"line"
          , Text
"linearGradient"
          , Text
"loading"
          , Text
"main"
          , Text
"map"
          , Text
"mark"
          , Text
"marker"
          , Text
"marquee"
          , Text
"mask"
          , Text
"menu"
          , Text
"mesh"
          , Text
"meshgradient"
          , Text
"meshpatch"
          , Text
"meshrow"
          , Text
"metadata"
          , Text
"meter"
          , Text
"mpath"
          , Text
"nav"
          , Text
"noscript"
          , Text
"object"
          , Text
"ol"
          , Text
"optgroup"
          , Text
"option"
          , Text
"output"
          , Text
"p"
          , Text
"path"
          , Text
"pattern"
          , Text
"picture"
          , Text
"polygon"
          , Text
"polyline"
          , Text
"pre"
          , Text
"progress"
          , Text
"q"
          , Text
"radialGradient"
          , Text
"rect"
          , Text
"rp"
          , Text
"rt"
          , Text
"ruby"
          , Text
"s"
          , Text
"samp"
          , Text
"script"
          , Text
"section"
          , Text
"select"
          , Text
"set"
          , Text
"slot"
          , Text
"small"
          , Text
"source"
          , Text
"span"
          , Text
"stop"
          , Text
"strong"
          , Text
"style"
          , Text
"sub"
          , Text
"summary"
          , Text
"sup"
          , Text
"svg"
          , Text
"switch"
          , Text
"symbol"
          , Text
"table"
          , Text
"tbody"
          , Text
"td"
          , Text
"template"
          , Text
"text"
          , Text
"textPath"
          , Text
"textarea"
          , Text
"tfoot"
          , Text
"th"
          , Text
"thead"
          , Text
"time"
          , Text
"title"
          , Text
"tr"
          , Text
"track"
          , Text
"tspan"
          , Text
"u"
          , Text
"ul"
          , Text
"unknown"
          , Text
"use"
          , Text
"var"
          , Text
"video"
          , Text
"view"
          , Text
"wbr"
          ]

leafs :: Set Text
leafs :: Set Text
leafs = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Text
"area"
        , Text
"base"
        , Text
"br"
        , Text
"col"
        , Text
"embed"
        , Text
"hr"
        , Text
"img"
        , Text
"input"
        , Text
"link"
        , Text
"meta"
        , Text
"param"
        ]

stripTextNodeWhitespaces :: [Node] -> [Node]
stripTextNodeWhitespaces [Node]
nodes = [Node] -> [Node]
stripLastTextNodeWhitespaces ([Node] -> [Node]
stripFirstTextNodeWhitespaces [Node]
nodes)

stripLastTextNodeWhitespaces :: [Node] -> [Node]
stripLastTextNodeWhitespaces [Node]
nodes =
    let strippedLastElement :: Maybe Node
strippedLastElement = if [Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Node]
nodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            then case [Node] -> Node
forall a. [a] -> a
List.last [Node]
nodes of
                TextNode Text
text -> Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Text -> Node
TextNode (Text -> Text
Text.stripEnd Text
text)
                Node
otherwise -> Maybe Node
forall a. Maybe a
Nothing
            else Maybe Node
forall a. Maybe a
Nothing
    in case Maybe Node
strippedLastElement of
        Just Node
last -> (([Node], [Node]) -> [Node]
forall a b. (a, b) -> a
fst (([Node], [Node]) -> [Node]) -> ([Node], [Node]) -> [Node]
forall a b. (a -> b) -> a -> b
$ Int -> [Node] -> ([Node], [Node])
forall a. Int -> [a] -> ([a], [a])
List.splitAt (([Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Node]
nodes) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Node]
nodes) [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
last]
        Maybe Node
Nothing -> [Node]
nodes

stripFirstTextNodeWhitespaces :: [Node] -> [Node]
stripFirstTextNodeWhitespaces [Node]
nodes =
    let strippedFirstElement :: Maybe Node
strippedFirstElement = if [Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Node]
nodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            then case [Node] -> Node
forall a. [a] -> a
List.head [Node]
nodes of
                TextNode Text
text -> Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Text -> Node
TextNode (Text -> Text
Text.stripStart Text
text)
                Node
otherwise -> Maybe Node
forall a. Maybe a
Nothing
            else Maybe Node
forall a. Maybe a
Nothing
    in case Maybe Node
strippedFirstElement of
        Just Node
first -> Node
firstNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:([Node] -> [Node]
forall a. [a] -> [a]
List.tail [Node]
nodes)
        Maybe Node
Nothing -> [Node]
nodes

-- | Replaces multiple space characters with a single one
collapseSpace :: Text -> Text
collapseSpace :: Text -> Text
collapseSpace Text
text = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
filterDuplicateSpaces (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
text)
    where
        filterDuplicateSpaces :: String -> String
        filterDuplicateSpaces :: ShowS
filterDuplicateSpaces String
string = String -> Bool -> String
filterDuplicateSpaces' String
string Bool
False

        filterDuplicateSpaces' :: String -> Bool -> String
        filterDuplicateSpaces' :: String -> Bool -> String
filterDuplicateSpaces' (Char
char:String
rest) Bool
True | Char -> Bool
Char.isSpace Char
char = String -> Bool -> String
filterDuplicateSpaces' String
rest Bool
True
        filterDuplicateSpaces' (Char
char:String
rest) Bool
False | Char -> Bool
Char.isSpace Char
char = Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:(String -> Bool -> String
filterDuplicateSpaces' String
rest Bool
True)
        filterDuplicateSpaces' (Char
char:String
rest) Bool
isRemovingSpaces = Char
charChar -> ShowS
forall a. a -> [a] -> [a]
:(String -> Bool -> String
filterDuplicateSpaces' String
rest Bool
False)
        filterDuplicateSpaces' [] Bool
isRemovingSpaces = []


patchExpr :: TH.Exp -> TH.Exp
patchExpr :: Exp -> Exp
patchExpr (TH.UInfixE (TH.VarE Name
varName) (TH.VarE Name
hash) (TH.VarE Name
labelValue)) | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#" = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
varName) Exp
fromLabel
    where
            fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
--- UInfixE (UInfixE a (VarE |>) (VarE get)) (VarE #) (VarE firstName)
patchExpr input :: Exp
input@(TH.UInfixE (TH.UInfixE Exp
a (TH.VarE Name
arrow) (TH.VarE Name
get)) (TH.VarE Name
hash) (TH.VarE Name
labelValue)) | (Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#") Bool -> Bool -> Bool
&& (Name
arrow Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"|>") Bool -> Bool -> Bool
&& (Name
get Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"get") =
        (Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp
patchExpr Exp
a) (Name -> Exp
TH.VarE Name
arrow) (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
get) Exp
fromLabel))
    where
            fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
-- UInfixE (UInfixE a (VarE $) (VarE get)) (VarE #) (AppE (VarE id) (VarE checklist))
patchExpr (TH.UInfixE (TH.UInfixE Exp
a Exp
b Exp
get) (TH.VarE Name
hash) (TH.AppE (TH.VarE Name
labelValue) (TH.VarE Name
d))) | (Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#") =
        Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b) (Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE Exp
get Exp
fromLabel) (Name -> Exp
TH.VarE Name
d))
    where
            fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr (TH.UInfixE (TH.VarE Name
varName) (TH.VarE Name
hash) (TH.AppE (TH.VarE Name
labelValue) Exp
arg)) | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#" = Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
varName) Exp
fromLabel) Exp
arg
    where
            fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr (TH.UInfixE (TH.VarE Name
a) (TH.VarE Name
hash) (TH.AppE (TH.VarE Name
labelValue) (TH.VarE Name
b))) | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#" =
        Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
a) Exp
fromLabel) (Name -> Exp
TH.VarE Name
b)
    where
            fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))

patchExpr (TH.UInfixE Exp
a Exp
b Exp
c) = Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b) (Exp -> Exp
patchExpr Exp
c)
patchExpr (TH.ParensE Exp
e) = Exp -> Exp
TH.ParensE (Exp -> Exp
patchExpr Exp
e)
patchExpr (TH.RecUpdE Exp
a [FieldExp]
b) = Exp -> [FieldExp] -> Exp
TH.RecUpdE (Exp -> Exp
patchExpr Exp
a) [FieldExp]
b
patchExpr (TH.AppE Exp
a Exp
b) = Exp -> Exp -> Exp
TH.AppE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b)
patchExpr (TH.LamE [Pat]
a Exp
b) = [Pat] -> Exp -> Exp
TH.LamE [Pat]
a (Exp -> Exp
patchExpr Exp
b)
patchExpr (TH.LetE [Dec]
a Exp
b) = [Dec] -> Exp -> Exp
TH.LetE [Dec]
a' (Exp -> Exp
patchExpr Exp
b)
    where
        a' :: [Dec]
a' = (Dec -> Dec) -> [Dec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
List.map Dec -> Dec
patchDec [Dec]
a
        patchDec :: Dec -> Dec
patchDec (TH.ValD Pat
a (TH.NormalB Exp
b) [Dec]
c) = (Pat -> Body -> [Dec] -> Dec
TH.ValD Pat
a (Exp -> Body
TH.NormalB (Exp -> Exp
patchExpr Exp
b)) [Dec]
c)
        patchDec Dec
a = Dec
a
patchExpr (TH.CondE Exp
a Exp
b Exp
c) = Exp -> Exp -> Exp -> Exp
TH.CondE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b) (Exp -> Exp
patchExpr Exp
c)
patchExpr (TH.SigE Exp
a Type
b) = Exp -> Type -> Exp
TH.SigE (Exp -> Exp
patchExpr Exp
a) Type
b
patchExpr Exp
e = Exp
e