diff --git a/IHP/HSX/Attribute.hs b/IHP/HSX/Attribute.hs
deleted file mode 100644
--- a/IHP/HSX/Attribute.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-|
-Module: IHP.HSX.Attribute
-Copyright: (c) digitally induced GmbH, 2023
--}
-module IHP.HSX.Attribute
-( ApplyAttribute (..)
-) where
-
-import Prelude
-import Text.Blaze.Html5 ((!))
-import qualified Text.Blaze.Html5 as Html5
-import Text.Blaze.Internal (attribute, MarkupM (Parent, Leaf), StaticString (..))
-import Data.String.Conversions
-import IHP.HSX.ToHtml
-import qualified Data.Text as Text
-import Data.Text (Text)
-
-class ApplyAttribute value where
- applyAttribute :: Text -> Text -> value -> (Html5.Html -> Html5.Html)
-
-instance ApplyAttribute Bool where
- applyAttribute attr attr' True h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') (Html5.textValue value))
- where
- value = if "data-" `Text.isPrefixOf` attr
- then "true" -- "true" for data attributes
- else attr -- normal html boolean attriubtes, like Hello "
--- >
--- > 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], ?settings :: HsxSettings) => Parsec Void Text a
-
-setPosition pstateSourcePos = updateParserState (\state -> state {
- statePosState = (statePosState state) { pstateSourcePos }
- })
-
-parser :: Parser Node
-parser = do
- space
- node <- manyHsxElement <|> hsxElement
- space
- eof
- pure node
-
-hsxElement :: Parser Node
-hsxElement = try hsxNoRenderComment <|> try hsxComment <|> try hsxSelfClosingElement <|> hsxNormalElement
-
-manyHsxElement :: Parser Node
-manyHsxElement = do
- children <- many hsxChild
- pure (Children (stripTextNodeWhitespaces children))
-
-hsxSelfClosingElement :: Parser Node
-hsxSelfClosingElement = do
- _ <- char '<'
- name <- hsxElementName
- let isLeaf = name `Set.member` leafs
- attributes <-
- if isLeaf
- then hsxNodeAttributes (string ">" <|> string "/>")
- else hsxNodeAttributes (string "/>")
- space
- pure (Node name attributes [] isLeaf)
-
-hsxNormalElement :: Parser Node
-hsxNormalElement = do
- (name, attributes) <- hsxOpeningElement
- let parsePreEscapedTextChildren transformText = do
- let closingElement = " name <> ">"
- text <- cs <$> manyTill anySingle (string closingElement)
- pure [PreEscapedTextNode (transformText text)]
- let parseNormalHSXChildren = stripTextNodeWhitespaces <$> (space >> (manyTill (try hsxChild) (try (space >> hsxClosingElement 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 @@
- -- will just literally output the string @{myHaskellExpr}@ without evaluating the haskell expression itself.
- --
- -- Here is an example HSX code explaining the problem:
- -- [hsx||]
- -- 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.
- children <- case name of
- "script" -> parsePreEscapedTextChildren Text.strip
- "style" -> parsePreEscapedTextChildren (collapseSpace . Text.strip)
- otherwise -> parseNormalHSXChildren
- pure (Node name attributes children False)
-
-hsxOpeningElement :: Parser (Text, [Attribute])
-hsxOpeningElement = do
- char '<'
- name <- hsxElementName
- space
- attributes <- hsxNodeAttributes (char '>')
- pure (name, attributes)
-
-hsxComment :: Parser Node
-hsxComment = do
- string "")
- space
- pure (CommentNode (cs body))
-
-hsxNoRenderComment :: Parser Node
-hsxNoRenderComment = do
- string "{-"
- manyTill (satisfy (const True)) (string "-}")
- space
- pure NoRenderCommentNode
-
-
-hsxNodeAttributes :: Parser a -> Parser [Attribute]
-hsxNodeAttributes end = staticAttributes
- where
- staticAttributes = do
- attributes <- manyTill (hsxNodeAttribute <|> hsxSplicedAttributes) end
- let staticAttributes = List.filter isStaticAttribute attributes
- let keys = List.map (\(StaticAttribute name _) -> name) staticAttributes
- let uniqueKeys = List.nubOrd keys
- unless (keys == uniqueKeys) (fail $ "Duplicate attribute found in tag: " <> show (keys List.\\ uniqueKeys))
- pure attributes
-
-isStaticAttribute (StaticAttribute _ _) = True
-isStaticAttribute _ = False
-
-hsxSplicedAttributes :: Parser Attribute
-hsxSplicedAttributes = do
- (pos, name) <- between (do char '{'; optional space; string "...") (string "}") do
- pos <- getSourcePos
- code <- takeWhile1P Nothing (\c -> c /= '}')
- pure (pos, code)
- space
- haskellExpression <- parseHaskellExpression pos (cs name)
- pure (SpreadAttributes haskellExpression)
-
-parseHaskellExpression :: SourcePos -> Text -> Parser Haskell.Exp
-parseHaskellExpression sourcePos input = do
- case HaskellParser.parseHaskellExpression sourcePos ?extensions (cs input) of
- Right expression -> pure expression
- Left (line, col, error) -> do
- pos <- getSourcePos
- setPosition pos { sourceLine = mkPos line, sourceColumn = mkPos col }
- fail (show error)
-
-hsxNodeAttribute :: Parser Attribute
-hsxNodeAttribute = do
- key <- hsxAttributeName
- space
-
- -- Boolean attributes like hello world |] `shouldBeHtml` "hello world "
- [hsx|hello world |] `shouldBeHtml` "hello world "
- [hsx|web scale |] `shouldBeHtml` "web scale "
+ [hsx|hello world |] `shouldBeSameHtml` "hello world "
+ [hsx|hello world |] `shouldBeSameHtml` "hello world "
+ [hsx|web scale |] `shouldBeSameHtml` "web scale "
it "should work with an empty input" do
- [hsx||] `shouldBeHtml` ""
+ [hsx||] `shouldBeSameHtml` ""
it "should support multiple root nodes" do
- [hsx|underlined italic |] `shouldBeHtml` "underlined italic "
+ [hsx|underlined italic |] `shouldBeSameHtml` "underlined italic "
it "should work with text variables" do
let myString :: Text = "World!"
- [hsx|Hello {myString}|] `shouldBeHtml` "Hello World!"
+ [hsx|Hello {myString}|] `shouldBeSameHtml` "Hello World!"
it "should work with complex haskell expressions" do
let project = Project { name = "Testproject" }
- [hsx|Project: {project.name} |] `shouldBeHtml` "Project: Testproject "
+ [hsx|Project: {project.name} |] `shouldBeSameHtml` "Project: Testproject "
it "should support lambdas and pattern matching on constructors" do
let placeData = PlaceId "Punches Cross"
- [hsx|{(\(PlaceId x) -> x)(placeData)} |] `shouldBeHtml` "Punches Cross "
+ [hsx|{(\(PlaceId x) -> x)(placeData)} |] `shouldBeSameHtml` "Punches Cross "
it "should support infix notation for standard constructors e.g. (:):" do
- [hsx| {show $ (:) 1 [2,3,42]} |] `shouldBeHtml` "[1,2,3,42] "
+ [hsx| {show $ (:) 1 [2,3,42]} |] `shouldBeSameHtml` "[1,2,3,42] "
it "should support infix notation for standard constructors e.g. (,):" do
- [hsx|{((,) 1 2)} |] `shouldBeHtml` "(1,2) "
+ [hsx|{show $ ((,) 1 2)} |] `shouldBeSameHtml` "(1,2) "
it "should support self closing tags" do
- [hsx| Hello World |] `shouldBeHtml` "Hello World "
- [hsx| a |] `shouldBeHtml` "a "
- [hsx| a b |] `shouldBeHtml` "a b "
- [hsx| a b c |] `shouldBeHtml` "a b c "
+ [hsx| Hello World |] `shouldBeSameHtml` "Hello World "
+ [hsx| a |] `shouldBeSameHtml` "a "
+ [hsx| a b |] `shouldBeSameHtml` "a b "
+ [hsx| a b c |] `shouldBeSameHtml` "a b c "
it "should collapse spaces" do
[hsx|
Hello
World
!
- |] `shouldBeHtml` "Hello World !"
+ |] `shouldBeSameHtml` "Hello World !"
it "should not strip whitespace around variables near to text nodes" do
let name :: Text = "Tester"
- [hsx| Hello {name} ! |] `shouldBeHtml` "Hello Tester ! "
- [hsx| Hello {name}{name} ! |] `shouldBeHtml` "Hello TesterTester ! "
- [hsx| Hello {name} {name} ! |] `shouldBeHtml` "Hello Tester Tester ! "
- [hsx|{name}|] `shouldBeHtml` "Tester"
+ [hsx| Hello {name} ! |] `shouldBeSameHtml` "Hello Tester ! "
+ [hsx| Hello {name}{name} ! |] `shouldBeSameHtml` "Hello TesterTester ! "
+ [hsx| Hello {name} {name} ! |] `shouldBeSameHtml` "Hello Tester Tester ! "
+ [hsx|{name}|] `shouldBeSameHtml` "Tester"
let question :: Text = "Q"
let answer :: Text = "A"
- [hsx|{question} → {answer} |] `shouldBeHtml` "Q → A "
+ [hsx|{question} → {answer} |] `shouldBeSameHtml` "Q → A "
it "should work with html comments" do
- [hsx|
|] `shouldBeHtml` "
"
+ [Blaze.hsx|
|] `shouldBeBlazeHtml` "
"
+ [Lucid2.hsx|
|] `shouldBeLucid2Html` "
"
it "should work with no render comments" do
- [hsx|{- my comment -}
|] `shouldBeHtml` "
"
+ [hsx|{- my comment -}
|] `shouldBeSameHtml` "
"
it "should escape variables to avoid XSS" do
let variableContent :: Text = ""
- [hsx|{variableContent}|] `shouldBeHtml` "<script>alert(1);</script>"
+ [hsx|{variableContent}|] `shouldBeSameHtml` "<script>alert(1);</script>"
it "should parse custom web component tags" do
- [hsx|
|] `shouldBeHtml` "
"
+ [hsx|
|] `shouldBeSameHtml` "
"
it "should parse a small hsx document" do
let metaTags = [hsx|
@@ -135,13 +142,13 @@
IHP Forum