uncheckedHsx + customHsx (#2010)

* add new module * Fix uncheckedHSX quasiquoter * Make sure closing tags are checked * Fix it so it works * remove UncheckedHSX and attept to restore QQ and Parser modules * reset some unecessary whitespace stuff * remove unecessary whitespace * unchecked HSX working, with tests on the parser * Add customHsx + tests * fix comment * fix comment * Update ihp-hsx/IHP/HSX/Parser.hs Co-authored-by: Marc Scholten <[email protected]> * Update ihp-hsx/IHP/HSX/QQ.hs Co-authored-by: Marc Scholten <[email protected]> * remove newtypes and use 'HsxSettings' directly * Fix Github resolve bug * Aesthethic nitpick * use customHsx to call hsx and uncheckedHsx * Move CustomHsxCases to Test.HSX namespace * Fix import * Fix module comment * For now, move CustomHsxCases back so the tests are working again * Add documentation * Minor doc fix * Formulate solution to QuasiQuoter shortcomings * typo fix * Add use-case example * Simplify langauge * Improve examples a bit * Add spread example --------- Co-authored-by: Marc Scholten <[email protected]>
digitallyinduced · Nov 2, 2024 · 61bc6a7 · 61bc6a7
1 parent b68c4dd
commit 61bc6a7
Show file tree

Hide file tree

Showing 8 changed files with 409 additions and 35 deletions.
diff --git a/Guide/hsx.markdown b/Guide/hsx.markdown
@@ -278,6 +278,102 @@ The underlying HTML library blaze currently does not support an empty HTML attri
 
 If you use HTML entities, such as `&nbsp;` for a non-breaking space, you will notice they appear exactly like that. To output directly (i.e. unescaped) use the method `preEscapedToMarkup` from `Text.Blaze.Html5`.
 
+### Custom HSX and Unchecked HSX
+
+HSX provides two additional QuasiQuoters beyond the standard `[hsx|...|]` for increased flexibility: `uncheckedHsx` and `customHsx`.
+
+#### Using `uncheckedHsx`
+
+`uncheckedHsx` provides a quick way to bypass HSX's strict tag and attribute name checking. 
+
+It will still check for a valid HTML structure, but it will accept any tag and attribute names.
+
+
+```haskell
+[uncheckedHsx|
+    <anytagname custom-attribute="value">
+        Content
+    </anytagname>
+|]
+```
+
+While convenient for rapid development, use it with caution as you lose the benefits of compile-time guarantees for your markup.
+
+#### Using `customHsx`
+
+`customHsx` allows you to extend the default HSX with additional whitelisted tag names and attribute names while maintaining the same strict compile-time checking of the default `hsx`. 
+
+This makes it easier to use custom elements that often also contain special attributes, and javascript libraries, for example `_hyperscript`, that use the `_` as an attribute name.
+
+
+To use `customHsx`, you need to create it in a separate module due to Template Haskell restrictions. Here's how to set it up:
+
+1. First, create a new module for your custom HSX (e.g., `Application.Helper.CustomHsx`):
+
+```haskell
+module Application.Helper.CustomHsx where
+
+import IHP.Prelude
+import IHP.HSX.QQ (customHsx)
+import IHP.HSX.Parser
+import Language.Haskell.TH.Quote
+import qualified Data.Set as Set
+
+myHsx :: QuasiQuoter
+myHsx = customHsx 
+    (HsxSettings 
+        { checkMarkup = True
+        , additionalTagNames = Set.fromList ["book", "heading", "name"]
+        , additionalAttributeNames = Set.fromList ["_", "custom-attribute"]
+        }
+    )
+```
+
+Configuration options for `HsxSettings`:
+- `checkMarkup`: Boolean to enable/disable markup checking
+- `additionalTagNames`: Set of additional allowed tag names
+- `additionalAttributeNames`: Set of additional allowed attribute names
+
+2. Make it available in your views by adding it to your view helpers module:
+
+```haskell
+module Application.Helper.View (
+    module Application.Helper.View,
+    module Application.Helper.CustomHsx -- Add this line
+) where
+
+import IHP.ViewPrelude
+import Application.Helper.CustomHsx (myHsx) -- Add this line
+```
+
+3. Use it in your views:
+
+```haskell
+[myHsx|
+    <book _="on click log 'Hello'">
+        <heading custom-attribute="value">My Book</heading>
+        <name>Author Name</name>
+    </book>
+|]
+```
+
+The custom HSX will validate that tags and attributes are either in the default HSX whitelist or in your additional sets. This gives you the flexibility to use custom elements and attributes.
+
+This approach is particularly useful for:
+- Web Components with custom attribute names
+- UI libraries with non-standard attributes
+- Domain-specific XML markup languages like [Hyperview](https://hyperview.org/docs/example_navigation)
+- Integration with third-party frameworks that extend HTML syntax
+
+`customHsx` whitelisting and even `uncheckedHsx` does not entirely help for libraries with very unusual symbols in their attributes, like Alpine.js, because they don't recognize html attributes starting with `@` or has `:` in the attribute name. In these cases, the spread syntax `{...attributeList}` is likely your best bet.
+
+```haskell
+-- This will not work
+[uncheckedHsx|<button @click="open = true">Expand</button>|]
+
+-- Using spread syntax will work
+[hsx|<button {...[("@click", "open = true" :: Text)]}>Expand</button>|]
+```
 
 ## Common HSX Patterns
 

diff --git a/ihp-hsx/IHP/HSX/Parser.hs b/ihp-hsx/IHP/HSX/Parser.hs
@@ -15,6 +15,7 @@ module IHP.HSX.Parser
 , Attribute (..)
 , AttributeValue (..)
 , collapseSpace
+, HsxSettings (..)
 ) where
 
 import Prelude
@@ -34,6 +35,12 @@ import qualified Data.Set as Set
 import qualified Data.Containers.ListUtils as List
 import qualified IHP.HSX.HaskellParser as HaskellParser
 
+data HsxSettings = HsxSettings
+    { checkMarkup :: Bool
+    , additionalTagNames :: Set Text
+    , additionalAttributeNames :: Set Text
+    }
+
 data AttributeValue = TextValue !Text | ExpressionValue !Haskell.Exp deriving (Eq, Show)
 
 data Attribute = StaticAttribute !Text !AttributeValue | SpreadAttributes !Haskell.Exp deriving (Eq, Show)
@@ -57,15 +64,16 @@ data Node = Node !Text ![Attribute] ![Node] !Bool
 -- > let position = Megaparsec.SourcePos filePath (Megaparsec.mkPos line) (Megaparsec.mkPos col)
 -- > let hsxText = "<strong>Hello</strong>"
 -- >
--- > let (Right node) = parseHsx position [] hsxText
-parseHsx :: SourcePos -> [TH.Extension] -> Text -> Either (ParseErrorBundle Text Void) Node
-parseHsx position extensions code =
+-- > let (Right node) = parseHsx settings position [] hsxText
+parseHsx :: HsxSettings -> SourcePos -> [TH.Extension] -> Text -> Either (ParseErrorBundle Text Void) Node
+parseHsx settings position extensions code =
     let
         ?extensions = extensions
+        ?settings = settings
     in
         runParser (setPosition position *> parser) "" code
 
-type Parser a = (?extensions :: [TH.Extension]) => Parsec Void Text a
+type Parser a = (?extensions :: [TH.Extension], ?settings :: HsxSettings) => Parsec Void Text a
 
 setPosition pstateSourcePos = updateParserState (\state -> state {
         statePosState = (statePosState state) { pstateSourcePos }
@@ -211,15 +219,16 @@ hsxNodeAttribute = do
 hsxAttributeName :: Parser Text
 hsxAttributeName = do
         name <- rawAttribute
-        unless (isValidAttributeName name) (fail $ "Invalid attribute name: " <> cs name)
+        let checkingMarkup = ?settings.checkMarkup
+        unless (isValidAttributeName name || not checkingMarkup) (fail $ "Invalid attribute name: " <> cs name)
         pure name
     where
         isValidAttributeName name =
             "data-" `Text.isPrefixOf` name
             || "aria-" `Text.isPrefixOf` name
             || "hx-" `Text.isPrefixOf` name
-            || "hx-" `Text.isPrefixOf` name
             || name `Set.member` attributes
+            || name `Set.member` ?settings.additionalAttributeNames
 
         rawAttribute = takeWhile1P Nothing (\c -> Char.isAlphaNum c || c == '-' || c == '_')
 
@@ -285,13 +294,18 @@ hsxSplicedNode = do
         treeToString acc (TokenNode (x:xs)) = ((treeToString (acc <> "{") x) <> (Text.concat $ fmap (treeToString "") xs)) <> "}"
 
 
+
 hsxElementName :: Parser Text
 hsxElementName = do
     name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_' || c == '-' || c == '!')
     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)
+    let isValidCustomWebComponent = "-" `Text.isInfixOf` name 
+                                  && not (Text.isPrefixOf "-" name)
+                                  && not (Char.isNumber (Text.head name))
+    let isValidAdditionalTag = name `Set.member` ?settings.additionalTagNames
+    let checkingMarkup = ?settings.checkMarkup
+    unless (isValidParent || isValidLeaf || isValidCustomWebComponent || isValidAdditionalTag || not checkingMarkup) (fail $ "Invalid tag name: " <> cs name)
     space
     pure name
 

diff --git a/ihp-hsx/IHP/HSX/QQ.hs b/ihp-hsx/IHP/HSX/QQ.hs
@@ -5,7 +5,7 @@ Module: IHP.HSX.QQ
 Description: Defines the @[hsx||]@ syntax
 Copyright: (c) digitally induced GmbH, 2022
 -}
-module IHP.HSX.QQ (hsx) where
+module IHP.HSX.QQ (hsx, uncheckedHsx, customHsx) where
 
 import           Prelude
 import Data.Text (Text)
@@ -27,20 +27,40 @@ import Data.List (foldl')
 import IHP.HSX.Attribute
 import qualified Text.Blaze.Html5.Attributes as Attributes
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
 
 hsx :: QuasiQuoter
-hsx = QuasiQuoter {
-        quoteExp = quoteHsxExpression,
-        quotePat = error "quotePat: not defined",
-        quoteDec = error "quoteDec: not defined",
-        quoteType = error "quoteType: not defined"
-    }
+hsx = customHsx 
+        (HsxSettings 
+            { checkMarkup = True
+            , additionalTagNames = Set.empty
+            , additionalAttributeNames = Set.empty
+            }
+        )
 
-quoteHsxExpression :: String -> TH.ExpQ
-quoteHsxExpression code = do
+uncheckedHsx :: QuasiQuoter
+uncheckedHsx = customHsx
+        (HsxSettings 
+            { checkMarkup = False
+            , additionalTagNames = Set.empty
+            , additionalAttributeNames = Set.empty
+            }
+        )
+
+customHsx :: HsxSettings -> QuasiQuoter
+customHsx settings = 
+    QuasiQuoter 
+        { quoteExp = quoteHsxExpression settings
+        , quotePat = error "quotePat: not defined"
+        , quoteDec = error "quoteDec: not defined"
+        , quoteType = error "quoteType: not defined"
+        }
+
+quoteHsxExpression :: HsxSettings -> String -> TH.ExpQ
+quoteHsxExpression settings code = do
         hsxPosition <- findHSXPosition
         extensions <- TH.extsEnabled
-        expression <- case parseHsx hsxPosition extensions (cs code) of
+        expression <- case parseHsx settings hsxPosition extensions (cs code) of
                 Left error   -> fail (Megaparsec.errorBundlePretty error)
                 Right result -> pure result
         compileToHaskell expression
@@ -458,4 +478,4 @@ textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 te
 {-# INLINE textToStaticString #-}
 
 instance Show (MarkupM ()) where
-    show html = BlazeString.renderHtml html
+    show html = BlazeString.renderHtml html
diff --git a/ihp-hsx/README.md b/ihp-hsx/README.md
@@ -274,6 +274,102 @@ The underlying HTML library blaze currently does not support an empty HTML attri
 
 If you use HTML entities, such as `&nbsp;` for a non-breaking space, you will notice they appear exactly like that. To output directly (i.e. unescaped) use the method `preEscapedToMarkup` from `Text.Blaze.Html5`.
 
+### Custom HSX and Unchecked HSX
+
+HSX provides two additional QuasiQuoters beyond the standard `[hsx|...|]` for increased flexibility: `uncheckedHsx` and `customHsx`.
+
+#### Using `uncheckedHsx`
+
+`uncheckedHsx` provides a quick way to bypass HSX's strict tag and attribute name checking. 
+
+It will still check for a valid HTML structure, but it will accept any tag and attribute names.
+
+
+```haskell
+[uncheckedHsx|
+    <anytagname custom-attribute="value">
+        Content
+    </anytagname>
+|]
+```
+
+While convenient for rapid development, use it with caution as you lose the benefits of compile-time guarantees for your markup.
+
+#### Using `customHsx`
+
+`customHsx` allows you to extend the default HSX with additional whitelisted tag names and attribute names while maintaining the same strict compile-time checking of the default `hsx`. 
+
+This makes it easier to use custom elements that often also contain special attributes, and javascript libraries, for example `_hyperscript`, that use the `_` as an attribute name.
+
+
+To use `customHsx`, you need to create it in a separate module due to Template Haskell restrictions. Here's how to set it up:
+
+1. First, create a new module for your custom HSX (e.g., `Application.Helper.CustomHsx`):
+
+```haskell
+module Application.Helper.CustomHsx where
+
+import IHP.Prelude
+import IHP.HSX.QQ (customHsx)
+import IHP.HSX.Parser
+import Language.Haskell.TH.Quote
+import qualified Data.Set as Set
+
+myHsx :: QuasiQuoter
+myHsx = customHsx 
+    (HsxSettings 
+        { checkMarkup = True
+        , additionalTagNames = Set.fromList ["book", "heading", "name"]
+        , additionalAttributeNames = Set.fromList ["_", "custom-attribute"]
+        }
+    )
+```
+
+Configuration options for `HsxSettings`:
+- `checkMarkup`: Boolean to enable/disable markup checking
+- `additionalTagNames`: Set of additional allowed tag names
+- `additionalAttributeNames`: Set of additional allowed attribute names
+
+2. Make it available in your views by adding it to your view helpers module:
+
+```haskell
+module Application.Helper.View (
+    module Application.Helper.View,
+    module Application.Helper.CustomHsx -- Add this line
+) where
+
+import IHP.ViewPrelude
+import Application.Helper.CustomHsx (myHsx) -- Add this line
+```
+
+3. Use it in your views:
+
+```haskell
+[myHsx|
+    <book _="on click log 'Hello'">
+        <heading custom-attribute="value">My Book</heading>
+        <name>Author Name</name>
+    </book>
+|]
+```
+
+The custom HSX will validate that tags and attributes are either in the default HSX whitelist or in your additional sets. This gives you the flexibility to use custom elements and attributes.
+
+This approach is particularly useful for:
+- Web Components with custom attribute names
+- UI libraries with non-standard attributes
+- Domain-specific XML markup languages
+- Integration with third-party frameworks that extend HTML syntax
+
+`customHsx` whitelisting and even `uncheckedHsx` does not entirely help for libraries with very unusual symbols in their attributes, like Alpine.js, because they don't recognize html attributes starting with `@` or has `:` in the attribute name. In these cases, the spread syntax `{...attributeList}` is likely your best bet.
+
+```haskell
+-- This will not work
+[uncheckedHsx|<button @click="open = true">Expand</button>|]
+
+-- Using spread syntax will work
+[hsx|<button {...[("@click", "open = true" :: Text)]}>Expand</button>|]
+```
 
 ## Common HSX Patterns
 

diff --git a/ihp-hsx/Test/IHP/HSX/CustomHsxCases.hs b/ihp-hsx/Test/IHP/HSX/CustomHsxCases.hs
@@ -0,0 +1,38 @@
+{-|
+Module: Test.HSX.CustomHsxCases
+Description: Test helpers for HSX tests with custom tags and attributes
+-}
+module IHP.HSX.CustomHsxCases where
+
+import Test.Hspec
+import Prelude
+import IHP.HSX.QQ
+import qualified Text.Blaze.Renderer.Text as Blaze
+import Data.Text
+import Language.Haskell.TH.Quote
+import IHP.HSX.Parser
+import qualified Data.Set as Set
+
+myCustomHsx :: QuasiQuoter
+myCustomHsx = customHsx 
+    (HsxSettings { checkMarkup = True
+                 , additionalTagNames = Set.fromList ["mycustomtag", "anothercustomtag"]
+                 , additionalAttributeNames = Set.fromList ["my-custom-attr", "anothercustomattr"] 
+                 }
+    )
+
+myTagsOnlyHsx :: QuasiQuoter
+myTagsOnlyHsx = customHsx
+    (HsxSettings { checkMarkup = True
+                 , additionalTagNames = Set.fromList ["mycustomtag", "anothercustomtag"]
+                 , additionalAttributeNames = Set.fromList []
+                 }
+    )
+
+myAttrsOnlyHsx :: QuasiQuoter
+myAttrsOnlyHsx = customHsx
+    (HsxSettings { checkMarkup = True
+                 , additionalTagNames = Set.fromList []
+                 , additionalAttributeNames = Set.fromList ["my-custom-attr", "anothercustomattr"]
+                 }
+    )