diff --git a/IHP/HtmlSupport/Parser.hs b/IHP/HtmlSupport/Parser.hs
index d16cad667..ee497e06e 100644
--- a/IHP/HtmlSupport/Parser.hs
+++ b/IHP/HtmlSupport/Parser.hs
@@ -3,9 +3,6 @@ module IHP.HtmlSupport.Parser
, Node (..)
, Attribute (..)
, AttributeValue (..)
-, attributes
-, parents
-, leafs
) where
import CorePrelude
@@ -23,6 +20,8 @@ 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 "template-haskell" Language.Haskell.TH.Syntax as TH
+import qualified Data.Set as Set
+import Data.Set (Set)
data AttributeValue = TextValue !Text | ExpressionValue !Haskell.Exp deriving (Eq, Show)
@@ -73,7 +72,7 @@ manyHsxElement = do
hsxSelfClosingElement = do
_ <- char '<'
name <- hsxElementName
- let isLeaf = name `List.elem` leafs
+ let isLeaf = name `Set.member` leafs
attributes <-
if isLeaf
then hsxNodeAttributes (string ">" <|> string "/>")
@@ -176,7 +175,7 @@ hsxAttributeName = do
|| "aria-" `Text.isPrefixOf` name
|| "hx-" `Text.isPrefixOf` name
|| "hx-" `Text.isPrefixOf` name
- || name `List.elem` attributes
+ || name `Set.member` attributes
rawAttribute = takeWhile1P Nothing (\c -> Char.isAlphaNum c || c == '-')
@@ -240,7 +239,10 @@ hsxSplicedNode = do
hsxElementName :: Parser Text
hsxElementName = do
name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_' || c == '-')
- unless (name `List.elem` parents || name `List.elem` leafs) (fail $ "Invalid tag name: " <> cs name)
+ let isValidParent = name `Set.member` parents
+ let isValidLeaf = name `Set.member` leafs
+ let isValidCustomWebComponent = "-" `Text.isInfixOf` name
+ unless (isValidParent || isValidLeaf || isValidCustomWebComponent) (fail $ "Invalid tag name: " <> cs name)
space
pure name
@@ -251,8 +253,8 @@ hsxIdentifier = do
pure name
-attributes :: [Text]
-attributes =
+attributes :: Set Text
+attributes = Set.fromList
[ "accept", "accept-charset", "accesskey", "action", "alt", "async"
, "autocomplete", "autofocus", "autoplay", "challenge", "charset"
, "checked", "cite", "class", "cols", "colspan", "content"
@@ -340,11 +342,11 @@ attributes =
, "stop-opacity", "stroke-dasharray", "stroke-dashoffset", "stroke-linecap"
, "stroke-linejoin", "stroke-miterlimit", "stroke-opacity", "stroke-width"
, "stroke", "text-anchor", "text-decoration", "text-rendering", "unicode-bidi"
- , "visibility", "word-spacing", "writing-mode"
+ , "visibility", "word-spacing", "writing-mode", "is"
]
-parents :: [Text]
-parents =
+parents :: Set Text
+parents = Set.fromList
[ "a", "abbr", "address", "article", "aside", "audio", "b"
, "bdo", "blockquote", "body", "button", "canvas", "caption", "cite"
, "code", "colgroup", "command", "datalist", "dd", "del", "details"
@@ -361,8 +363,8 @@ parents =
, "loading"
]
-leafs :: [Text]
-leafs =
+leafs :: Set Text
+leafs = Set.fromList
[ "area", "br", "col", "hr", "link", "img", "input", "meta", "param"
]
diff --git a/Test/HtmlSupport/ParserSpec.hs b/Test/HtmlSupport/ParserSpec.hs
index 002822330..68018ffdc 100644
--- a/Test/HtmlSupport/ParserSpec.hs
+++ b/Test/HtmlSupport/ParserSpec.hs
@@ -14,8 +14,8 @@ tests = do
let position = Megaparsec.SourcePos "" (Megaparsec.mkPos 0) (Megaparsec.mkPos 0)
describe "HSX Parser" do
it "should fail on invalid html tags" do
- let errorText = "1:15:\n |\n1 | \n | ^\nInvalid tag name: my-invalid-el\n"
- let (Left error) = parseHsx position ""
+ let errorText = "1:13:\n |\n1 | \n | ^\nInvalid tag name: myinvalidel\n"
+ let (Left error) = parseHsx position ""
(Megaparsec.errorBundlePretty error) `shouldBe` errorText
it "should fail on invalid attribute names" do
diff --git a/Test/HtmlSupport/QQSpec.hs b/Test/HtmlSupport/QQSpec.hs
index 85f9f902e..17b56930f 100644
--- a/Test/HtmlSupport/QQSpec.hs
+++ b/Test/HtmlSupport/QQSpec.hs
@@ -67,6 +67,11 @@ tests = do
let variableContent :: Text = ""
[hsx|{variableContent}|] `shouldBeHtml` "<script>alert(1);</script>"
+ it "should parse custom web component tags" do
+ [hsx||] `shouldBeHtml` ""
+ [hsx||] `shouldBeHtml` "" -- Currently we cannot deal with self closing tags as expected
+ [hsx||] `shouldBeHtml` ""
+
data Project = Project { name :: Text }
shouldBeHtml hsx expectedHtml = (Blaze.renderMarkup hsx) `shouldBe` expectedHtml
\ No newline at end of file