Allow custom web component tags in HSX. Fixes #607

digitallyinduced · Dec 27, 2020 · e8056fd · e8056fd
1 parent e7c2768
commit e8056fd
Show file tree

Hide file tree

Showing 3 changed files with 22 additions and 15 deletions.
diff --git 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
@@ -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 | <my-invalid-el>\n  |               ^\nInvalid tag name: my-invalid-el\n"
-            let (Left error) = parseHsx position "<my-invalid-el>"
+            let errorText = "1:13:\n  |\n1 | <myinvalidel>\n  |             ^\nInvalid tag name: myinvalidel\n"
+            let (Left error) = parseHsx position "<myinvalidel>"
             (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
@@ -67,6 +67,11 @@ tests = do
             let variableContent :: Text = "<script>alert(1);</script>"
             [hsx|{variableContent}|] `shouldBeHtml` "&lt;script&gt;alert(1);&lt;/script&gt;"
 
+        it "should parse custom web component tags" do
+            [hsx|<confetti-effect></confetti-effect>|] `shouldBeHtml` "<confetti-effect></confetti-effect>"
+            [hsx|<confetti-effect/>|] `shouldBeHtml` "<confetti-effect></confetti-effect>" -- Currently we cannot deal with self closing tags as expected
+            [hsx|<div is="confetti-effect"></div>|] `shouldBeHtml` "<div is=\"confetti-effect\"></div>"
+
 data Project = Project { name :: Text }
 
 shouldBeHtml hsx expectedHtml = (Blaze.renderMarkup hsx) `shouldBe` expectedHtml