packages feed

ihp-hsx 1.4.1 → 1.5.0

raw patch · 22 files changed

+2151/−1693 lines, 22 filesdep +lucid2dep +mtldep +transformersdep ~basedep ~ghcdep ~template-haskell

Dependencies added: lucid2, mtl, transformers

Dependency ranges changed: base, ghc, template-haskell

Files

− IHP/HSX/Attribute.hs 
@@ -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 <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes-    applyAttribute attr attr' false h | "data-" `Text.isPrefixOf` attr = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') "false") -- data attribute set to "false"-    applyAttribute attr attr' false h = h -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false-    {-# INLINE applyAttribute #-}--instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where-    applyAttribute attr attr' (Just value) h = applyAttribute attr attr' value h-    applyAttribute attr attr' Nothing h = h-    {-# INLINE applyAttribute #-}--instance ApplyAttribute Html5.AttributeValue where-    applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value)-    {-# INLINE applyAttribute #-}--instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where-    applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h-    {-# INLINE applyAttribute #-}
− IHP/HSX/ConvertibleStrings.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-}--module IHP.HSX.ConvertibleStrings where--import Prelude-import Data.String.Conversions (ConvertibleStrings (convertString), cs)-import Text.Blaze.Html5-import Data.Text-import Data.ByteString-import qualified Text.Blaze.Html5        as Html5-import qualified Data.ByteString.Lazy as LBS--instance ConvertibleStrings String Html5.AttributeValue where-    {-# INLINE convertString #-}-    convertString = stringValue--instance ConvertibleStrings Text Html5.AttributeValue where-    {-# INLINE convertString #-}-    convertString = Html5.textValue--instance ConvertibleStrings String Html5.Html where-    {-# INLINE convertString #-}-    convertString = Html5.string--instance ConvertibleStrings ByteString Html5.AttributeValue where-    {-# INLINE convertString #-}-    convertString value = convertString (cs value :: Text)--instance ConvertibleStrings LBS.ByteString Html5.AttributeValue where-    {-# INLINE convertString #-}-    convertString value = convertString (cs value :: Text)--instance ConvertibleStrings Text Html5.Html where-    {-# INLINE convertString #-}-    convertString = Html5.text
− IHP/HSX/HaskellParser.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE CPP #-}-module IHP.HSX.HaskellParser (parseHaskellExpression) where--import Prelude-import GHC.Parser.Lexer (ParseResult (..), PState (..))-import GHC.Types.SrcLoc-import qualified GHC.Parser as Parser-import qualified GHC.Parser.Lexer as Lexer-import GHC.Data.FastString-import GHC.Data.StringBuffer-import GHC.Parser.PostProcess-import Text.Megaparsec.Pos-import qualified "template-haskell" Language.Haskell.TH as TH--import qualified GHC.Data.EnumSet as EnumSet-import GHC-import IHP.HSX.HsExpToTH (toExp)--import GHC.Types.Error-import GHC.Utils.Outputable hiding ((<>))-import GHC.Utils.Error-import qualified GHC.Types.SrcLoc as SrcLoc-#if __GLASGOW_HASKELL__ >= 908-import GHC.Unit.Module.Warnings-#endif--parseHaskellExpression :: SourcePos -> [TH.Extension] -> String -> Either (Int, Int, String) TH.Exp-parseHaskellExpression sourcePos extensions input =-        case expr of-            POk parserState result -> Right (toExp (unLoc result))-            PFailed parserState ->-                let-                    error = renderWithContext defaultSDocContext-                        $ vcat-#if __GLASGOW_HASKELL__ >= 908-                        $ map formatBulleted-#else-                        $ map (formatBulleted defaultSDocContext)-#endif-#if __GLASGOW_HASKELL__ >= 906-                        $ map (diagnosticMessage NoDiagnosticOpts)-#else-                        $ map diagnosticMessage-#endif-                        $ map errMsgDiagnostic-                        $ sortMsgBag Nothing-                        $ getMessages parserState.errors-                    line = SrcLoc.srcLocLine parserState.loc.psRealLoc-                    col = SrcLoc.srcLocCol parserState.loc.psRealLoc-                in-                    Left (line, col, error)-    where-        expr :: ParseResult (LocatedA (HsExpr GhcPs))-        expr = case Lexer.unP Parser.parseExpression parseState of-                POk parserState result -> Lexer.unP (runPV (unECP result)) parserState-                PFailed parserState -> PFailed parserState--        location :: RealSrcLoc-        location = mkRealSrcLoc filename line col-        -        filename :: FastString-        filename = mkFastString sourcePos.sourceName--        line :: Int-        line = unPos sourcePos.sourceLine--        col :: Int-        col = unPos sourcePos.sourceColumn--        buffer = stringToStringBuffer input-        parseState = Lexer.initParserState parserOpts buffer location--        parserOpts :: Lexer.ParserOpts-        parserOpts = Lexer.mkParserOpts (EnumSet.fromList extensions) diagOpts [] False False False False--diagOpts :: DiagOpts-diagOpts =-    DiagOpts-    { diag_warning_flags = EnumSet.empty-    , diag_fatal_warning_flags = EnumSet.empty-    , diag_warn_is_error = False-    , diag_reverse_errors = False-    , diag_max_errors = Nothing-    , diag_ppr_ctx = defaultSDocContext-#if __GLASGOW_HASKELL__ >= 908-    , diag_custom_warning_categories = emptyWarningCategorySet-    , diag_fatal_custom_warning_categories = emptyWarningCategorySet-#endif-    }
− IHP/HSX/HsExpToTH.hs 
@@ -1,239 +0,0 @@-{-# LANGUAGE ViewPatterns, CPP #-}-{-|-Module: IHP.HSX.HsExpToTH-Copyright: (c) digitally induced GmbH, 2022-Description: Converts Haskell AST to Template Haskell AST--Based on https://github.com/guibou/PyF/blob/b3aaee12d34380e55aa3909690041eccb8fcf001/src/PyF/Internal/Meta.hs--}-module IHP.HSX.HsExpToTH (toExp) where--import Prelude--import GHC.Hs.Expr as Expr-import GHC.Hs.Extension as Ext-import GHC.Hs.Pat as Pat-import GHC.Hs.Lit-import qualified GHC.Hs.Utils as Utils-import qualified Data.ByteString as B-import qualified Language.Haskell.TH.Syntax as TH-import GHC.Types.SrcLoc-import GHC.Types.Name-import GHC.Types.Name.Reader-import GHC.Data.FastString-import GHC.Utils.Outputable (Outputable, ppr, showSDocUnsafe)-import GHC.Types.Basic (Boxity(..))-import GHC.Types.SourceText (il_value, rationalFromFractionalLit)-import qualified GHC.Unit.Module as Module-import GHC.Stack-import qualified Data.List.NonEmpty as NonEmpty-import Language.Haskell.Syntax.Type-#if __GLASGOW_HASKELL__ >= 906-import Language.Haskell.Syntax.Basic-#endif---fl_value = rationalFromFractionalLit--toLit :: HsLit GhcPs -> TH.Lit-toLit (HsChar _ c) = TH.CharL c-toLit (HsCharPrim _ c) = TH.CharPrimL c-toLit (HsString _ s) = TH.StringL (unpackFS s)-toLit (HsStringPrim _ s) = TH.StringPrimL (B.unpack s)-toLit (HsInt _ i) = TH.IntegerL (il_value i)-toLit (HsIntPrim _ i) = TH.IntPrimL i-toLit (HsWordPrim _ i) = TH.WordPrimL i-toLit (HsInt64Prim _ i) = TH.IntegerL i-toLit (HsWord64Prim _ i) = TH.WordPrimL i-toLit (HsInteger _ i _) = TH.IntegerL i-toLit (HsRat _ f _) = TH.FloatPrimL (fl_value f)-toLit (HsFloatPrim _ f) = TH.FloatPrimL (fl_value f)-toLit (HsDoublePrim _ f) = TH.DoublePrimL (fl_value f)--toLit' :: OverLitVal -> TH.Lit-toLit' (HsIntegral i) = TH.IntegerL (il_value i)-toLit' (HsFractional f) = TH.RationalL (fl_value f)-toLit' (HsIsString _ fs) = TH.StringL (unpackFS fs)--toType :: HsType GhcPs -> TH.Type-toType (HsWildCardTy _) = TH.WildCardT-toType (HsTyVar _ _ n) =-  let n' = unLoc n-   in if isRdrTyVar n'-        then TH.VarT (toName n')-        else TH.ConT (toName n')-toType t = todo "toType" t--toName :: RdrName -> TH.Name-toName n = case n of-  (Unqual o) -> TH.mkName (occNameString o)-  (Qual m o) -> TH.mkName (Module.moduleNameString m <> "." <> occNameString o)-  (Exact name) -> TH.mkName ((occNameString . rdrNameOcc . getRdrName) name) --error "exact"-  (Orig _ _) -> error "orig"--toFieldExp :: a-toFieldExp = undefined--toPat :: Pat.Pat GhcPs -> TH.Pat-toPat (Pat.VarPat _ (unLoc -> name)) = TH.VarP (toName name)-toPat (TuplePat _ p _) = TH.TupP (map (toPat . unLoc) p)-toPat (ParPat xP _ lP _) = (toPat . unLoc) lP-toPat (ConPat pat_con_ext ((unLoc -> name)) pat_args) = TH.ConP (toName name) (map toType []) (map (toPat . unLoc) (Pat.hsConPatArgs pat_args))-toPat (ViewPat pat_con pat_args pat_con_ext) = error "TH.ViewPattern not implemented"-toPat (SumPat _ _ _ _) = error "TH.SumPat not implemented"-toPat (WildPat _ ) = error "TH.WildPat not implemented"-toPat (NPat _ _ _ _ ) = error "TH.NPat not implemented"-toPat p = todo "toPat" p--toExp :: Expr.HsExpr GhcPs -> TH.Exp-toExp (Expr.HsVar _ n) =-  let n' = unLoc n-   in if isRdrDataCon n'-        then TH.ConE (toName n')-        else TH.VarE (toName n')--#if __GLASGOW_HASKELL__ >= 906-toExp (Expr.HsUnboundVar _ n)              = TH.UnboundVarE (TH.mkName . occNameString $ occName n)-#else-toExp (Expr.HsUnboundVar _ n)              = TH.UnboundVarE (TH.mkName . occNameString $ n)-#endif--toExp Expr.HsIPVar {}-  = noTH "toExp" "HsIPVar"--toExp (Expr.HsLit _ l)-  = TH.LitE (toLit l)--toExp (Expr.HsOverLit _ OverLit {ol_val})-  = TH.LitE (toLit' ol_val)--toExp (Expr.HsApp _ e1 e2)-  = TH.AppE (toExp . unLoc $ e1) (toExp . unLoc $ e2)--#if __GLASGOW_HASKELL__ >= 906-toExp (Expr.HsAppType _ e _ HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)-#else-toExp (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)-#endif-toExp (Expr.ExprWithTySig _ e HsWC{hswc_body=unLoc -> HsSig{sig_body}}) = TH.SigE (toExp . unLoc $ e) (toType . unLoc $ sig_body)--toExp (Expr.OpApp _ e1 o e2)-  = TH.UInfixE (toExp . unLoc $ e1) (toExp . unLoc $ o) (toExp . unLoc $ e2)--toExp (Expr.NegApp _ e _)-  = TH.AppE (TH.VarE 'negate) (toExp . unLoc $ e)---- NOTE: for lambda, there is only one match-#if __GLASGOW_HASKELL__ >= 906-toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))-#else-toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)])) _))-#endif-  = TH.LamE (fmap toPat ps) (toExp e)---- toExp (Expr.Let _ bs e)                       = TH.LetE (toDecs bs) (toExp e)----toExp (Expr.HsIf _ a b c)                   = TH.CondE (toExp (unLoc a)) (toExp (unLoc b)) (toExp (unLoc c))---- toExp (Expr.MultiIf _ ifs)                    = TH.MultiIfE (map toGuard ifs)--- toExp (Expr.Case _ e alts)                    = TH.CaseE (toExp e) (map toMatch alts)--- toExp (Expr.Do _ ss)                          = TH.DoE (map toStmt ss)--- toExp e@Expr.MDo{}                            = noTH "toExp" e----toExp (Expr.ExplicitTuple _ args boxity) = ctor tupArgs-  where-    toTupArg (Expr.Present _ e) = Just $ unLoc e-    toTupArg (Expr.Missing _) = Nothing-    toTupArg _ = error "impossible case"--    ctor = case boxity of-      Boxed -> TH.TupE-      Unboxed -> TH.UnboxedTupE--    tupArgs = fmap ((fmap toExp) . toTupArg) args---- toExp (Expr.List _ xs)                        = TH.ListE (fmap toExp xs)-toExp (Expr.HsPar _ _ e _)-  = TH.ParensE (toExp . unLoc $ e)--toExp (Expr.SectionL _ (unLoc -> a) (unLoc -> b))-  = TH.InfixE (Just . toExp $ a) (toExp b) Nothing--toExp (Expr.SectionR _ (unLoc -> a) (unLoc -> b))-  = TH.InfixE Nothing (toExp a) (Just . toExp $ b)--toExp (Expr.RecordCon _ name HsRecFields {rec_flds})-  = TH.RecConE (toName . unLoc $ name) (fmap toFieldExp rec_flds)--toExp (Expr.RecordUpd _ (unLoc -> e) xs)                 = TH.RecUpdE (toExp e) $ case xs of-#if __GLASGOW_HASKELL__ >= 908-    RegularRecUpdFields { recUpdFields = fields } ->-#else-    Left fields ->-#endif-        let-            f (unLoc -> x) = (name, value)-                where-                    value = toExp $ unLoc $ hfbRHS x-                    name =-                        case unLoc (hfbLHS x) of-                            Unambiguous _ (unLoc -> name) -> toName name-                            Ambiguous _ (unLoc -> name) -> toName name-        in-            map f fields-    otherwise -> error "todo"--- toExp (Expr.ListComp _ e ss)                  = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]---  where---   convert (Expr.QualStmt _ st)                = toStmt st---   convert s                                   = noTH "toExp ListComp" s--- toExp (Expr.ExpTypeSig _ e t)                 = TH.SigE (toExp e) (toType t)----toExp (Expr.ExplicitList _ (map unLoc -> args)) = TH.ListE (map toExp args)--toExp (Expr.ArithSeq _ _ e)-  = TH.ArithSeqE $ case e of-    (From a) -> TH.FromR (toExp $ unLoc a)-    (FromThen a b) -> TH.FromThenR (toExp $ unLoc a) (toExp $ unLoc b)-    (FromTo a b) -> TH.FromToR (toExp $ unLoc a) (toExp $ unLoc b)-    (FromThenTo a b c) -> TH.FromThenToR (toExp $ unLoc a) (toExp $ unLoc b) (toExp $ unLoc c)---toExp (Expr.HsProjection _ locatedFields) =-  let-    extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr-    extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..."-  in-#if __GLASGOW_HASKELL__ >= 906-    TH.ProjectionE (NonEmpty.map (unpackFS . (.field_label) . unLoc . extractFieldLabel . unLoc) locatedFields)-#else-    TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)-#endif--toExp (Expr.HsGetField _ expr locatedField) =-  let-    extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr-    extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..."-  in-#if __GLASGOW_HASKELL__ >= 906-    TH.GetFieldE (toExp (unLoc expr)) (unpackFS . (.field_label) . unLoc . extractFieldLabel . unLoc $ locatedField)-#else-    TH.GetFieldE (toExp (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)-#endif--#if __GLASGOW_HASKELL__ >= 906-toExp (Expr.HsOverLabel _ _ fastString) = TH.LabelE (unpackFS fastString)-#else-toExp (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)-#endif--toExp e = todo "toExp" e---todo :: Outputable e => String -> e -> a-todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", (showSDocUnsafe $ ppr thing)]--noTH :: (HasCallStack, Show e) => String -> e -> a-noTH fun thing = error . concat $ [moduleName, ".", fun, ": no TemplateHaskell for: ", show thing]--moduleName :: String-moduleName = "IHP.HSX.HsExpToTH"
− IHP/HSX/Parser.hs 
@@ -1,642 +0,0 @@-{-# 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-, HsxSettings (..)-) 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 Data.String.Conversions-import qualified Data.List as List-import Control.Monad (unless)-import qualified "template-haskell" 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-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)--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 -- ^ A Comment that is rendered in the final HTML-    | NoRenderCommentNode -- ^ A comment that is not rendered in the final HTML-    deriving (Eq, 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 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 @<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.-    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 "<!--"-    body :: String <- manyTill (satisfy (const True)) (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 <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 = do-            let value = if "data-" `Text.isPrefixOf` key-                    then "true"-                    else key-            pure (StaticAttribute key (TextValue value))--    -- Parsing normal attributes like <input value="Hello"/>-    let attributeWithValue = do-            _ <- char '='-            space-            value <- hsxQuotedValue <|> hsxSplicedValue-            space-            pure (StaticAttribute key value)--    attributeWithValue <|> attributeWithoutValue---hsxAttributeName :: Parser Text-hsxAttributeName = do-        name <- rawAttribute-        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-            || name `Set.member` attributes-            || name `Set.member` ?settings.additionalAttributeNames--        rawAttribute = takeWhile1P Nothing (\c -> Char.isAlphaNum c || c == '-' || c == '_')---hsxQuotedValue :: Parser AttributeValue-hsxQuotedValue = do-    value <- between (char '"') (char '"') (takeWhileP Nothing (\c -> c /= '\"'))-    pure (TextValue value)--hsxSplicedValue :: Parser AttributeValue-hsxSplicedValue = do-    (pos, value) <- between (char '{') (char '}') do-        pos <- getSourcePos-        code <- takeWhile1P Nothing (\c -> c /= '}')-        pure (pos, code)-    haskellExpression <- parseHaskellExpression pos (cs value)-    pure (ExpressionValue haskellExpression)--hsxClosingElement name = (hsxClosingElement' name) <?> friendlyErrorMessage-    where-        friendlyErrorMessage = show (Text.unpack ("</" <> name <> ">"))-        hsxClosingElement' name = do-            _ <- string ("</" <> name)-            space-            char ('>')-            pure ()--hsxChild :: Parser Node-hsxChild = hsxElement <|> hsxSplicedNode <|> try (space >> hsxElement) <|> hsxText---- | Parses a hsx text node------ Stops parsing when hitting a variable, like `{myVar}`-hsxText :: Parser Node-hsxText = buildTextNode <$> takeWhile1P (Just "text") (\c -> c /= '{' && c /= '}' && c /= '<' && c /= '>')---- | Builds a TextNode and strips all surround whitespace from the input string-buildTextNode :: Text -> Node-buildTextNode value = TextNode (collapseSpace value)--data TokenTree = TokenLeaf Text | TokenNode [TokenTree] deriving (Show)--hsxSplicedNode :: Parser Node-hsxSplicedNode = do-        (pos, expression) <- doParse-        haskellExpression <- parseHaskellExpression pos (cs expression)-        pure (SplicedNode haskellExpression)-    where-        doParse = do-            (pos, tree) <- node-            let value = (treeToString "" tree)-            pure (pos, Text.init $ Text.tail value)--        parseTree = (snd <$> node) <|> leaf-        node = between (char '{') (char '}') do-                pos <- getSourcePos-                tree <- many parseTree-                pure (pos, TokenNode tree)-        leaf = TokenLeaf <$> takeWhile1P Nothing (\c -> c /= '{' && c /= '}')-        treeToString :: Text -> TokenTree -> Text-        treeToString acc (TokenLeaf value)  = acc <> value-        treeToString acc (TokenNode [])     = acc-        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 -                                  && 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--hsxIdentifier :: Parser Text-hsxIdentifier = do-    name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_')-    space-    pure name---attributes :: Set Text-attributes = Set.fromList-        [ "accept", "accept-charset", "accesskey", "action", "alt", "async"-        , "autocomplete", "autofocus", "autoplay", "challenge", "charset"-        , "checked", "cite", "class", "cols", "colspan", "content"-        , "contenteditable", "contextmenu", "controls", "coords", "data"-        , "datetime", "defer", "dir", "disabled", "draggable", "enctype"-        , "form", "formaction", "formenctype", "formmethod", "formnovalidate"-        , "for"-        , "formtarget", "headers", "height", "hidden", "high", "href"-        , "hreflang", "http-equiv", "icon", "id", "ismap", "item", "itemprop"-        , "itemscope", "itemtype"-        , "keytype", "label", "lang", "list", "loop", "low", "manifest", "max"-        , "maxlength", "media", "method", "min", "multiple", "name"-        , "novalidate", "onbeforeonload", "onbeforeprint", "onblur", "oncanplay"-        , "oncanplaythrough", "onchange", "oncontextmenu", "onclick"-        , "ondblclick", "ondrag", "ondragend", "ondragenter", "ondragleave"-        , "ondragover", "ondragstart", "ondrop", "ondurationchange", "onemptied"-        , "onended", "onerror", "onfocus", "onformchange", "onforminput"-        , "onhaschange", "oninput", "oninvalid", "onkeydown", "onkeyup"-        , "onload", "onloadeddata", "onloadedmetadata", "onloadstart"-        , "onmessage", "onmousedown", "onmousemove", "onmouseout", "onmouseover"-        , "onmouseup", "onmousewheel", "ononline", "onpagehide", "onpageshow"-        , "onpause", "onplay", "onplaying", "onprogress", "onpropstate"-        , "onratechange", "onreadystatechange", "onredo", "onresize", "onscroll"-        , "onseeked", "onseeking", "onselect", "onstalled", "onstorage"-        , "onsubmit", "onsuspend", "ontimeupdate", "onundo", "onunload"-        , "onvolumechange", "onwaiting", "open", "optimum", "pattern", "ping"-        , "placeholder", "preload", "pubdate", "radiogroup", "readonly", "rel"-        , "required", "reversed", "rows", "rowspan", "sandbox", "scope"-        , "scoped", "seamless", "selected", "shape", "size", "sizes", "span"-        , "spellcheck", "src", "srcdoc", "srcset", "start", "step", "style", "subject"-        , "summary", "tabindex", "target", "title", "type", "usemap", "value"-        , "width", "wrap", "xmlns"-        , "ontouchstart", "download"-        , "allowtransparency", "minlength", "maxlength", "property"-        , "role"-        , "d", "viewBox", "cx", "cy", "r", "x", "y", "text-anchor", "alignment-baseline"-        , "line-spacing", "letter-spacing"-        , "integrity", "crossorigin", "poster"-        , "accent-height", "accumulate", "additive", "alphabetic", "amplitude"-        , "arabic-form", "ascent", "attributeName", "attributeType", "azimuth"-        , "baseFrequency", "baseProfile", "bbox", "begin", "bias", "by", "calcMode"-        , "cap-height", "class", "clipPathUnits", "contentScriptType"-        , "contentStyleType", "cx", "cy", "d", "descent", "diffuseConstant", "divisor"-        , "dur", "dx", "dy", "edgeMode", "elevation", "end", "exponent"-        , "externalResourcesRequired", "filterRes", "filterUnits", "font-family"-        , "font-size", "font-stretch", "font-style", "font-variant", "font-weight"-        , "format", "from", "fx", "fy", "g1", "g2", "glyph-name", "glyphRef"-        , "gradientTransform", "gradientUnits", "hanging", "height", "horiz-adv-x"-        , "horiz-origin-x", "horiz-origin-y", "id", "ideographic", "in", "in2"-        , "intercept", "k", "k1", "k2", "k3", "k4", "kernelMatrix", "kernelUnitLength"-        , "keyPoints", "keySplines", "keyTimes", "lang", "lengthAdjust"-        , "limitingConeAngle", "local", "markerHeight", "markerUnits", "markerWidth"-        , "maskContentUnits", "maskUnits", "mathematical", "max", "media", "method"-        , "min", "mode", "name", "numOctaves", "offset", "onabort", "onactivate"-        , "onbegin", "onclick", "onend", "onerror", "onfocusin", "onfocusout", "onload"-        , "onmousedown", "onmousemove", "onmouseout", "onmouseover", "onmouseup"-        , "onrepeat", "onresize", "onscroll", "onunload", "onzoom", "operator", "order"-        , "orient", "orientation", "origin", "overline-position", "overline-thickness"-        , "panose-1", "path", "pathLength", "patternContentUnits", "patternTransform"-        , "patternUnits", "points", "pointsAtX", "pointsAtY", "pointsAtZ"-        , "preserveAlpha", "preserveAspectRatio", "primitiveUnits", "r", "radius"-        , "refX", "refY", "rendering-intent", "repeatCount", "repeatDur"-        , "requiredExtensions", "requiredFeatures", "restart", "result", "rotate", "rx"-        , "ry", "scale", "seed", "slope", "spacing", "specularConstant"-        , "specularExponent", "spreadMethod", "startOffset", "stdDeviation", "stemh"-        , "stemv", "stitchTiles", "strikethrough-position", "strikethrough-thickness"-        , "string", "style", "surfaceScale", "systemLanguage", "tableValues", "target"-        , "targetX", "targetY", "textLength", "title", "to", "transform", "type", "u1"-        , "u2", "underline-position", "underline-thickness", "unicode", "unicode-range"-        , "units-per-em", "v-alphabetic", "v-hanging", "v-ideographic", "v-mathematical"-        , "values", "version", "vert-adv-y", "vert-origin-x", "vert-origin-y", "viewBox"-        , "viewTarget", "width", "widths", "x", "x-height", "x1", "x2"-        , "xChannelSelector", "xlink:actuate", "xlink:arcrole", "xlink:href"-        , "xlink:role", "xlink:show", "xlink:title", "xlink:type", "xml:base"-        , "xml:lang", "xml:space", "y", "y1", "y2", "yChannelSelector", "z", "zoomAndPan"-        , "alignment-baseline", "baseline-shift", "clip-path", "clip-rule"-        , "clip", "color-interpolation-filters", "color-interpolation"-        , "color-profile", "color-rendering", "color", "cursor", "direction"-        , "display", "dominant-baseline", "enable-background", "fill-opacity"-        , "fill-rule", "fill", "filter", "flood-color", "flood-opacity"-        , "font-size-adjust", "glyph-orientation-horizontal"-        , "glyph-orientation-vertical", "image-rendering", "kerning", "letter-spacing"-        , "lighting-color", "marker-end", "marker-mid", "marker-start", "mask"-        , "opacity", "overflow", "pointer-events", "shape-rendering", "stop-color"-        , "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", "is"-        , "cellspacing", "cellpadding", "bgcolor", "classes"-        , "loading"-        , "frameborder", "allow", "allowfullscreen", "nonce", "referrerpolicy", "slot"-        , "kind"-        , "html"-        , "sse-connect", "sse-swap"-        ]--parents :: Set Text-parents = Set.fromList-          [ "a"-          , "abbr"-          , "address"-          , "animate"-          , "animateMotion"-          , "animateTransform"-          , "article"-          , "aside"-          , "audio"-          , "b"-          , "bdi"-          , "bdo"-          , "blink"-          , "blockquote"-          , "body"-          , "button"-          , "canvas"-          , "caption"-          , "circle"-          , "cite"-          , "clipPath"-          , "code"-          , "colgroup"-          , "command"-          , "data"-          , "datalist"-          , "dd"-          , "defs"-          , "del"-          , "desc"-          , "details"-          , "dfn"-          , "dialog"-          , "discard"-          , "div"-          , "dl"-          , "dt"-          , "ellipse"-          , "em"-          , "feBlend"-          , "feColorMatrix"-          , "feComponentTransfer"-          , "feComposite"-          , "feConvolveMatrix"-          , "feDiffuseLighting"-          , "feDisplacementMap"-          , "feDistantLight"-          , "feDropShadow"-          , "feFlood"-          , "feFuncA"-          , "feFuncB"-          , "feFuncG"-          , "feFuncR"-          , "feGaussianBlur"-          , "feImage"-          , "feMerge"-          , "feMergeNode"-          , "feMorphology"-          , "feOffset"-          , "fePointLight"-          , "feSpecularLighting"-          , "feSpotLight"-          , "feTile"-          , "feTurbulence"-          , "fieldset"-          , "figcaption"-          , "figure"-          , "filter"-          , "footer"-          , "foreignObject"-          , "form"-          , "g"-          , "h1"-          , "h2"-          , "h3"-          , "h4"-          , "h5"-          , "h6"-          , "hatch"-          , "hatchpath"-          , "head"-          , "header"-          , "hgroup"-          , "html"-          , "i"-          , "iframe"-          , "ins"-          , "ion-icon"-          , "kbd"-          , "label"-          , "legend"-          , "li"-          , "line"-          , "linearGradient"-          , "loading"-          , "main"-          , "map"-          , "mark"-          , "marker"-          , "marquee"-          , "mask"-          , "menu"-          , "mesh"-          , "meshgradient"-          , "meshpatch"-          , "meshrow"-          , "metadata"-          , "meter"-          , "mpath"-          , "nav"-          , "noscript"-          , "object"-          , "ol"-          , "optgroup"-          , "option"-          , "output"-          , "p"-          , "path"-          , "pattern"-          , "picture"-          , "polygon"-          , "polyline"-          , "pre"-          , "progress"-          , "q"-          , "radialGradient"-          , "rect"-          , "rp"-          , "rt"-          , "ruby"-          , "s"-          , "samp"-          , "script"-          , "section"-          , "select"-          , "set"-          , "slot"-          , "small"-          , "source"-          , "span"-          , "stop"-          , "strong"-          , "style"-          , "sub"-          , "summary"-          , "sup"-          , "svg"-          , "switch"-          , "symbol"-          , "table"-          , "tbody"-          , "td"-          , "template"-          , "text"-          , "textPath"-          , "textarea"-          , "tfoot"-          , "th"-          , "thead"-          , "time"-          , "title"-          , "tr"-          , "track"-          , "tspan"-          , "u"-          , "ul"-          , "unknown"-          , "use"-          , "var"-          , "video"-          , "view"-          , "wbr"-          ]--leafs :: Set Text-leafs = Set.fromList-        [ "area"-        , "base"-        , "br"-        , "col"-        , "embed"-        , "hr"-        , "img"-        , "input"-        , "link"-        , "meta"-        , "param"-        , "!DOCTYPE"-        ]--stripTextNodeWhitespaces nodes = stripLastTextNodeWhitespaces (stripFirstTextNodeWhitespaces nodes)--stripLastTextNodeWhitespaces nodes =-    let strippedLastElement = if List.length nodes > 0-            then case List.last nodes of-                TextNode text -> Just $ TextNode (Text.stripEnd text)-                otherwise -> Nothing-            else Nothing-    in case strippedLastElement of-        Just last -> (fst $ List.splitAt ((List.length nodes) - 1) nodes) <> [last]-        Nothing -> nodes--stripFirstTextNodeWhitespaces nodes =-    let strippedFirstElement = if List.length nodes > 0-            then case List.head nodes of-                TextNode text -> Just $ TextNode (Text.stripStart text)-                otherwise -> Nothing-            else Nothing-    in case strippedFirstElement of-        Just first -> first:(List.tail nodes)-        Nothing -> nodes---- | Replaces multiple space characters with a single one-collapseSpace :: Text -> Text-collapseSpace text = cs $ filterDuplicateSpaces (cs text)-    where-        filterDuplicateSpaces :: String -> String-        filterDuplicateSpaces string = filterDuplicateSpaces' string False--        filterDuplicateSpaces' :: String -> Bool -> String-        filterDuplicateSpaces' (char:rest) True | Char.isSpace char = filterDuplicateSpaces' rest True-        filterDuplicateSpaces' (char:rest) False | Char.isSpace char = ' ':(filterDuplicateSpaces' rest True)-        filterDuplicateSpaces' (char:rest) isRemovingSpaces = char:(filterDuplicateSpaces' rest False)-        filterDuplicateSpaces' [] isRemovingSpaces = []
− IHP/HSX/QQ.hs 
@@ -1,481 +0,0 @@-{-# LANGUAGE TemplateHaskell, UndecidableInstances, BangPatterns, PackageImports, FlexibleInstances, OverloadedStrings #-}--{-|-Module: IHP.HSX.QQ-Description: Defines the @[hsx||]@ syntax-Copyright: (c) digitally induced GmbH, 2022--}-module IHP.HSX.QQ (hsx, uncheckedHsx, customHsx) where--import           Prelude-import Data.Text (Text)-import           IHP.HSX.Parser-import qualified "template-haskell" Language.Haskell.TH           as TH-import qualified "template-haskell" Language.Haskell.TH.Syntax           as TH-import           Language.Haskell.TH.Quote-import           Text.Blaze.Html5              ((!))-import qualified Text.Blaze.Html5              as Html5-import Text.Blaze.Html (Html)-import Text.Blaze.Internal (attribute, MarkupM (Parent, Leaf), StaticString (..))-import Data.String.Conversions-import IHP.HSX.ToHtml-import qualified Text.Megaparsec as Megaparsec-import qualified Text.Blaze.Html.Renderer.String as BlazeString-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-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 = customHsx -        (HsxSettings -            { checkMarkup = True-            , additionalTagNames = Set.empty-            , additionalAttributeNames = Set.empty-            }-        )--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 settings hsxPosition extensions (cs code) of-                Left error   -> fail (Megaparsec.errorBundlePretty error)-                Right result -> pure result-        compileToHaskell expression-    where--        findHSXPosition = do-            loc <- TH.location-            let (line, col) = TH.loc_start loc-            pure $ Megaparsec.SourcePos (TH.loc_filename loc) (Megaparsec.mkPos line) (Megaparsec.mkPos col)--compileToHaskell :: Node -> TH.ExpQ-compileToHaskell (Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True) = [| Html5.docType |]-compileToHaskell (Node name attributes children isLeaf) =-    let-        renderedChildren = TH.listE $ map compileToHaskell children-        stringAttributes = TH.listE $ map toStringAttribute attributes-    in-        if isLeaf-            then-                let-                    element = nodeToBlazeLeaf name-                in-                    [| applyAttributes $element $stringAttributes |]-            else-                let-                    element = nodeToBlazeElement name-                in [| applyAttributes ($element (mconcat $renderedChildren)) $stringAttributes |]-compileToHaskell (Children children) =-    let-        renderedChildren = TH.listE $ map compileToHaskell children-    in [| mconcat $(renderedChildren) |]--compileToHaskell (TextNode value) = [| Html5.preEscapedText value |]-compileToHaskell (PreEscapedTextNode value) = [| Html5.preEscapedText value |]-compileToHaskell (SplicedNode expression) = [| toHtml $(pure expression) |]-compileToHaskell (CommentNode value) = [| Html5.textComment value |]-compileToHaskell (NoRenderCommentNode) = [| mempty |]--nodeToBlazeElement :: Text -> TH.Q TH.Exp-nodeToBlazeElement name =-    HashMap.findWithDefault (nodeToBlazeElementGeneric name) name knownElements--knownElements :: HashMap.HashMap Text TH.ExpQ-knownElements =-    HashMap.fromList-        [ ("a", [| Html5.a |])-        , ("abbr", [| Html5.abbr |])-        , ("address", [| Html5.address |])-        , ("article", [| Html5.article |])-        , ("aside", [| Html5.aside |])-        , ("audio", [| Html5.audio |])-        , ("b", [| Html5.b |])-        , ("blockquote", [| Html5.blockquote |])-        , ("body", [| Html5.body |])-        , ("button", [| Html5.button |])-        , ("canvas", [| Html5.canvas |])-        , ("caption", [| Html5.caption |])-        , ("cite", [| Html5.cite |])-        , ("code", [| Html5.code |])-        , ("colgroup", [| Html5.colgroup |])-        , ("datalist", [| Html5.datalist |])-        , ("dd", [| Html5.dd |])-        , ("del", [| Html5.del |])-        , ("details", [| Html5.details |])-        , ("dfn", [| Html5.dfn |])-        , ("div", [| Html5.div |])-        , ("dl", [| Html5.dl |])-        , ("dt", [| Html5.dt |])-        , ("em", [| Html5.em |])-        , ("fieldset", [| Html5.fieldset |])-        , ("figcaption", [| Html5.figcaption |])-        , ("figure", [| Html5.figure |])-        , ("footer", [| Html5.footer |])-        , ("form", [| Html5.form |])-        , ("h1", [| Html5.h1 |])-        , ("h2", [| Html5.h2 |])-        , ("h3", [| Html5.h3 |])-        , ("h4", [| Html5.h4 |])-        , ("h5", [| Html5.h5 |])-        , ("h6", [| Html5.h6 |])-        , ("head", [| Html5.head |])-        , ("header", [| Html5.header |])-        , ("hgroup", [| Html5.hgroup |])-        , ("html", [| Html5.html |])-        , ("i", [| Html5.i |])-        , ("iframe", [| Html5.iframe |])-        , ("ins", [| Html5.ins |])-        , ("kbd", [| Html5.kbd |])-        , ("label", [| Html5.label |])-        , ("legend", [| Html5.legend |])-        , ("li", [| Html5.li |])-        , ("main", [| Html5.main |])-        , ("map", [| Html5.map |])-        , ("mark", [| Html5.mark |])-        , ("menu", [| Html5.menu |])-        , ("menuitem", [| Html5.menuitem |])-        , ("meter", [| Html5.meter |])-        , ("nav", [| Html5.nav |])-        , ("noscript", [| Html5.noscript |])-        , ("object", [| Html5.object |])-        , ("ol", [| Html5.ol |])-        , ("optgroup", [| Html5.optgroup |])-        , ("option", [| Html5.option |])-        , ("output", [| Html5.output |])-        , ("p", [| Html5.p |])-        , ("pre", [| Html5.pre |])-        , ("progress", [| Html5.progress |])-        , ("q", [| Html5.q |])-        , ("rp", [| Html5.rp |])-        , ("rt", [| Html5.rt |])-        , ("ruby", [| Html5.ruby |])-        , ("s", [| Html5.s |])-        , ("samp", [| Html5.samp |])-        , ("script", [| Html5.script |])-        , ("section", [| Html5.section |])-        , ("select", [| Html5.select |])-        , ("small", [| Html5.small |])-        , ("span", [| Html5.span |])-        , ("strong", [| Html5.strong |])-        , ("style", [| Html5.style |])-        , ("sub", [| Html5.sub |])-        , ("summary", [| Html5.summary |])-        , ("sup", [| Html5.sup |])-        , ("table", [| Html5.table |])-        , ("tbody", [| Html5.tbody |])-        , ("td", [| Html5.td |])-        , ("textarea", [| Html5.textarea |])-        , ("tfoot", [| Html5.tfoot |])-        , ("th", [| Html5.th |])-        , ("thead", [| Html5.thead |])-        , ("time", [| Html5.time |])-        , ("title", [| Html5.title |])-        , ("tr", [| Html5.tr |])-        , ("u", [| Html5.u |])-        , ("ul", [| Html5.ul |])-        , ("var", [| Html5.var |])-        , ("video", [| Html5.video |])-        ]--nodeToBlazeLeaf :: Text -> TH.Q TH.Exp-nodeToBlazeLeaf name =-    HashMap.findWithDefault (nodeToBlazeLeafGeneric name) name knownLeafs--knownLeafs :: HashMap.HashMap Text TH.ExpQ-knownLeafs =-    HashMap.fromList-        [ ("area", [| Html5.area |])-        , ("base", [| Html5.base |])-        , ("br", [| Html5.br |])-        , ("col", [| Html5.col |])-        , ("embed", [| Html5.embed |])-        , ("hr", [| Html5.hr |])-        , ("img", [| Html5.img |])-        , ("input", [| Html5.input |])-        , ("keygen", [| Html5.keygen |])-        , ("link", [| Html5.link |])-        , ("meta", [| Html5.meta |])-        , ("param", [| Html5.param |])-        , ("source", [| Html5.source |])-        , ("track", [| Html5.track |])-        , ("wbr", [| Html5.wbr |])-        ]--nodeToBlazeElementGeneric :: Text -> TH.Q TH.Exp-nodeToBlazeElementGeneric name =-    let-        openTag :: Text-        openTag = "<" <> tag-        -        tag :: Text-        tag = cs name--        closeTag :: Text-        closeTag = "</" <> tag <> ">"-    in-        [| makeParent (textToStaticString $(TH.lift name)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) |]--nodeToBlazeLeafGeneric :: Text -> TH.Q TH.Exp-nodeToBlazeLeafGeneric name =-    let-        openTag :: Text-        openTag = "<" <> tag--        closeTag :: Text-        closeTag = ">"-        -        tag :: Text-        tag = cs name-    in-        [| (Leaf (textToStaticString $(TH.lift tag)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) ()) |]--toStringAttribute :: Attribute -> TH.ExpQ-toStringAttribute (StaticAttribute name (TextValue value)) =-    attributeFromName name value--toStringAttribute (StaticAttribute name (ExpressionValue expression)) = let nameWithSuffix = " " <> name <> "=\"" in [| applyAttribute name nameWithSuffix $(pure expression) |]-toStringAttribute (SpreadAttributes expression) = [| spreadAttributes $(pure expression) |]--attributeFromName :: Text -> Text -> TH.ExpQ-attributeFromName name value =-    let-        value' :: TH.ExpQ-        value' = if Text.null value then [| mempty |] else [| Html5.preEscapedTextValue value |] --        attr = attributeFromName' name-    in-        [| (! $attr $value') |]--attributeFromName' :: Text -> TH.ExpQ-attributeFromName' name =-    HashMap.findWithDefault (attributeFromNameGeneric name) name knownAttributes--knownAttributes :: HashMap.HashMap Text TH.ExpQ-knownAttributes =-    HashMap.fromList-        [ ("accept", [| Attributes.accept |])-        , ( "accept-charset", [| Attributes.acceptCharset |])-        , ( "accesskey", [| Attributes.accesskey |])-        , ( "action", [| Attributes.action |])-        , ( "alt", [| Attributes.alt |])-        , ( "async", [| Attributes.async |])-        , ( "autocomplete", [| Attributes.autocomplete |])-        , ( "autofocus", [| Attributes.autofocus |])-        , ( "autoplay", [| Attributes.autoplay |])-        , ( "challenge", [| Attributes.challenge |])-        , ( "charset", [| Attributes.charset |])-        , ( "checked", [| Attributes.checked |])-        , ( "cite", [| Attributes.cite |])-        , ( "class", [| Attributes.class_ |])-        , ( "cols", [| Attributes.cols |])-        , ( "colspan", [| Attributes.colspan |])-        , ( "content", [| Attributes.content |])-        , ( "contenteditable", [| Attributes.contenteditable |])-        , ( "contextmenu", [| Attributes.contextmenu |])-        , ( "controls", [| Attributes.controls |])-        , ( "coords", [| Attributes.coords |])-        , ( "data", [| Attributes.data_ |])-        , ( "datetime", [| Attributes.datetime |])-        , ( "defer", [| Attributes.defer |])-        , ( "dir", [| Attributes.dir |])-        , ( "disabled", [| Attributes.disabled |])-        , ( "download", [| Attributes.download |])-        , ( "draggable", [| Attributes.draggable |])-        , ( "enctype", [| Attributes.enctype |])-        , ( "for", [| Attributes.for |])-        , ( "form", [| Attributes.form |])-        , ( "formaction", [| Attributes.formaction |])-        , ( "formenctype", [| Attributes.formenctype |])-        , ( "formmethod", [| Attributes.formmethod |])-        , ( "formnovalidate", [| Attributes.formnovalidate |])-        , ( "formtarget", [| Attributes.formtarget |])-        , ( "headers", [| Attributes.headers |])-        , ( "height", [| Attributes.height |])-        , ( "hidden", [| Attributes.hidden |])-        , ( "high", [| Attributes.high |])-        , ( "href", [| Attributes.href |])-        , ( "hreflang", [| Attributes.hreflang |])-        , ( "http-equiv", [| Attributes.httpEquiv |])-        , ( "icon", [| Attributes.icon |])-        , ( "id", [| Attributes.id |])-        , ( "ismap", [| Attributes.ismap |])-        , ( "item", [| Attributes.item |])-        , ( "itemprop", [| Attributes.itemprop |])-        , ( "itemscope", [| Attributes.itemscope |])-        , ( "itemtype", [| Attributes.itemtype |])-        , ( "keytype", [| Attributes.keytype |])-        , ( "label", [| Attributes.label |])-        , ( "lang", [| Attributes.lang |])-        , ( "list", [| Attributes.list |])-        , ( "loop", [| Attributes.loop |])-        , ( "low", [| Attributes.low |])-        , ( "manifest", [| Attributes.manifest |])-        , ( "max", [| Attributes.max |])-        , ( "maxlength", [| Attributes.maxlength |])-        , ( "media", [| Attributes.media |])-        , ( "method", [| Attributes.method |])-        , ( "min", [| Attributes.min |])-        , ( "minlength", [| Attributes.minlength |])-        , ( "multiple", [| Attributes.multiple |])-        , ( "muted", [| Attributes.muted |])-        , ( "name", [| Attributes.name |])-        , ( "novalidate", [| Attributes.novalidate |])-        , ( "onbeforeonload", [| Attributes.onbeforeonload |])-        , ( "onbeforeprint", [| Attributes.onbeforeprint |])-        , ( "onblur", [| Attributes.onblur |])-        , ( "oncanplay", [| Attributes.oncanplay |])-        , ( "oncanplaythrough", [| Attributes.oncanplaythrough |])-        , ( "onchange", [| Attributes.onchange |])-        , ( "onclick", [| Attributes.onclick |])-        , ( "oncontextmenu", [| Attributes.oncontextmenu |])-        , ( "ondblclick", [| Attributes.ondblclick |])-        , ( "ondrag", [| Attributes.ondrag |])-        , ( "ondragend", [| Attributes.ondragend |])-        , ( "ondragenter", [| Attributes.ondragenter |])-        , ( "ondragleave", [| Attributes.ondragleave |])-        , ( "ondragover", [| Attributes.ondragover |])-        , ( "ondragstart", [| Attributes.ondragstart |])-        , ( "ondrop", [| Attributes.ondrop |])-        , ( "ondurationchange", [| Attributes.ondurationchange |])-        , ( "onemptied", [| Attributes.onemptied |])-        , ( "onended", [| Attributes.onended |])-        , ( "onerror", [| Attributes.onerror |])-        , ( "onfocus", [| Attributes.onfocus |])-        , ( "onformchange", [| Attributes.onformchange |])-        , ( "onforminput", [| Attributes.onforminput |])-        , ( "onhaschange", [| Attributes.onhaschange |])-        , ( "oninput", [| Attributes.oninput |])-        , ( "oninvalid", [| Attributes.oninvalid |])-        , ( "onkeydown", [| Attributes.onkeydown |])-        , ( "onkeypress", [| Attributes.onkeypress |])-        , ( "onkeyup", [| Attributes.onkeyup |])-        , ( "onload", [| Attributes.onload |])-        , ( "onloadeddata", [| Attributes.onloadeddata |])-        , ( "onloadedmetadata", [| Attributes.onloadedmetadata |])-        , ( "onloadstart", [| Attributes.onloadstart |])-        , ( "onmessage", [| Attributes.onmessage |])-        , ( "onmousedown", [| Attributes.onmousedown |])-        , ( "onmousemove", [| Attributes.onmousemove |])-        , ( "onmouseout", [| Attributes.onmouseout |])-        , ( "onmouseover", [| Attributes.onmouseover |])-        , ( "onmouseup", [| Attributes.onmouseup |])-        , ( "onmousewheel", [| Attributes.onmousewheel |])-        , ( "ononline", [| Attributes.ononline |])-        , ( "onpagehide", [| Attributes.onpagehide |])-        , ( "onpageshow", [| Attributes.onpageshow |])-        , ( "onpause", [| Attributes.onpause |])-        , ( "onplay", [| Attributes.onplay |])-        , ( "onplaying", [| Attributes.onplaying |])-        , ( "onprogress", [| Attributes.onprogress |])-        , ( "onpropstate", [| Attributes.onpropstate |])-        , ( "onratechange", [| Attributes.onratechange |])-        , ( "onreadystatechange", [| Attributes.onreadystatechange |])-        , ( "onredo", [| Attributes.onredo |])-        , ( "onresize", [| Attributes.onresize |])-        , ( "onscroll", [| Attributes.onscroll |])-        , ( "onseeked", [| Attributes.onseeked |])-        , ( "onseeking", [| Attributes.onseeking |])-        , ( "onselect", [| Attributes.onselect |])-        , ( "onstalled", [| Attributes.onstalled |])-        , ( "onstorage", [| Attributes.onstorage |])-        , ( "onsubmit", [| Attributes.onsubmit |])-        , ( "onsuspend", [| Attributes.onsuspend |])-        , ( "ontimeupdate", [| Attributes.ontimeupdate |])-        , ( "onundo", [| Attributes.onundo |])-        , ( "onunload", [| Attributes.onunload |])-        , ( "onvolumechange", [| Attributes.onvolumechange |])-        , ( "onwaiting", [| Attributes.onwaiting |])-        , ( "open", [| Attributes.open |])-        , ( "optimum", [| Attributes.optimum |])-        , ( "pattern", [| Attributes.pattern |])-        , ( "ping", [| Attributes.ping |])-        , ( "placeholder", [| Attributes.placeholder |])-        , ( "poster", [| Attributes.poster |])-        , ( "preload", [| Attributes.preload |])-        , ( "property", [| Attributes.property |])-        , ( "pubdate", [| Attributes.pubdate |])-        , ( "radiogroup", [| Attributes.radiogroup |])-        , ( "readonly", [| Attributes.readonly |])-        , ( "rel", [| Attributes.rel |])-        , ( "required", [| Attributes.required |])-        , ( "reversed", [| Attributes.reversed |])-        , ( "role", [| Attributes.role |])-        , ( "rows", [| Attributes.rows |])-        , ( "rowspan", [| Attributes.rowspan |])-        , ( "sandbox", [| Attributes.sandbox |])-        , ( "scope", [| Attributes.scope |])-        , ( "scoped", [| Attributes.scoped |])-        , ( "seamless", [| Attributes.seamless |])-        , ( "selected", [| Attributes.selected |])-        , ( "shape", [| Attributes.shape |])-        , ( "size", [| Attributes.size |])-        , ( "sizes", [| Attributes.sizes |])-        , ( "span", [| Attributes.span |])-        , ( "spellcheck", [| Attributes.spellcheck |])-        , ( "src", [| Attributes.src |])-        , ( "srcdoc", [| Attributes.srcdoc |])-        , ( "start", [| Attributes.start |])-        , ( "step", [| Attributes.step |])-        , ( "style", [| Attributes.style |])-        , ( "subject", [| Attributes.subject |])-        , ( "summary", [| Attributes.summary |])-        , ( "tabindex", [| Attributes.tabindex |])-        , ( "target", [| Attributes.target |])-        , ( "title", [| Attributes.title |])-        , ( "type", [| Attributes.type_ |])-        , ( "usemap", [| Attributes.usemap |])-        , ( "value", [| Attributes.value |])-        , ( "width", [| Attributes.width |])-        , ( "wrap", [| Attributes.wrap |])-        , ( "xmlns", [| Attributes.xmlns |])-        ]--attributeFromNameGeneric :: Text -> TH.ExpQ-attributeFromNameGeneric name =-    let-        nameWithSuffix = " " <> name <> "=\""-    in-        [| attribute (Html5.textTag name) (Html5.textTag nameWithSuffix) |]--spreadAttributes :: ApplyAttribute value => [(Text, value)] -> Html5.Html -> Html5.Html-spreadAttributes attributes html = applyAttributes html $ map (\(name, value) -> applyAttribute name (" " <> name <> "=\"") value) attributes-{-# INLINE spreadAttributes #-}--applyAttributes :: Html5.Html -> [Html5.Html -> Html5.Html] -> Html5.Html-applyAttributes element (attribute:rest) = applyAttributes (attribute element) rest-applyAttributes element [] = element-{-# INLINE applyAttributes #-}--makeParent :: StaticString -> StaticString -> StaticString -> Html -> Html-makeParent tag openTag closeTag children = Parent tag openTag closeTag children-{-# INLINE makeParent #-}--textToStaticString :: Text -> StaticString-textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 text) text-{-# INLINE textToStaticString #-}--instance Show (MarkupM ()) where-    show html = BlazeString.renderHtml html
− IHP/HSX/ToHtml.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE  UndecidableInstances #-}-{-# LANGUAGE  FlexibleInstances #-}--{-|-Module: IHP.HSX.ToHtml-Description: Provides a few helper instances that convert data structures to HTML-Copyright: (c) digitally induced GmbH, 2022--}-module IHP.HSX.ToHtml where--import Prelude-import qualified Text.Blaze.Html5 as Html5-import qualified Text.Blaze.Internal-import Data.Text-import Data.ByteString-import Data.String.Conversions (cs)-import IHP.HSX.ConvertibleStrings ()--class ToHtml a where-    toHtml :: a -> Html5.Html--instance ToHtml (Text.Blaze.Internal.MarkupM ()) where-    {-# INLINE toHtml #-}-    toHtml a = a--instance ToHtml Text where-    {-# INLINE toHtml #-}-    toHtml = Html5.text--instance ToHtml String where-    {-# INLINE toHtml #-}-    toHtml = Html5.string--instance ToHtml ByteString where-    {-# INLINE toHtml #-}-    toHtml value = toHtml (cs value :: Text)--instance {-# OVERLAPPABLE #-} ToHtml a => ToHtml (Maybe a) where-    {-# INLINE toHtml #-}-    toHtml maybeValue = maybe mempty toHtml maybeValue--instance {-# OVERLAPPABLE #-} Show a => ToHtml a where-    {-# INLINE toHtml #-}-    toHtml value = Html5.string (show value)
Test/IHP/HSX/CustomHsxCases.hs view
@@ -4,15 +4,42 @@ -} 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 qualified IHP.HSX.QQ as Blaze+import qualified IHP.HSX.ToHtml as Blaze+import qualified IHP.HSX.Lucid2.QQ as Lucid2+import qualified IHP.HSX.Lucid2.ToHtml as IHPLucid2+import qualified Text.Blaze as Blaze import Language.Haskell.TH.Quote+import qualified "template-haskell" Language.Haskell.TH           as TH import IHP.HSX.Parser import qualified Data.Set as Set+import qualified "lucid2" Lucid.Base as Lucid2 (Html, HtmlT, ToHtml(..))+import Lucid.Base (generalizeHtmlT) +{- This allows us to share test cases between the blaze and lucid backends for+ - HSX. We build a QuasiQuoter that takes the same string splice as input, and+ - runs it through both backends. It also converts the results into lazy text+ - values for testing purposes.+ -}+customHsx :: HsxSettings -> QuasiQuoter+customHsx settings =+    QuasiQuoter+        { quoteExp = quoteHsxExpressionShared settings+        , quotePat = error "quotePat: not defined"+        , quoteDec = error "quoteDec: not defined"+        , quoteType = error "quoteType: not defined"+        }++hsx :: QuasiQuoter+hsx = customHsx+        (HsxSettings+            { checkMarkup = True+            , additionalTagNames = Set.empty+            , additionalAttributeNames = Set.empty+            }+        )+ myCustomHsx :: QuasiQuoter myCustomHsx = customHsx      (HsxSettings { checkMarkup = True@@ -36,3 +63,31 @@                  , additionalAttributeNames = Set.fromList ["my-custom-attr", "anothercustomattr"]                  }     )++data AllBackends = MkAllBackends+  { blazeMarkup :: !Blaze.Markup+  , lucid2Html :: !(Lucid2.Html ())+  , lucid2HtmlM :: !(Lucid2.Html ())+  } deriving Show++instance Lucid2.ToHtml AllBackends where+  toHtml = generalizeHtmlT . lucid2Html+  toHtmlRaw = generalizeHtmlT . lucid2Html++instance (Monad m) => IHPLucid2.EmbedAsHtml (Lucid2.HtmlT m) AllBackends where+    toHtml = IHPLucid2.Lucid2Html . generalizeHtmlT . lucid2HtmlM+    toHtmlRaw = IHPLucid2.Lucid2Html . generalizeHtmlT . lucid2HtmlM++instance Blaze.ToHtml AllBackends where+  toHtml = blazeMarkup++quoteHsxExpressionShared :: HsxSettings -> String -> TH.ExpQ+quoteHsxExpressionShared settings spliceStr =+  let blazeExp = Blaze.quoteHsxExpression settings spliceStr+      lucidExp = Lucid2.quoteHsxExpression settings spliceStr+      lucidExpM = Lucid2.quoteHsxExpressionM settings spliceStr+   in [| MkAllBackends+       { blazeMarkup = $blazeExp+       , lucid2Html = $lucidExp+       , lucid2HtmlM = $lucidExpM+       } |]
Test/IHP/HSX/QQSpec.hs view
@@ -6,111 +6,118 @@  import Test.Hspec import Prelude-import IHP.HSX.QQ+import Control.Monad.State.Strict (State, get, put, evalState)+import qualified IHP.HSX.QQ as Blaze+import qualified IHP.HSX.Lucid2.QQ as Lucid2+import qualified IHP.HSX.Lucid2.Attribute as Lucid2 import qualified Text.Blaze.Renderer.Text as Blaze+import qualified Text.Blaze as Blaze import Text.Blaze (preEscapedTextValue)-import Data.Text+import Data.Text (Text)+import qualified Data.Text.Lazy as TL import IHP.HSX.CustomHsxCases+import qualified "lucid2" Lucid.Base as Lucid2 (Html, HtmlT, renderText, renderTextT)  tests :: SpecWith () tests = do     describe "HSX" do         it "should work with static html" do-            [hsx|<strong>hello world</strong>|] `shouldBeHtml` "<strong>hello world</strong>"-            [hsx|<h1>hello world</h1>|] `shouldBeHtml` "<h1>hello world</h1>"-            [hsx|<blink>web scale</blink>|] `shouldBeHtml` "<blink>web scale</blink>"+            [hsx|<strong>hello world</strong>|] `shouldBeSameHtml` "<strong>hello world</strong>"+            [hsx|<h1>hello world</h1>|] `shouldBeSameHtml` "<h1>hello world</h1>"+            [hsx|<blink>web scale</blink>|] `shouldBeSameHtml` "<blink>web scale</blink>"          it "should work with an empty input" do-            [hsx||] `shouldBeHtml` ""+            [hsx||] `shouldBeSameHtml` ""          it "should support multiple root nodes" do-            [hsx|<u>underlined</u><i>italic</i>|] `shouldBeHtml` "<u>underlined</u><i>italic</i>"+            [hsx|<u>underlined</u><i>italic</i>|] `shouldBeSameHtml` "<u>underlined</u><i>italic</i>"          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|<h1>Project: {project.name}</h1>|] `shouldBeHtml` "<h1>Project: Testproject</h1>"+            [hsx|<h1>Project: {project.name}</h1>|] `shouldBeSameHtml` "<h1>Project: Testproject</h1>"          it "should support lambdas and pattern matching on constructors" do             let placeData = PlaceId "Punches Cross"-            [hsx|<h1>{(\(PlaceId x) -> x)(placeData)}</h1>|] `shouldBeHtml` "<h1>Punches Cross</h1>"+            [hsx|<h1>{(\(PlaceId x) -> x)(placeData)}</h1>|] `shouldBeSameHtml` "<h1>Punches Cross</h1>"          it "should support infix notation for standard constructors e.g. (:):" do-            [hsx| <h1>{show $ (:) 1  [2,3,42]}</h1> |] `shouldBeHtml` "<h1>[1,2,3,42]</h1>"+            [hsx| <h1>{show $ (:) 1  [2,3,42]}</h1> |] `shouldBeSameHtml` "<h1>[1,2,3,42]</h1>"          it "should support infix notation for standard constructors e.g. (,):" do-            [hsx|<h1>{((,) 1 2)}</h1>|] `shouldBeHtml` "<h1>(1,2)</h1>"+            [hsx|<h1>{show $ ((,) 1 2)}</h1>|] `shouldBeSameHtml` "<h1>(1,2)</h1>"          it "should support self closing tags" do-            [hsx|<input>|] `shouldBeHtml` "<input>"-            [hsx|<br><br/>|] `shouldBeHtml` "<br><br>"+            [hsx|<input>|] `shouldBeSameHtml` "<input>"+            [hsx|<br><br/>|] `shouldBeSameHtml` "<br><br>"          it "should support boolean attributes" do-            [hsx|<input disabled>|] `shouldBeHtml` "<input disabled=\"disabled\">"-            [hsx|<input disabled={True}>|] `shouldBeHtml` "<input disabled=\"disabled\">"-            [hsx|<input disabled={False}>|] `shouldBeHtml` "<input>"+            [hsx|<input disabled>|] `shouldBeSameHtml` "<input disabled=\"disabled\">"+            [hsx|<input disabled={True}>|] `shouldBeSameHtml` "<input disabled=\"disabled\">"+            [hsx|<input disabled={False}>|] `shouldBeSameHtml` "<input>"          it "should correctly output True and False values in data attributes" do-            [hsx|<form data-disabled-javascript-submission></form>|] `shouldBeHtml` "<form data-disabled-javascript-submission=\"true\"></form>"-            [hsx|<form data-disabled-javascript-submission={True}></form>|] `shouldBeHtml` "<form data-disabled-javascript-submission=\"true\"></form>"-            [hsx|<form data-disabled-javascript-submission={False}></form>|] `shouldBeHtml` "<form data-disabled-javascript-submission=\"false\"></form>"+            [hsx|<form data-disabled-javascript-submission></form>|] `shouldBeSameHtml` "<form data-disabled-javascript-submission=\"true\"></form>"+            [hsx|<form data-disabled-javascript-submission={True}></form>|] `shouldBeSameHtml` "<form data-disabled-javascript-submission=\"true\"></form>"+            [hsx|<form data-disabled-javascript-submission={False}></form>|] `shouldBeSameHtml` "<form data-disabled-javascript-submission=\"false\"></form>"          it "should work with inline JS" do-            [hsx|<script>var a = { hello: true }; alert('hello world');</script>|] `shouldBeHtml` "<script>var a = { hello: true }; alert('hello world');</script>"-            [hsx|<script>{haskellCodeNotWorkingHere}</script>|] `shouldBeHtml` "<script>{haskellCodeNotWorkingHere}</script>"+            [hsx|<script>var a = { hello: true }; alert('hello world');</script>|] `shouldBeSameHtml` "<script>var a = { hello: true }; alert('hello world');</script>"+            [hsx|<script>{haskellCodeNotWorkingHere}</script>|] `shouldBeSameHtml` "<script>{haskellCodeNotWorkingHere}</script>"          it "should work with inline CSS" do-            [hsx|<style>.blue { background: blue; }</style>|] `shouldBeHtml` "<style>.blue { background: blue; }</style>"-            [hsx|<style>{haskellCodeNotWorkingHere}</style>|] `shouldBeHtml` "<style>{haskellCodeNotWorkingHere}</style>"+            [hsx|<style>.blue { background: blue; }</style>|] `shouldBeSameHtml` "<style>.blue { background: blue; }</style>"+            [hsx|<style>{haskellCodeNotWorkingHere}</style>|] `shouldBeSameHtml` "<style>{haskellCodeNotWorkingHere}</style>"          it "should strip whitespace around script tags" do             [hsx|                 <script>                     var apiKey = document.currentScript.dataset.apiKey;                 </script>-            |] `shouldBeHtml` "<script>var apiKey = document.currentScript.dataset.apiKey;</script>"+            |] `shouldBeSameHtml` "<script>var apiKey = document.currentScript.dataset.apiKey;</script>"          it "should strip whitespace around text nodes" do-            [hsx| <strong> Hello World </strong> |] `shouldBeHtml` "<strong>Hello World</strong>"-            [hsx|<i> a</i>|] `shouldBeHtml` "<i>a</i>"-            [hsx|<i> a b</i>|] `shouldBeHtml` "<i>a b</i>"-            [hsx|<i> a b c </i>|] `shouldBeHtml` "<i>a b c</i>"+            [hsx| <strong> Hello World </strong> |] `shouldBeSameHtml` "<strong>Hello World</strong>"+            [hsx|<i> a</i>|] `shouldBeSameHtml` "<i>a</i>"+            [hsx|<i> a b</i>|] `shouldBeSameHtml` "<i>a b</i>"+            [hsx|<i> a b c </i>|] `shouldBeSameHtml` "<i>a b c</i>"          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| <strong> Hello {name} ! </strong> |] `shouldBeHtml` "<strong>Hello Tester !</strong>"-            [hsx| <strong> Hello {name}{name} ! </strong> |] `shouldBeHtml` "<strong>Hello TesterTester !</strong>"-            [hsx| <strong> Hello {name} {name} ! </strong> |] `shouldBeHtml` "<strong>Hello Tester Tester !</strong>"-            [hsx|{name}|] `shouldBeHtml` "Tester"+            [hsx| <strong> Hello {name} ! </strong> |] `shouldBeSameHtml` "<strong>Hello Tester !</strong>"+            [hsx| <strong> Hello {name}{name} ! </strong> |] `shouldBeSameHtml` "<strong>Hello TesterTester !</strong>"+            [hsx| <strong> Hello {name} {name} ! </strong> |] `shouldBeSameHtml` "<strong>Hello Tester Tester !</strong>"+            [hsx|{name}|] `shouldBeSameHtml` "Tester"              let question :: Text = "Q"             let answer :: Text = "A"-            [hsx|<td>{question} → {answer}</td>|] `shouldBeHtml` "<td>Q → A</td>"+            [hsx|<td>{question} → {answer}</td>|] `shouldBeSameHtml` "<td>Q → A</td>"          it "should work with html comments" do-            [hsx|<div><!--my comment--></div>|] `shouldBeHtml` "<div><!-- my comment --></div>"+            [Blaze.hsx|<div><!--my comment--></div>|] `shouldBeBlazeHtml` "<div><!-- my comment --></div>"+            [Lucid2.hsx|<div><!--my comment--></div>|] `shouldBeLucid2Html` "<div><!--my comment--></div>"          it "should work with no render comments" do-            [hsx|<div>{- my comment -}</div>|] `shouldBeHtml` "<div></div>"+            [hsx|<div>{- my comment -}</div>|] `shouldBeSameHtml` "<div></div>"          it "should escape variables to avoid XSS" do             let variableContent :: Text = "<script>alert(1);</script>"-            [hsx|{variableContent}|] `shouldBeHtml` "&lt;script&gt;alert(1);&lt;/script&gt;"+            [hsx|{variableContent}|] `shouldBeSameHtml` "&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>"+            [hsx|<confetti-effect></confetti-effect>|] `shouldBeSameHtml` "<confetti-effect></confetti-effect>"+            [hsx|<confetti-effect/>|] `shouldBeSameHtml` "<confetti-effect></confetti-effect>" -- Currently we cannot deal with self closing tags as expected+            [hsx|<div is="confetti-effect"></div>|] `shouldBeSameHtml` "<div is=\"confetti-effect\"></div>"          it "should parse a small hsx document" do             let metaTags = [hsx|@@ -135,13 +142,13 @@                         <title>IHP Forum</title>                     </head>                 </html>-            |] `shouldBeHtml` "<html><head><meta charset=\"utf-8\"> <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"><link rel=\"stylesheet\" href=\"/vendor/flatpickr.min.css\"><link rel=\"stylesheet\" href=\"/app.css\"> <script src=\"/prod.js\"></script><title>IHP Forum</title></head></html>"+            |] `shouldBeSameHtml` "<html><head><meta charset=\"utf-8\"> <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"><link rel=\"stylesheet\" href=\"/vendor/flatpickr.min.css\"><link rel=\"stylesheet\" href=\"/app.css\"> <script src=\"/prod.js\"></script><title>IHP Forum</title></head></html>"          it "should parse an example hsx document" do             let metaTags = [hsx|                 <meta charset="utf-8">             |]-            metaTags `shouldBeHtml` "<meta charset=\"utf-8\">"+            metaTags `shouldBeSameHtml` "<meta charset=\"utf-8\">"             let stylesheets = [hsx|                 <link rel="stylesheet" href="/vendor/bootstrap.min.css"/>                 <link rel="stylesheet" href="/vendor/flatpickr.min.css"/>@@ -168,44 +175,67 @@                         </div>                     </body>                 </html>-            |] `shouldBeHtml` "<html><head><meta charset=\"utf-8\"> <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"><link rel=\"stylesheet\" href=\"/vendor/flatpickr.min.css\"><link rel=\"stylesheet\" href=\"/app.css\"> <script src=\"/prod.js\"></script><title>IHP Forum</title></head><body><div class=\"container mt-4\"><nav class=\"navbar navbar-expand-lg navbar-light mb-4\"><a class=\"navbar-brand\" href=\"/\">\955 IHP Forum</a></nav></div></body></html>"+            |] `shouldBeSameHtml` "<html><head><meta charset=\"utf-8\"> <link rel=\"stylesheet\" href=\"/vendor/bootstrap.min.css\"><link rel=\"stylesheet\" href=\"/vendor/flatpickr.min.css\"><link rel=\"stylesheet\" href=\"/app.css\"> <script src=\"/prod.js\"></script><title>IHP Forum</title></head><body><div class=\"container mt-4\"><nav class=\"navbar navbar-expand-lg navbar-light mb-4\"><a class=\"navbar-brand\" href=\"/\">\955 IHP Forum</a></nav></div></body></html>"          it "should handle spread attributes with a variable" do             let customAttributes :: [(Text, Text)] = [                     ("hello", "world")                     ]-            [hsx|<div {...customAttributes}></div>|] `shouldBeHtml` "<div hello=\"world\"></div>"+            [hsx|<div {...customAttributes}></div>|] `shouldBeSameHtml` "<div hello=\"world\"></div>"          it "should handle spread attributes with a list" do             -- See https://github.com/digitallyinduced/ihp/issues/1226 -            [hsx|<div {...[ ("data-hoge" :: Text, "Hello World!" :: Text) ]}></div>|] `shouldBeHtml` "<div data-hoge=\"Hello World!\"></div>"+            [hsx|<div {...[ ("data-hoge" :: Text, "Hello World!" :: Text) ]}></div>|] `shouldBeSameHtml` "<div data-hoge=\"Hello World!\"></div>" -        it "should support pre escaped class names" do+        it "should support pre escaped class names for Blaze" do             -- See https://github.com/digitallyinduced/ihp/issues/1527              let className = preEscapedTextValue "a&"-            [hsx|<div class={className}></div>|] `shouldBeHtml` "<div class=\"a&\"></div>"+            [Blaze.hsx|<div class={className}></div>|] `shouldBeBlazeHtml` "<div class=\"a&\"></div>" +        it "should support pre escaped class names for Lucid2" do+            -- See https://github.com/digitallyinduced/ihp/issues/1527++            let className = Lucid2.MkLucidAttributeRaw "a&"+            [Lucid2.hsx|<div class={className}></div>|] `shouldBeLucid2Html` "<div class=\"a&\"></div>"+         it "should support support doctype" do             -- See https://github.com/digitallyinduced/ihp/issues/1717 -            [hsx|<!DOCTYPE html><html lang="en"><body>hello</body></html>|] `shouldBeHtml` "<!DOCTYPE HTML>\n<html lang=\"en\"><body>hello</body></html>"+            [Blaze.hsx|<!DOCTYPE html><html lang="en"><body>hello</body></html>|] `shouldBeBlazeHtml` "<!DOCTYPE HTML>\n<html lang=\"en\"><body>hello</body></html>"+            [Lucid2.hsx|<!DOCTYPE html><html lang="en"><body>hello</body></html>|] `shouldBeLucid2Html` "<!DOCTYPE HTML><html lang=\"en\"><body>hello</body></html>" +        it "should support non-Identity effects for Lucid2" do+            let increment :: State Int String = do+                  x <- get+                  put $! (x + 1)+                  pure $! show x+                monadFragment :: Lucid2.HtmlT (State Int) ()+                monadFragment = [Lucid2.hsxM|<div>{increment}</div><div>{increment}</div><div>{increment}</div>|]+                textFragment :: TL.Text+                textFragment = evalState (Lucid2.renderTextT monadFragment) 1+                insertMonadFragment :: Lucid2.HtmlT (State Int) ()+                insertMonadFragment = [Lucid2.hsxM|<div>{monadFragment}</div><div>{monadFragment}</div>|]+                doubleTextFragment :: TL.Text+                doubleTextFragment = evalState (Lucid2.renderTextT insertMonadFragment) 1+            textFragment `shouldBe` "<div>1</div><div>2</div><div>3</div>"+            doubleTextFragment `shouldBe` "<div><div>1</div><div>2</div><div>3</div></div><div><div>4</div><div>5</div><div>6</div></div>"+     describe "customHsx" do         it "should allow specified custom tags" do-            [myTagsOnlyHsx|<mycustomtag>hello</mycustomtag>|] `shouldBeHtml` "<mycustomtag>hello</mycustomtag>"-            [myTagsOnlyHsx|<anothercustomtag>world</anothercustomtag>|] `shouldBeHtml` "<anothercustomtag>world</anothercustomtag>"+            [myTagsOnlyHsx|<mycustomtag>hello</mycustomtag>|] `shouldBeSameHtml` "<mycustomtag>hello</mycustomtag>"+            [myTagsOnlyHsx|<anothercustomtag>world</anothercustomtag>|] `shouldBeSameHtml` "<anothercustomtag>world</anothercustomtag>"          it "should allow specified custom attributes" do-            [myAttrsOnlyHsx|<div my-custom-attr="hello">test</div>|] `shouldBeHtml` "<div my-custom-attr=\"hello\">test</div>"-            [myAttrsOnlyHsx|<div anothercustomattr="world">test</div>|] `shouldBeHtml` "<div anothercustomattr=\"world\">test</div>"+            [myAttrsOnlyHsx|<div my-custom-attr="hello">test</div>|] `shouldBeSameHtml` "<div my-custom-attr=\"hello\">test</div>"+            [myAttrsOnlyHsx|<div anothercustomattr="world">test</div>|] `shouldBeSameHtml` "<div anothercustomattr=\"world\">test</div>"          it "should allow combining custom tags and attributes" do-            [myCustomHsx|<mycustomtag my-custom-attr="hello">test</mycustomtag>|] `shouldBeHtml` "<mycustomtag my-custom-attr=\"hello\">test</mycustomtag>"+            [myCustomHsx|<mycustomtag my-custom-attr="hello">test</mycustomtag>|] `shouldBeSameHtml` "<mycustomtag my-custom-attr=\"hello\">test</mycustomtag>"          it "should work with regular HTML tags and attributes too" do-           [myCustomHsx|<div class="hello" my-custom-attr="test">world</div>|] `shouldBeHtml` "<div class=\"hello\" my-custom-attr=\"test\">world</div>"+           [myCustomHsx|<div class="hello" my-custom-attr="test">world</div>|] `shouldBeSameHtml` "<div class=\"hello\" my-custom-attr=\"test\">world</div>"  data Project = Project { name :: Text } @@ -216,6 +246,16 @@ newPlaceData = NewPlaceId "New Punches Cross" locationId = LocationId 17 (PlaceId "Punches Cross") +shouldBeSameHtml :: HasCallStack => AllBackends -> TL.Text -> Expectation+shouldBeSameHtml MkAllBackends {..} expectedHtml = do+  Blaze.renderMarkup blazeMarkup `shouldBe` expectedHtml+  Lucid2.renderText lucid2Html `shouldBe` expectedHtml+  Lucid2.renderText lucid2HtmlM `shouldBe` expectedHtml +shouldBeBlazeHtml :: HasCallStack => Blaze.Markup -> TL.Text -> Expectation+shouldBeBlazeHtml blazeMarkup expectedHtml =+  Blaze.renderMarkup blazeMarkup `shouldBe` expectedHtml -shouldBeHtml hsx expectedHtml = (Blaze.renderMarkup hsx) `shouldBe` expectedHtml+shouldBeLucid2Html :: HasCallStack => Lucid2.Html () -> TL.Text -> Expectation+shouldBeLucid2Html lucid2Html expectedHtml =+  Lucid2.renderText lucid2Html `shouldBe` expectedHtml
Test/Main.hs view
+ blaze/IHP/HSX/Attribute.hs view
@@ -0,0 +1,43 @@+{-# 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 <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes+    applyAttribute attr attr' false h | "data-" `Text.isPrefixOf` attr = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') "false") -- data attribute set to "false"+    applyAttribute attr attr' false h = h -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false+    {-# INLINE applyAttribute #-}++instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where+    applyAttribute attr attr' (Just value) h = applyAttribute attr attr' value h+    applyAttribute attr attr' Nothing h = h+    {-# INLINE applyAttribute #-}++instance ApplyAttribute Html5.AttributeValue where+    applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value)+    {-# INLINE applyAttribute #-}++instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where+    applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h+    {-# INLINE applyAttribute #-}
+ blaze/IHP/HSX/ConvertibleStrings.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module IHP.HSX.ConvertibleStrings where++import Prelude+import Data.String.Conversions (ConvertibleStrings (convertString), cs)+import Text.Blaze.Html5+import Data.Text+import Data.ByteString+import qualified Text.Blaze.Html5        as Html5+import qualified Data.ByteString.Lazy as LBS++instance ConvertibleStrings String Html5.AttributeValue where+    {-# INLINE convertString #-}+    convertString = stringValue++instance ConvertibleStrings Text Html5.AttributeValue where+    {-# INLINE convertString #-}+    convertString = Html5.textValue++instance ConvertibleStrings String Html5.Html where+    {-# INLINE convertString #-}+    convertString = Html5.string++instance ConvertibleStrings ByteString Html5.AttributeValue where+    {-# INLINE convertString #-}+    convertString value = convertString (cs value :: Text)++instance ConvertibleStrings LBS.ByteString Html5.AttributeValue where+    {-# INLINE convertString #-}+    convertString value = convertString (cs value :: Text)++instance ConvertibleStrings Text Html5.Html where+    {-# INLINE convertString #-}+    convertString = Html5.text
+ blaze/IHP/HSX/QQ.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, BangPatterns, PackageImports, FlexibleInstances, OverloadedStrings #-}++{-|+Module: IHP.HSX.QQ+Description: Defines the @[hsx||]@ syntax+Copyright: (c) digitally induced GmbH, 2022+-}+module IHP.HSX.QQ+  ( hsx+  , uncheckedHsx+  , customHsx+  , quoteHsxExpression+  ) where++import           Prelude+import Data.Text (Text)+import           IHP.HSX.Parser+import qualified "template-haskell" Language.Haskell.TH           as TH+import qualified "template-haskell" Language.Haskell.TH.Syntax           as TH+import           Language.Haskell.TH.Quote+import           Text.Blaze.Html5              ((!))+import qualified Text.Blaze.Html5              as Html5+import Text.Blaze.Html (Html)+import Text.Blaze.Internal (attribute, MarkupM (Parent, Leaf), StaticString (..))+import Data.String.Conversions+import IHP.HSX.ToHtml+import qualified Text.Megaparsec as Megaparsec+import qualified Text.Blaze.Html.Renderer.String as BlazeString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+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 = customHsx +        (HsxSettings +            { checkMarkup = True+            , additionalTagNames = Set.empty+            , additionalAttributeNames = Set.empty+            }+        )++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 settings hsxPosition extensions (cs code) of+                Left error   -> fail (Megaparsec.errorBundlePretty error)+                Right result -> pure result+        compileToHaskell expression+    where++        findHSXPosition = do+            loc <- TH.location+            let (line, col) = TH.loc_start loc+            pure $ Megaparsec.SourcePos (TH.loc_filename loc) (Megaparsec.mkPos line) (Megaparsec.mkPos col)++compileToHaskell :: Node -> TH.ExpQ+compileToHaskell (Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True) = [| Html5.docType |]+compileToHaskell (Node name attributes children isLeaf) =+    let+        renderedChildren = TH.listE $ map compileToHaskell children+        stringAttributes = TH.listE $ map toStringAttribute attributes+    in+        if isLeaf+            then+                let+                    element = nodeToBlazeLeaf name+                in+                    [| applyAttributes $element $stringAttributes |]+            else+                let+                    element = nodeToBlazeElement name+                in [| applyAttributes ($element (mconcat $renderedChildren)) $stringAttributes |]+compileToHaskell (Children children) =+    let+        renderedChildren = TH.listE $ map compileToHaskell children+    in [| mconcat $(renderedChildren) |]++compileToHaskell (TextNode value) = [| Html5.preEscapedText value |]+compileToHaskell (PreEscapedTextNode value) = [| Html5.preEscapedText value |]+compileToHaskell (SplicedNode expression) = [| toHtml $(pure expression) |]+compileToHaskell (CommentNode value) = [| Html5.textComment value |]+compileToHaskell (NoRenderCommentNode) = [| mempty |]++nodeToBlazeElement :: Text -> TH.Q TH.Exp+nodeToBlazeElement name =+    HashMap.findWithDefault (nodeToBlazeElementGeneric name) name knownElements++knownElements :: HashMap.HashMap Text TH.ExpQ+knownElements =+    HashMap.fromList+        [ ("a", [| Html5.a |])+        , ("abbr", [| Html5.abbr |])+        , ("address", [| Html5.address |])+        , ("article", [| Html5.article |])+        , ("aside", [| Html5.aside |])+        , ("audio", [| Html5.audio |])+        , ("b", [| Html5.b |])+        , ("blockquote", [| Html5.blockquote |])+        , ("body", [| Html5.body |])+        , ("button", [| Html5.button |])+        , ("canvas", [| Html5.canvas |])+        , ("caption", [| Html5.caption |])+        , ("cite", [| Html5.cite |])+        , ("code", [| Html5.code |])+        , ("colgroup", [| Html5.colgroup |])+        , ("datalist", [| Html5.datalist |])+        , ("dd", [| Html5.dd |])+        , ("del", [| Html5.del |])+        , ("details", [| Html5.details |])+        , ("dfn", [| Html5.dfn |])+        , ("div", [| Html5.div |])+        , ("dl", [| Html5.dl |])+        , ("dt", [| Html5.dt |])+        , ("em", [| Html5.em |])+        , ("fieldset", [| Html5.fieldset |])+        , ("figcaption", [| Html5.figcaption |])+        , ("figure", [| Html5.figure |])+        , ("footer", [| Html5.footer |])+        , ("form", [| Html5.form |])+        , ("h1", [| Html5.h1 |])+        , ("h2", [| Html5.h2 |])+        , ("h3", [| Html5.h3 |])+        , ("h4", [| Html5.h4 |])+        , ("h5", [| Html5.h5 |])+        , ("h6", [| Html5.h6 |])+        , ("head", [| Html5.head |])+        , ("header", [| Html5.header |])+        , ("hgroup", [| Html5.hgroup |])+        , ("html", [| Html5.html |])+        , ("i", [| Html5.i |])+        , ("iframe", [| Html5.iframe |])+        , ("ins", [| Html5.ins |])+        , ("kbd", [| Html5.kbd |])+        , ("label", [| Html5.label |])+        , ("legend", [| Html5.legend |])+        , ("li", [| Html5.li |])+        , ("main", [| Html5.main |])+        , ("map", [| Html5.map |])+        , ("mark", [| Html5.mark |])+        , ("menu", [| Html5.menu |])+        , ("menuitem", [| Html5.menuitem |])+        , ("meter", [| Html5.meter |])+        , ("nav", [| Html5.nav |])+        , ("noscript", [| Html5.noscript |])+        , ("object", [| Html5.object |])+        , ("ol", [| Html5.ol |])+        , ("optgroup", [| Html5.optgroup |])+        , ("option", [| Html5.option |])+        , ("output", [| Html5.output |])+        , ("p", [| Html5.p |])+        , ("pre", [| Html5.pre |])+        , ("progress", [| Html5.progress |])+        , ("q", [| Html5.q |])+        , ("rp", [| Html5.rp |])+        , ("rt", [| Html5.rt |])+        , ("ruby", [| Html5.ruby |])+        , ("s", [| Html5.s |])+        , ("samp", [| Html5.samp |])+        , ("script", [| Html5.script |])+        , ("section", [| Html5.section |])+        , ("select", [| Html5.select |])+        , ("small", [| Html5.small |])+        , ("span", [| Html5.span |])+        , ("strong", [| Html5.strong |])+        , ("style", [| Html5.style |])+        , ("sub", [| Html5.sub |])+        , ("summary", [| Html5.summary |])+        , ("sup", [| Html5.sup |])+        , ("table", [| Html5.table |])+        , ("tbody", [| Html5.tbody |])+        , ("td", [| Html5.td |])+        , ("textarea", [| Html5.textarea |])+        , ("tfoot", [| Html5.tfoot |])+        , ("th", [| Html5.th |])+        , ("thead", [| Html5.thead |])+        , ("time", [| Html5.time |])+        , ("title", [| Html5.title |])+        , ("tr", [| Html5.tr |])+        , ("u", [| Html5.u |])+        , ("ul", [| Html5.ul |])+        , ("var", [| Html5.var |])+        , ("video", [| Html5.video |])+        ]++nodeToBlazeLeaf :: Text -> TH.Q TH.Exp+nodeToBlazeLeaf name =+    HashMap.findWithDefault (nodeToBlazeLeafGeneric name) name knownLeafs++knownLeafs :: HashMap.HashMap Text TH.ExpQ+knownLeafs =+    HashMap.fromList+        [ ("area", [| Html5.area |])+        , ("base", [| Html5.base |])+        , ("br", [| Html5.br |])+        , ("col", [| Html5.col |])+        , ("embed", [| Html5.embed |])+        , ("hr", [| Html5.hr |])+        , ("img", [| Html5.img |])+        , ("input", [| Html5.input |])+        , ("keygen", [| Html5.keygen |])+        , ("link", [| Html5.link |])+        , ("meta", [| Html5.meta |])+        , ("param", [| Html5.param |])+        , ("source", [| Html5.source |])+        , ("track", [| Html5.track |])+        , ("wbr", [| Html5.wbr |])+        ]++nodeToBlazeElementGeneric :: Text -> TH.Q TH.Exp+nodeToBlazeElementGeneric name =+    let+        openTag :: Text+        openTag = "<" <> tag+        +        tag :: Text+        tag = cs name++        closeTag :: Text+        closeTag = "</" <> tag <> ">"+    in+        [| makeParent (textToStaticString $(TH.lift name)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) |]++nodeToBlazeLeafGeneric :: Text -> TH.Q TH.Exp+nodeToBlazeLeafGeneric name =+    let+        openTag :: Text+        openTag = "<" <> tag++        closeTag :: Text+        closeTag = ">"+        +        tag :: Text+        tag = cs name+    in+        [| (Leaf (textToStaticString $(TH.lift tag)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) ()) |]++toStringAttribute :: Attribute -> TH.ExpQ+toStringAttribute (StaticAttribute name (TextValue value)) =+    attributeFromName name value++toStringAttribute (StaticAttribute name (ExpressionValue expression)) = let nameWithSuffix = " " <> name <> "=\"" in [| applyAttribute name nameWithSuffix $(pure expression) |]+toStringAttribute (SpreadAttributes expression) = [| spreadAttributes $(pure expression) |]++attributeFromName :: Text -> Text -> TH.ExpQ+attributeFromName name value =+    let+        value' :: TH.ExpQ+        value' = if Text.null value then [| mempty |] else [| Html5.preEscapedTextValue value |] ++        attr = attributeFromName' name+    in+        [| (! $attr $value') |]++attributeFromName' :: Text -> TH.ExpQ+attributeFromName' name =+    HashMap.findWithDefault (attributeFromNameGeneric name) name knownAttributes++knownAttributes :: HashMap.HashMap Text TH.ExpQ+knownAttributes =+    HashMap.fromList+        [ ("accept", [| Attributes.accept |])+        , ( "accept-charset", [| Attributes.acceptCharset |])+        , ( "accesskey", [| Attributes.accesskey |])+        , ( "action", [| Attributes.action |])+        , ( "alt", [| Attributes.alt |])+        , ( "async", [| Attributes.async |])+        , ( "autocomplete", [| Attributes.autocomplete |])+        , ( "autofocus", [| Attributes.autofocus |])+        , ( "autoplay", [| Attributes.autoplay |])+        , ( "challenge", [| Attributes.challenge |])+        , ( "charset", [| Attributes.charset |])+        , ( "checked", [| Attributes.checked |])+        , ( "cite", [| Attributes.cite |])+        , ( "class", [| Attributes.class_ |])+        , ( "cols", [| Attributes.cols |])+        , ( "colspan", [| Attributes.colspan |])+        , ( "content", [| Attributes.content |])+        , ( "contenteditable", [| Attributes.contenteditable |])+        , ( "contextmenu", [| Attributes.contextmenu |])+        , ( "controls", [| Attributes.controls |])+        , ( "coords", [| Attributes.coords |])+        , ( "data", [| Attributes.data_ |])+        , ( "datetime", [| Attributes.datetime |])+        , ( "defer", [| Attributes.defer |])+        , ( "dir", [| Attributes.dir |])+        , ( "disabled", [| Attributes.disabled |])+        , ( "download", [| Attributes.download |])+        , ( "draggable", [| Attributes.draggable |])+        , ( "enctype", [| Attributes.enctype |])+        , ( "for", [| Attributes.for |])+        , ( "form", [| Attributes.form |])+        , ( "formaction", [| Attributes.formaction |])+        , ( "formenctype", [| Attributes.formenctype |])+        , ( "formmethod", [| Attributes.formmethod |])+        , ( "formnovalidate", [| Attributes.formnovalidate |])+        , ( "formtarget", [| Attributes.formtarget |])+        , ( "headers", [| Attributes.headers |])+        , ( "height", [| Attributes.height |])+        , ( "hidden", [| Attributes.hidden |])+        , ( "high", [| Attributes.high |])+        , ( "href", [| Attributes.href |])+        , ( "hreflang", [| Attributes.hreflang |])+        , ( "http-equiv", [| Attributes.httpEquiv |])+        , ( "icon", [| Attributes.icon |])+        , ( "id", [| Attributes.id |])+        , ( "ismap", [| Attributes.ismap |])+        , ( "item", [| Attributes.item |])+        , ( "itemprop", [| Attributes.itemprop |])+        , ( "itemscope", [| Attributes.itemscope |])+        , ( "itemtype", [| Attributes.itemtype |])+        , ( "keytype", [| Attributes.keytype |])+        , ( "label", [| Attributes.label |])+        , ( "lang", [| Attributes.lang |])+        , ( "list", [| Attributes.list |])+        , ( "loop", [| Attributes.loop |])+        , ( "low", [| Attributes.low |])+        , ( "manifest", [| Attributes.manifest |])+        , ( "max", [| Attributes.max |])+        , ( "maxlength", [| Attributes.maxlength |])+        , ( "media", [| Attributes.media |])+        , ( "method", [| Attributes.method |])+        , ( "min", [| Attributes.min |])+        , ( "minlength", [| Attributes.minlength |])+        , ( "multiple", [| Attributes.multiple |])+        , ( "muted", [| Attributes.muted |])+        , ( "name", [| Attributes.name |])+        , ( "novalidate", [| Attributes.novalidate |])+        , ( "onbeforeonload", [| Attributes.onbeforeonload |])+        , ( "onbeforeprint", [| Attributes.onbeforeprint |])+        , ( "onblur", [| Attributes.onblur |])+        , ( "oncanplay", [| Attributes.oncanplay |])+        , ( "oncanplaythrough", [| Attributes.oncanplaythrough |])+        , ( "onchange", [| Attributes.onchange |])+        , ( "onclick", [| Attributes.onclick |])+        , ( "oncontextmenu", [| Attributes.oncontextmenu |])+        , ( "ondblclick", [| Attributes.ondblclick |])+        , ( "ondrag", [| Attributes.ondrag |])+        , ( "ondragend", [| Attributes.ondragend |])+        , ( "ondragenter", [| Attributes.ondragenter |])+        , ( "ondragleave", [| Attributes.ondragleave |])+        , ( "ondragover", [| Attributes.ondragover |])+        , ( "ondragstart", [| Attributes.ondragstart |])+        , ( "ondrop", [| Attributes.ondrop |])+        , ( "ondurationchange", [| Attributes.ondurationchange |])+        , ( "onemptied", [| Attributes.onemptied |])+        , ( "onended", [| Attributes.onended |])+        , ( "onerror", [| Attributes.onerror |])+        , ( "onfocus", [| Attributes.onfocus |])+        , ( "onformchange", [| Attributes.onformchange |])+        , ( "onforminput", [| Attributes.onforminput |])+        , ( "onhaschange", [| Attributes.onhaschange |])+        , ( "oninput", [| Attributes.oninput |])+        , ( "oninvalid", [| Attributes.oninvalid |])+        , ( "onkeydown", [| Attributes.onkeydown |])+        , ( "onkeypress", [| Attributes.onkeypress |])+        , ( "onkeyup", [| Attributes.onkeyup |])+        , ( "onload", [| Attributes.onload |])+        , ( "onloadeddata", [| Attributes.onloadeddata |])+        , ( "onloadedmetadata", [| Attributes.onloadedmetadata |])+        , ( "onloadstart", [| Attributes.onloadstart |])+        , ( "onmessage", [| Attributes.onmessage |])+        , ( "onmousedown", [| Attributes.onmousedown |])+        , ( "onmousemove", [| Attributes.onmousemove |])+        , ( "onmouseout", [| Attributes.onmouseout |])+        , ( "onmouseover", [| Attributes.onmouseover |])+        , ( "onmouseup", [| Attributes.onmouseup |])+        , ( "onmousewheel", [| Attributes.onmousewheel |])+        , ( "ononline", [| Attributes.ononline |])+        , ( "onpagehide", [| Attributes.onpagehide |])+        , ( "onpageshow", [| Attributes.onpageshow |])+        , ( "onpause", [| Attributes.onpause |])+        , ( "onplay", [| Attributes.onplay |])+        , ( "onplaying", [| Attributes.onplaying |])+        , ( "onprogress", [| Attributes.onprogress |])+        , ( "onpropstate", [| Attributes.onpropstate |])+        , ( "onratechange", [| Attributes.onratechange |])+        , ( "onreadystatechange", [| Attributes.onreadystatechange |])+        , ( "onredo", [| Attributes.onredo |])+        , ( "onresize", [| Attributes.onresize |])+        , ( "onscroll", [| Attributes.onscroll |])+        , ( "onseeked", [| Attributes.onseeked |])+        , ( "onseeking", [| Attributes.onseeking |])+        , ( "onselect", [| Attributes.onselect |])+        , ( "onstalled", [| Attributes.onstalled |])+        , ( "onstorage", [| Attributes.onstorage |])+        , ( "onsubmit", [| Attributes.onsubmit |])+        , ( "onsuspend", [| Attributes.onsuspend |])+        , ( "ontimeupdate", [| Attributes.ontimeupdate |])+        , ( "onundo", [| Attributes.onundo |])+        , ( "onunload", [| Attributes.onunload |])+        , ( "onvolumechange", [| Attributes.onvolumechange |])+        , ( "onwaiting", [| Attributes.onwaiting |])+        , ( "open", [| Attributes.open |])+        , ( "optimum", [| Attributes.optimum |])+        , ( "pattern", [| Attributes.pattern |])+        , ( "ping", [| Attributes.ping |])+        , ( "placeholder", [| Attributes.placeholder |])+        , ( "poster", [| Attributes.poster |])+        , ( "preload", [| Attributes.preload |])+        , ( "property", [| Attributes.property |])+        , ( "pubdate", [| Attributes.pubdate |])+        , ( "radiogroup", [| Attributes.radiogroup |])+        , ( "readonly", [| Attributes.readonly |])+        , ( "rel", [| Attributes.rel |])+        , ( "required", [| Attributes.required |])+        , ( "reversed", [| Attributes.reversed |])+        , ( "role", [| Attributes.role |])+        , ( "rows", [| Attributes.rows |])+        , ( "rowspan", [| Attributes.rowspan |])+        , ( "sandbox", [| Attributes.sandbox |])+        , ( "scope", [| Attributes.scope |])+        , ( "scoped", [| Attributes.scoped |])+        , ( "seamless", [| Attributes.seamless |])+        , ( "selected", [| Attributes.selected |])+        , ( "shape", [| Attributes.shape |])+        , ( "size", [| Attributes.size |])+        , ( "sizes", [| Attributes.sizes |])+        , ( "span", [| Attributes.span |])+        , ( "spellcheck", [| Attributes.spellcheck |])+        , ( "src", [| Attributes.src |])+        , ( "srcdoc", [| Attributes.srcdoc |])+        , ( "start", [| Attributes.start |])+        , ( "step", [| Attributes.step |])+        , ( "style", [| Attributes.style |])+        , ( "subject", [| Attributes.subject |])+        , ( "summary", [| Attributes.summary |])+        , ( "tabindex", [| Attributes.tabindex |])+        , ( "target", [| Attributes.target |])+        , ( "title", [| Attributes.title |])+        , ( "type", [| Attributes.type_ |])+        , ( "usemap", [| Attributes.usemap |])+        , ( "value", [| Attributes.value |])+        , ( "width", [| Attributes.width |])+        , ( "wrap", [| Attributes.wrap |])+        , ( "xmlns", [| Attributes.xmlns |])+        ]++attributeFromNameGeneric :: Text -> TH.ExpQ+attributeFromNameGeneric name =+    let+        nameWithSuffix = " " <> name <> "=\""+    in+        [| attribute (Html5.textTag name) (Html5.textTag nameWithSuffix) |]++spreadAttributes :: ApplyAttribute value => [(Text, value)] -> Html5.Html -> Html5.Html+spreadAttributes attributes html = applyAttributes html $ map (\(name, value) -> applyAttribute name (" " <> name <> "=\"") value) attributes+{-# INLINE spreadAttributes #-}++applyAttributes :: Html5.Html -> [Html5.Html -> Html5.Html] -> Html5.Html+applyAttributes element (attribute:rest) = applyAttributes (attribute element) rest+applyAttributes element [] = element+{-# INLINE applyAttributes #-}++makeParent :: StaticString -> StaticString -> StaticString -> Html -> Html+makeParent tag openTag closeTag children = Parent tag openTag closeTag children+{-# INLINE makeParent #-}++textToStaticString :: Text -> StaticString+textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 text) text+{-# INLINE textToStaticString #-}++instance Show (MarkupM ()) where+    show html = BlazeString.renderHtml html
+ blaze/IHP/HSX/ToHtml.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE  UndecidableInstances #-}+{-# LANGUAGE  FlexibleInstances #-}++{-|+Module: IHP.HSX.ToHtml+Description: Provides a few helper instances that convert data structures to HTML+Copyright: (c) digitally induced GmbH, 2022+-}+module IHP.HSX.ToHtml where++import Prelude+import qualified Text.Blaze.Html5 as Html5+import qualified Text.Blaze.Internal+import Data.Text (Text)+import Data.ByteString+import Data.String.Conversions (cs)+import IHP.HSX.ConvertibleStrings ()++class ToHtml a where+    toHtml :: a -> Html5.Html++instance ToHtml (Text.Blaze.Internal.MarkupM ()) where+    {-# INLINE toHtml #-}+    toHtml a = a++instance ToHtml Text where+    {-# INLINE toHtml #-}+    toHtml = Html5.text++instance ToHtml String where+    {-# INLINE toHtml #-}+    toHtml = Html5.string++instance ToHtml ByteString where+    {-# INLINE toHtml #-}+    toHtml value = toHtml (cs value :: Text)++instance {-# OVERLAPPABLE #-} ToHtml a => ToHtml (Maybe a) where+    {-# INLINE toHtml #-}+    toHtml maybeValue = maybe mempty toHtml maybeValue++instance {-# OVERLAPPABLE #-} Show a => ToHtml a where+    {-# INLINE toHtml #-}+    toHtml value = Html5.string (show value)
changelog.md view
@@ -1,5 +1,11 @@ # Changelog for `ihp-hsx` +## Version 1.5.0++- Suport for GHC 9.10.x and 9.12.x+- Add backend for lucid2 via dedidcated ihp-hsx-lucid2 library+- Add missing attributes muted, onkeypress+ ## Versions < 0.18:  [See the IHP main upgrade instructions](https://github.com/digitallyinduced/ihp/blob/master/UPGRADE.md)
ihp-hsx.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                ihp-hsx-version:             1.4.1+version:             1.5.0 synopsis:            JSX-like but for Haskell description:         JSX-like templating syntax for Haskell license:             MIT@@ -16,20 +16,7 @@     type:     git     location: https://github.com/digitallyinduced/ihp.git -library-    default-language: Haskell2010-    build-depends:-          base >= 4.17.0 && < 4.20-        , blaze-html-        , bytestring-        , template-haskell >= 2.19.0 && < 2.22-        , text-        , containers-        , blaze-markup-        , ghc >= 9.4.4 && < 9.9-        , megaparsec-        , string-conversions-        , unordered-containers+common common-extensions     default-extensions:         OverloadedStrings         , NoImplicitPrelude@@ -64,6 +51,8 @@         , StandaloneDeriving         , TemplateHaskell         , OverloadedRecordDot++common common-flags     ghc-options:         -fstatic-argument-transformation         -funbox-strict-fields@@ -80,17 +69,66 @@         -fdicts-strict         -fexpose-all-unfoldings         -optc-O3-    hs-source-dirs: .++common common-depends+    build-depends:+          base >= 4.17.0 && < 4.22+        , bytestring+        , template-haskell >= 2.19.0 && < 2.24+        , text+        , containers+        , megaparsec+        , string-conversions+        , unordered-containers++library ihp-hsx-parser+    import: common-extensions, common-flags, common-depends+    default-language: Haskell2010+    build-depends:+        ghc >= 9.4.4 && < 9.13+    hs-source-dirs: parser     exposed-modules:         IHP.HSX.Parser-        , IHP.HSX.QQ+        , IHP.HSX.HaskellParser+        , IHP.HSX.HsExpToTH++library+    import: common-extensions, common-flags, common-depends+    build-depends:+        ihp-hsx-parser+        , blaze-html+        , blaze-markup+    default-language: Haskell2010+    hs-source-dirs: blaze+    exposed-modules:+        IHP.HSX.QQ         , IHP.HSX.ToHtml         , IHP.HSX.ConvertibleStrings+        , IHP.HSX.Attribute+    reexported-modules:+        IHP.HSX.Parser         , IHP.HSX.HaskellParser         , IHP.HSX.HsExpToTH-        , IHP.HSX.Attribute +library ihp-hsx-lucid2+    import: common-extensions, common-flags, common-depends+    build-depends:+        ihp-hsx-parser+        , lucid2+        , transformers+    default-language: Haskell2010+    hs-source-dirs: lucid2+    exposed-modules:+        IHP.HSX.Lucid2.QQ+        , IHP.HSX.Lucid2.Attribute+        , IHP.HSX.Lucid2.ToHtml+    reexported-modules:+        IHP.HSX.Parser+        , IHP.HSX.HaskellParser+        , IHP.HSX.HsExpToTH+ test-suite ihp-hsx-tests+    import: common-extensions, common-flags, common-depends     type:                exitcode-stdio-1.0     hs-source-dirs:      Test     main-is:             Main.hs@@ -100,46 +138,11 @@         IHP.HSX.CustomHsxCases     default-language:    Haskell2010     build-depends:-          base >= 4.17.0 && < 4.20         , ihp-hsx+        , ihp-hsx-lucid2         , hspec-        , text-        , bytestring-        , containers         , blaze-markup         , megaparsec         , template-haskell-    default-extensions:-        OverloadedStrings-        , NoImplicitPrelude-        , ImplicitParams-        , Rank2Types-        , NamedFieldPuns-        , TypeSynonymInstances-        , FlexibleInstances-        , DisambiguateRecordFields-        , DuplicateRecordFields-        , OverloadedLabels-        , FlexibleContexts-        , DataKinds-        , QuasiQuotes-        , TypeFamilies-        , PackageImports-        , ScopedTypeVariables-        , RecordWildCards-        , TypeApplications-        , DataKinds-        , InstanceSigs-        , DeriveGeneric-        , MultiParamTypeClasses-        , TypeOperators-        , DeriveDataTypeable-        , DefaultSignatures-        , BangPatterns-        , FunctionalDependencies-        , PartialTypeSignatures-        , BlockArguments-        , LambdaCase-        , StandaloneDeriving-        , TemplateHaskell-        , OverloadedRecordDot+        , lucid2+        , mtl
+ lucid2/IHP/HSX/Lucid2/Attribute.hs view
@@ -0,0 +1,42 @@+{-|+Module: IHP.HSX.Lucid2.Attribute+Copyright: (c) digitally induced GmbH, 2023+-}+module IHP.HSX.Lucid2.Attribute+  ( LucidAttributeRaw (..)+  , LucidAttributeValue (..)+  ) where++import Prelude+import qualified Data.Text as Text+import Data.Text (Text)+import Lucid.Base (Attributes, makeAttributes, makeAttributesRaw)++class LucidAttributeValue value where+    buildAttribute :: Text -> value -> Attributes++instance LucidAttributeValue Bool where+    buildAttribute attr True = makeAttributes attr value+        where+            value = if "data-" `Text.isPrefixOf` attr+                    then "true" -- "true" for data attributes+                    else attr -- normal html boolean attriubtes, like <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes+    buildAttribute attr False | "data-" `Text.isPrefixOf` attr = makeAttributesRaw attr "false" -- data attribute set to "false"+    buildAttribute attr False = mempty -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false+    {-# INLINE buildAttribute #-}++instance LucidAttributeValue lav => LucidAttributeValue (Maybe lav) where+    buildAttribute attr (Just value) = buildAttribute attr value+    buildAttribute attr Nothing = mempty+    {-# INLINE buildAttribute #-}++instance LucidAttributeValue Text where+    buildAttribute = makeAttributes+    {-# INLINE buildAttribute #-}++newtype LucidAttributeRaw = MkLucidAttributeRaw { unLucidAttributeRaw :: Text }++instance LucidAttributeValue LucidAttributeRaw where+    buildAttribute attr MkLucidAttributeRaw { unLucidAttributeRaw = textVal } =+      makeAttributesRaw attr textVal+    {-# INLINE buildAttribute #-}
+ lucid2/IHP/HSX/Lucid2/QQ.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, BangPatterns, PackageImports, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}++{-|+Module: IHP.HSX.Lucid2.QQ+Description: Defines the @[hsx||]@ and @[hsxM||]@ syntax+Copyright: (c) digitally induced GmbH, 2025+-}+module IHP.HSX.Lucid2.QQ+  ( hsx+  , uncheckedHsx+  , customHsx+  , quoteHsxExpression+  , hsxM+  , uncheckedHsxM+  , customHsxM+  , quoteHsxExpressionM+  ) where++import           Prelude+import Data.Foldable (Foldable(..))+import Data.Text (Text)+import           IHP.HSX.Parser+import           IHP.HSX.Lucid2.Attribute+import qualified IHP.HSX.Lucid2.ToHtml as M+import qualified "template-haskell" Language.Haskell.TH           as TH+import qualified "template-haskell" Language.Haskell.TH.Syntax           as TH+import           Language.Haskell.TH.Quote+import Data.String.Conversions+import qualified Text.Megaparsec as Megaparsec+import qualified Data.Set as Set+import Lucid.Html5 (doctype_)+import Lucid.Base+  ( Attributes+  , ToHtml (..)+  , makeElement+  , makeElementNoEnd+  )++hsx :: QuasiQuoter+hsx = customHsx+        (HsxSettings+            { checkMarkup = True+            , additionalTagNames = Set.empty+            , additionalAttributeNames = Set.empty+            }+        )++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 settings hsxPosition extensions (cs code) of+                Left error   -> fail (Megaparsec.errorBundlePretty error)+                Right result -> pure result+        compileToHaskell expression+    where++        findHSXPosition = do+            loc <- TH.location+            let (line, col) = TH.loc_start loc+            pure $ Megaparsec.SourcePos (TH.loc_filename loc) (Megaparsec.mkPos line) (Megaparsec.mkPos col)++compileToHaskell :: Node -> TH.ExpQ+compileToHaskell (Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True) = [| doctype_ |]+compileToHaskell (Node name attributes children isLeaf) =+    let+        renderedChildren = TH.listE $ map compileToHaskell children+        listAttributes = TH.listE $ map toLucidAttributes attributes+    in+        if isLeaf+            then+                let+                    element = nodeToLucidLeaf name+                in+                    [| $element $listAttributes |]+            else+                let+                    element = nodeToLucidElement name+                in [| $element $listAttributes (sequence_ @[] $renderedChildren) |]+compileToHaskell (Children children) =+    let+        renderedChildren = TH.listE $ map compileToHaskell children+    in [| (sequence_ @[] $(renderedChildren)) |]++compileToHaskell (TextNode value) = [| toHtmlRaw value |]+compileToHaskell (PreEscapedTextNode value) = [| toHtmlRaw value |]+compileToHaskell (SplicedNode expression) = [| toHtml $(pure expression) |]+compileToHaskell (CommentNode value) = [| toHtmlRaw @Text "<!--" >> toHtmlRaw value >> toHtmlRaw @Text "-->" |]+compileToHaskell NoRenderCommentNode = [| pure () |]++nodeToLucidElement :: Text -> TH.Q TH.Exp+nodeToLucidElement name =+    [| makeElement $(TH.lift name) |]++nodeToLucidLeaf :: Text -> TH.Q TH.Exp+nodeToLucidLeaf name =+    [| makeElementNoEnd $(TH.lift name) |]++toLucidAttributes :: Attribute -> TH.ExpQ+toLucidAttributes (StaticAttribute name (TextValue value)) =+    [| buildAttribute name value |]+toLucidAttributes (StaticAttribute name (ExpressionValue expression)) =+    [| buildAttribute name $(pure expression) |]+toLucidAttributes (SpreadAttributes expression) =+    [| spreadAttributes $(pure expression) |]++spreadAttributes :: (LucidAttributeValue lav) => [(Text, lav)] -> Attributes+spreadAttributes = foldMap' (uncurry buildAttribute)++++-- Monad Version+hsxM :: QuasiQuoter+hsxM = customHsxM+        (HsxSettings+            { checkMarkup = True+            , additionalTagNames = Set.empty+            , additionalAttributeNames = Set.empty+            }+        )++uncheckedHsxM :: QuasiQuoter+uncheckedHsxM = customHsxM+        (HsxSettings+            { checkMarkup = False+            , additionalTagNames = Set.empty+            , additionalAttributeNames = Set.empty+            }+        )++customHsxM :: HsxSettings -> QuasiQuoter+customHsxM settings =+    QuasiQuoter+        { quoteExp = quoteHsxExpressionM settings+        , quotePat = error "quotePat: not defined"+        , quoteDec = error "quoteDec: not defined"+        , quoteType = error "quoteType: not defined"+        }++quoteHsxExpressionM :: HsxSettings -> String -> TH.ExpQ+quoteHsxExpressionM settings code = do+        hsxPosition <- findHSXPosition+        extensions <- TH.extsEnabled+        expression <- case parseHsx settings hsxPosition extensions (cs code) of+                Left error   -> fail (Megaparsec.errorBundlePretty error)+                Right result -> pure result+        [| M.unHtmlType $(compileToHaskellM expression) |]+    where++        findHSXPosition = do+            loc <- TH.location+            let (line, col) = TH.loc_start loc+            pure $ Megaparsec.SourcePos (TH.loc_filename loc) (Megaparsec.mkPos line) (Megaparsec.mkPos col)++compileToHaskellM :: Node -> TH.ExpQ+compileToHaskellM (Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True) = [| M.Lucid2Html doctype_ |]+compileToHaskellM (Node name attributes children isLeaf) =+    let+        renderedChildren = TH.listE $ map compileToHaskellM children+        listAttributes = TH.listE $ map toLucidAttributes attributes+    in+        if isLeaf+            then+                let+                    element = nodeToLucidLeafM name+                in+                    [| $element $listAttributes |]+            else+                let+                    element = nodeToLucidElementM name+                in [| $element $listAttributes (M.sequenceChildren $renderedChildren) |]+compileToHaskellM (Children children) =+    let+        renderedChildren = TH.listE $ map compileToHaskellM children+    in [| (M.sequenceChildren $(renderedChildren)) |]++compileToHaskellM (TextNode value) = [| M.toHtmlRaw value |]+compileToHaskellM (PreEscapedTextNode value) = [| M.toHtmlRaw value |]+compileToHaskellM (SplicedNode expression) = [| M.toHtml $(pure expression) |]+compileToHaskellM (CommentNode value) =+  [| M.sequenceChildren [M.toHtmlRaw @_ @Text "<!--", M.toHtmlRaw value, M.toHtmlRaw @_ @Text "-->"] |]+compileToHaskellM NoRenderCommentNode = [| M.Lucid2Html (pure ()) |]++nodeToLucidElementM :: Text -> TH.Q TH.Exp+nodeToLucidElementM name =+    [| M.makeElement $(TH.lift name) |]++nodeToLucidLeafM :: Text -> TH.Q TH.Exp+nodeToLucidLeafM name =+    [| M.makeElementNoEnd $(TH.lift name) |]
+ lucid2/IHP/HSX/Lucid2/ToHtml.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-|+Module: IHP.HSX.Lucid2.ToHtml+Description: Provides an alternative ToHtml class for Lucid2 that tracks the wrapped monad+Copyright: (c) digitally induced GmbH, 2025+-}++module IHP.HSX.Lucid2.ToHtml where++import Prelude (Applicative (..), Monad (..), String, ($), (.), id, mapM_)+import Lucid.Base (HtmlT (..))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Kind (Type)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL (Text)+import qualified Lucid.Base as Lucid2 (ToHtml (..), Attributes, makeElementNoEnd, makeElement)++class (Monad m) => HtmlGen m where+    data HtmlType m :: Type++    unHtmlType :: HtmlType m -> m ()+    makeElement :: Text -> [Lucid2.Attributes] -> HtmlType m -> HtmlType m+    makeElementNoEnd :: Text -> [Lucid2.Attributes] -> HtmlType m+    sequenceChildren :: [HtmlType m] -> HtmlType m++class (HtmlGen m) => EmbedAsHtml m a where+    toHtml :: a -> HtmlType m+    toHtmlRaw :: a -> HtmlType m++instance (Monad m) => HtmlGen (HtmlT m) where+    newtype HtmlType (HtmlT m) = Lucid2Html { unLucid2Html :: HtmlT m () }+    makeElement name attrs Lucid2Html { unLucid2Html = content } =+      Lucid2Html (Lucid2.makeElement name attrs content)+    makeElementNoEnd name attrs = Lucid2Html (Lucid2.makeElementNoEnd name attrs)+    sequenceChildren = Lucid2Html . mapM_ unLucid2Html+    unHtmlType = unLucid2Html++instance (HtmlGen m) => EmbedAsHtml m (HtmlType m) where+    toHtml = id+    toHtmlRaw = id++instance (Monad m) => EmbedAsHtml (HtmlT m) String where+    toHtml = Lucid2Html . Lucid2.toHtml+    toHtmlRaw = Lucid2Html . Lucid2.toHtmlRaw++instance (Monad m) => EmbedAsHtml (HtmlT m) Text where+    toHtml = Lucid2Html . Lucid2.toHtml+    toHtmlRaw = Lucid2Html . Lucid2.toHtmlRaw++instance (Monad m) => EmbedAsHtml (HtmlT m) TL.Text where+    toHtml = Lucid2Html . Lucid2.toHtml+    toHtmlRaw = Lucid2Html . Lucid2.toHtmlRaw++instance (Monad m) => EmbedAsHtml (HtmlT m) ByteString where+    toHtml = Lucid2Html . Lucid2.toHtml+    toHtmlRaw = Lucid2Html . Lucid2.toHtmlRaw++instance (Monad m) => EmbedAsHtml (HtmlT m) BL.ByteString where+    toHtml = Lucid2Html . Lucid2.toHtml+    toHtmlRaw = Lucid2Html . Lucid2.toHtmlRaw++instance Lucid2.ToHtml () where+    toHtml = pure+    toHtmlRaw = pure++instance (Monad m, Lucid2.ToHtml a) => EmbedAsHtml (HtmlT m) (HtmlT m a) where+    toHtml mHtml = Lucid2Html $ mHtml >>= Lucid2.toHtml+    toHtmlRaw mHtml = Lucid2Html $ mHtml >>= Lucid2.toHtmlRaw++instance (Monad m, Lucid2.ToHtml a) => EmbedAsHtml (HtmlT m) (m a) where+    toHtml mHtml = Lucid2Html $ lift mHtml >>= Lucid2.toHtml+    toHtmlRaw mHtml = Lucid2Html $ lift mHtml >>= Lucid2.toHtmlRaw
+ parser/IHP/HSX/HaskellParser.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+module IHP.HSX.HaskellParser (parseHaskellExpression) where++import Prelude+import GHC.Parser.Lexer (ParseResult (..), PState (..))+import GHC.Types.SrcLoc+import qualified GHC.Parser as Parser+import qualified GHC.Parser.Lexer as Lexer+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Parser.PostProcess+import Text.Megaparsec.Pos+import qualified "template-haskell" Language.Haskell.TH as TH++import qualified GHC.Data.EnumSet as EnumSet+import GHC+import IHP.HSX.HsExpToTH (toExp)++import GHC.Types.Error+import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Error+import qualified GHC.Types.SrcLoc as SrcLoc+#if __GLASGOW_HASKELL__ >= 908+import GHC.Unit.Module.Warnings+#endif++parseHaskellExpression :: SourcePos -> [TH.Extension] -> String -> Either (Int, Int, String) TH.Exp+parseHaskellExpression sourcePos extensions input =+        case expr of+            POk parserState result -> Right (toExp (unLoc result))+            PFailed parserState ->+                let+                    error = renderWithContext defaultSDocContext+                        $ vcat+#if __GLASGOW_HASKELL__ >= 908+                        $ map formatBulleted+#else+                        $ map (formatBulleted defaultSDocContext)+#endif+#if __GLASGOW_HASKELL__ >= 906+                        $ map (diagnosticMessage NoDiagnosticOpts)+#else+                        $ map diagnosticMessage+#endif+                        $ map errMsgDiagnostic+                        $ sortMsgBag Nothing+                        $ getMessages parserState.errors+                    line = SrcLoc.srcLocLine parserState.loc.psRealLoc+                    col = SrcLoc.srcLocCol parserState.loc.psRealLoc+                in+                    Left (line, col, error)+    where+        expr :: ParseResult (LocatedA (HsExpr GhcPs))+        expr = case Lexer.unP Parser.parseExpression parseState of+                POk parserState result -> Lexer.unP (runPV (unECP result)) parserState+                PFailed parserState -> PFailed parserState++        location :: RealSrcLoc+        location = mkRealSrcLoc filename line col+        +        filename :: FastString+        filename = mkFastString sourcePos.sourceName++        line :: Int+        line = unPos sourcePos.sourceLine++        col :: Int+        col = unPos sourcePos.sourceColumn++        buffer = stringToStringBuffer input+        parseState = Lexer.initParserState parserOpts buffer location++        parserOpts :: Lexer.ParserOpts+        parserOpts = Lexer.mkParserOpts (EnumSet.fromList extensions) diagOpts [] False False False False++diagOpts :: DiagOpts+diagOpts =+    DiagOpts+    { diag_warning_flags = EnumSet.empty+    , diag_fatal_warning_flags = EnumSet.empty+    , diag_warn_is_error = False+    , diag_reverse_errors = False+    , diag_max_errors = Nothing+    , diag_ppr_ctx = defaultSDocContext+#if __GLASGOW_HASKELL__ >= 908+    , diag_custom_warning_categories = emptyWarningCategorySet+    , diag_fatal_custom_warning_categories = emptyWarningCategorySet+#endif+    }
+ parser/IHP/HSX/HsExpToTH.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE ViewPatterns, CPP #-}+{-|+Module: IHP.HSX.HsExpToTH+Copyright: (c) digitally induced GmbH, 2022+Description: Converts Haskell AST to Template Haskell AST++Based on https://github.com/guibou/PyF/blob/b3aaee12d34380e55aa3909690041eccb8fcf001/src/PyF/Internal/Meta.hs+-}+module IHP.HSX.HsExpToTH (toExp) where++import Prelude++import GHC.Hs.Expr as Expr+import GHC.Hs.Extension as Ext+import GHC.Hs.Pat as Pat+import GHC.Hs.Lit+import qualified GHC.Hs.Utils as Utils+import qualified Data.ByteString as B+import qualified Language.Haskell.TH.Syntax as TH+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Data.FastString+import GHC.Utils.Outputable (Outputable, ppr, showSDocUnsafe)+import GHC.Types.Basic (Boxity(..))+import GHC.Types.SourceText (il_value, rationalFromFractionalLit)+import qualified GHC.Unit.Module as Module+import GHC.Stack+import qualified Data.List.NonEmpty as NonEmpty+import Language.Haskell.Syntax.Type+#if __GLASGOW_HASKELL__ >= 906+import Language.Haskell.Syntax.Basic+#endif+++fl_value = rationalFromFractionalLit++toLit :: HsLit GhcPs -> TH.Lit+toLit (HsChar _ c) = TH.CharL c+toLit (HsCharPrim _ c) = TH.CharPrimL c+toLit (HsString _ s) = TH.StringL (unpackFS s)+toLit (HsStringPrim _ s) = TH.StringPrimL (B.unpack s)+toLit (HsInt _ i) = TH.IntegerL (il_value i)+toLit (HsIntPrim _ i) = TH.IntPrimL i+toLit (HsWordPrim _ i) = TH.WordPrimL i+toLit (HsInt64Prim _ i) = TH.IntegerL i+toLit (HsWord64Prim _ i) = TH.WordPrimL i+toLit (HsInteger _ i _) = TH.IntegerL i+toLit (HsRat _ f _) = TH.FloatPrimL (fl_value f)+toLit (HsFloatPrim _ f) = TH.FloatPrimL (fl_value f)+toLit (HsDoublePrim _ f) = TH.DoublePrimL (fl_value f)++toLit' :: OverLitVal -> TH.Lit+toLit' (HsIntegral i) = TH.IntegerL (il_value i)+toLit' (HsFractional f) = TH.RationalL (fl_value f)+toLit' (HsIsString _ fs) = TH.StringL (unpackFS fs)++toType :: HsType GhcPs -> TH.Type+toType (HsWildCardTy _) = TH.WildCardT+toType (HsTyVar _ _ n) =+  let n' = unLoc n+   in if isRdrTyVar n'+        then TH.VarT (toName n')+        else TH.ConT (toName n')+toType t = todo "toType" t++toName :: RdrName -> TH.Name+toName n = case n of+  (Unqual o) -> TH.mkName (occNameString o)+  (Qual m o) -> TH.mkName (Module.moduleNameString m <> "." <> occNameString o)+  (Exact name) -> TH.mkName ((occNameString . rdrNameOcc . getRdrName) name) --error "exact"+  (Orig _ _) -> error "orig"++toFieldExp :: a+toFieldExp = undefined++toPat :: Pat.Pat GhcPs -> TH.Pat+toPat (Pat.VarPat _ (unLoc -> name)) = TH.VarP (toName name)+toPat (TuplePat _ p _) = TH.TupP (map (toPat . unLoc) p)+#if __GLASGOW_HASKELL__ >= 910+toPat (ParPat xP lP)  = (toPat . unLoc) lP+#else+toPat (ParPat xP _ lP _) = (toPat . unLoc) lP+#endif+toPat (ConPat pat_con_ext ((unLoc -> name)) pat_args) = TH.ConP (toName name) (map toType []) (map (toPat . unLoc) (Pat.hsConPatArgs pat_args))+toPat (ViewPat pat_con pat_args pat_con_ext) = error "TH.ViewPattern not implemented"+toPat (SumPat _ _ _ _) = error "TH.SumPat not implemented"+toPat (WildPat _ ) = error "TH.WildPat not implemented"+toPat (NPat _ _ _ _ ) = error "TH.NPat not implemented"+toPat p = todo "toPat" p++toExp :: Expr.HsExpr GhcPs -> TH.Exp+toExp (Expr.HsVar _ n) =+  let n' = unLoc n+   in if isRdrDataCon n'+        then TH.ConE (toName n')+        else TH.VarE (toName n')++#if __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsUnboundVar _ n)              = TH.UnboundVarE (TH.mkName . occNameString $ occName n)+#else+toExp (Expr.HsUnboundVar _ n)              = TH.UnboundVarE (TH.mkName . occNameString $ n)+#endif++toExp Expr.HsIPVar {}+  = noTH "toExp" "HsIPVar"++toExp (Expr.HsLit _ l)+  = TH.LitE (toLit l)++toExp (Expr.HsOverLit _ OverLit {ol_val})+  = TH.LitE (toLit' ol_val)++toExp (Expr.HsApp _ e1 e2)+  = TH.AppE (toExp . unLoc $ e1) (toExp . unLoc $ e2)++#if __GLASGOW_HASKELL__ >= 910+toExp (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)+#elif __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsAppType _ e _ HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)+#else+toExp (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)+#endif+toExp (Expr.ExprWithTySig _ e HsWC{hswc_body=unLoc -> HsSig{sig_body}}) = TH.SigE (toExp . unLoc $ e) (toType . unLoc $ sig_body)++toExp (Expr.OpApp _ e1 o e2)+  = TH.UInfixE (toExp . unLoc $ e1) (toExp . unLoc $ o) (toExp . unLoc $ e2)++toExp (Expr.NegApp _ e _)+  = TH.AppE (TH.VarE 'negate) (toExp . unLoc $ e)++-- NOTE: for lambda, there is only one match+#if __GLASGOW_HASKELL__ >= 912+toExp (Expr.HsLam _ LamSingle (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc . unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#elif __GLASGOW_HASKELL__ >= 910+toExp (Expr.HsLam _ LamSingle (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#elif __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#else+toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)])) _))+#endif+  = TH.LamE (fmap toPat ps) (toExp e)++-- toExp (Expr.Let _ bs e)                       = TH.LetE (toDecs bs) (toExp e)+--+toExp (Expr.HsIf _ a b c)                   = TH.CondE (toExp (unLoc a)) (toExp (unLoc b)) (toExp (unLoc c))++-- toExp (Expr.MultiIf _ ifs)                    = TH.MultiIfE (map toGuard ifs)+-- toExp (Expr.Case _ e alts)                    = TH.CaseE (toExp e) (map toMatch alts)+-- toExp (Expr.Do _ ss)                          = TH.DoE (map toStmt ss)+-- toExp e@Expr.MDo{}                            = noTH "toExp" e+--+toExp (Expr.ExplicitTuple _ args boxity) = ctor tupArgs+  where+    toTupArg (Expr.Present _ e) = Just $ unLoc e+    toTupArg (Expr.Missing _) = Nothing+    toTupArg _ = error "impossible case"++    ctor = case boxity of+      Boxed -> TH.TupE+      Unboxed -> TH.UnboxedTupE++    tupArgs = fmap ((fmap toExp) . toTupArg) args++-- toExp (Expr.List _ xs)                        = TH.ListE (fmap toExp xs)+#if __GLASGOW_HASKELL__ >= 910+toExp (Expr.HsPar _ e) =+#else+toExp (Expr.HsPar _ _ e _) =+#endif+  TH.ParensE (toExp . unLoc $ e)++toExp (Expr.SectionL _ (unLoc -> a) (unLoc -> b))+  = TH.InfixE (Just . toExp $ a) (toExp b) Nothing++toExp (Expr.SectionR _ (unLoc -> a) (unLoc -> b))+  = TH.InfixE Nothing (toExp a) (Just . toExp $ b)++toExp (Expr.RecordCon _ name HsRecFields {rec_flds})+  = TH.RecConE (toName . unLoc $ name) (fmap toFieldExp rec_flds)++toExp (Expr.RecordUpd _ (unLoc -> e) xs)                 = TH.RecUpdE (toExp e) $ case xs of+#if __GLASGOW_HASKELL__ >= 908+    RegularRecUpdFields { recUpdFields = fields } ->+#else+    Left fields ->+#endif+        let+            f (unLoc -> x) = (name, value)+                where+                    value = toExp $ unLoc $ hfbRHS x+                    name =+                        case unLoc (hfbLHS x) of+#if __GLASGOW_HASKELL__ >= 912+                            FieldOcc _ (unLoc -> name) -> toName name+                            XFieldOcc _ -> error "todo"+#else+                            Unambiguous _ (unLoc -> name) -> toName name+                            Ambiguous _ (unLoc -> name) -> toName name+#endif+        in+            map f fields+    otherwise -> error "todo"+-- toExp (Expr.ListComp _ e ss)                  = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]+--  where+--   convert (Expr.QualStmt _ st)                = toStmt st+--   convert s                                   = noTH "toExp ListComp" s+-- toExp (Expr.ExpTypeSig _ e t)                 = TH.SigE (toExp e) (toType t)+--+toExp (Expr.ExplicitList _ (map unLoc -> args)) = TH.ListE (map toExp args)++toExp (Expr.ArithSeq _ _ e)+  = TH.ArithSeqE $ case e of+    (From a) -> TH.FromR (toExp $ unLoc a)+    (FromThen a b) -> TH.FromThenR (toExp $ unLoc a) (toExp $ unLoc b)+    (FromTo a b) -> TH.FromToR (toExp $ unLoc a) (toExp $ unLoc b)+    (FromThenTo a b c) -> TH.FromThenToR (toExp $ unLoc a) (toExp $ unLoc b) (toExp $ unLoc c)+++toExp (Expr.HsProjection _ locatedFields) =+  let+    extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+    extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..."+  in+#if __GLASGOW_HASKELL__ >= 912+    TH.ProjectionE (NonEmpty.map (unpackFS . (.field_label) . unLoc . extractFieldLabel) locatedFields)+#elif __GLASGOW_HASKELL__ >= 906+    TH.ProjectionE (NonEmpty.map (unpackFS . (.field_label) . unLoc . extractFieldLabel . unLoc) locatedFields)+#else+    TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)+#endif++toExp (Expr.HsGetField _ expr locatedField) =+  let+    extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+    extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..."+  in+#if __GLASGOW_HASKELL__ >= 906+    TH.GetFieldE (toExp (unLoc expr)) (unpackFS . (.field_label) . unLoc . extractFieldLabel . unLoc $ locatedField)+#else+    TH.GetFieldE (toExp (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)+#endif++#if __GLASGOW_HASKELL__ >= 912+toExp (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#elif __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsOverLabel _ _ fastString) = TH.LabelE (unpackFS fastString)+#else+toExp (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#endif++toExp e = todo "toExp" e+++todo :: Outputable e => String -> e -> a+todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", (showSDocUnsafe $ ppr thing)]++noTH :: (HasCallStack, Show e) => String -> e -> a+noTH fun thing = error . concat $ [moduleName, ".", fun, ": no TemplateHaskell for: ", show thing]++moduleName :: String+moduleName = "IHP.HSX.HsExpToTH"
+ parser/IHP/HSX/Parser.hs view
@@ -0,0 +1,643 @@+{-# 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+, HsxSettings (..)+) where++import Prelude+import Data.Text (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 Data.String.Conversions+import qualified Data.List as List+import Control.Monad (unless)+import qualified "template-haskell" 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+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)++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 -- ^ A Comment that is rendered in the final HTML+    | NoRenderCommentNode -- ^ A comment that is not rendered in the final HTML+    deriving (Eq, 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 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 @<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.+    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 "<!--"+    body :: String <- manyTill (satisfy (const True)) (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 <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 = do+            let value = if "data-" `Text.isPrefixOf` key+                    then "true"+                    else key+            pure (StaticAttribute key (TextValue value))++    -- Parsing normal attributes like <input value="Hello"/>+    let attributeWithValue = do+            _ <- char '='+            space+            value <- hsxQuotedValue <|> hsxSplicedValue+            space+            pure (StaticAttribute key value)++    attributeWithValue <|> attributeWithoutValue+++hsxAttributeName :: Parser Text+hsxAttributeName = do+        name <- rawAttribute+        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+            || name `Set.member` attributes+            || name `Set.member` ?settings.additionalAttributeNames++        rawAttribute = takeWhile1P Nothing (\c -> Char.isAlphaNum c || c == '-' || c == '_')+++hsxQuotedValue :: Parser AttributeValue+hsxQuotedValue = do+    value <- between (char '"') (char '"') (takeWhileP Nothing (\c -> c /= '\"'))+    pure (TextValue value)++hsxSplicedValue :: Parser AttributeValue+hsxSplicedValue = do+    (pos, value) <- between (char '{') (char '}') do+        pos <- getSourcePos+        code <- takeWhile1P Nothing (\c -> c /= '}')+        pure (pos, code)+    haskellExpression <- parseHaskellExpression pos (cs value)+    pure (ExpressionValue haskellExpression)++hsxClosingElement name = (hsxClosingElement' name) <?> friendlyErrorMessage+    where+        friendlyErrorMessage = show (Text.unpack ("</" <> name <> ">"))+        hsxClosingElement' name = do+            _ <- string ("</" <> name)+            space+            char ('>')+            pure ()++hsxChild :: Parser Node+hsxChild = hsxElement <|> hsxSplicedNode <|> try (space >> hsxElement) <|> hsxText++-- | Parses a hsx text node+--+-- Stops parsing when hitting a variable, like `{myVar}`+hsxText :: Parser Node+hsxText = buildTextNode <$> takeWhile1P (Just "text") (\c -> c /= '{' && c /= '}' && c /= '<' && c /= '>')++-- | Builds a TextNode and strips all surround whitespace from the input string+buildTextNode :: Text -> Node+buildTextNode value = TextNode (collapseSpace value)++data TokenTree = TokenLeaf Text | TokenNode [TokenTree] deriving (Show)++hsxSplicedNode :: Parser Node+hsxSplicedNode = do+        (pos, expression) <- doParse+        haskellExpression <- parseHaskellExpression pos (cs expression)+        pure (SplicedNode haskellExpression)+    where+        doParse = do+            (pos, tree) <- node+            let value = (treeToString "" tree)+            pure (pos, Text.init $ Text.tail value)++        parseTree = (snd <$> node) <|> leaf+        node = between (char '{') (char '}') do+                pos <- getSourcePos+                tree <- many parseTree+                pure (pos, TokenNode tree)+        leaf = TokenLeaf <$> takeWhile1P Nothing (\c -> c /= '{' && c /= '}')+        treeToString :: Text -> TokenTree -> Text+        treeToString acc (TokenLeaf value)  = acc <> value+        treeToString acc (TokenNode [])     = acc+        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 +                                  && 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++hsxIdentifier :: Parser Text+hsxIdentifier = do+    name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_')+    space+    pure name+++attributes :: Set Text+attributes = Set.fromList+        [ "accept", "accept-charset", "accesskey", "action", "alt", "async"+        , "autocomplete", "autofocus", "autoplay", "challenge", "charset"+        , "checked", "cite", "class", "cols", "colspan", "content"+        , "contenteditable", "contextmenu", "controls", "coords", "data"+        , "datetime", "defer", "dir", "disabled", "draggable", "enctype"+        , "form", "formaction", "formenctype", "formmethod", "formnovalidate"+        , "for"+        , "formtarget", "headers", "height", "hidden", "high", "href"+        , "hreflang", "http-equiv", "icon", "id", "ismap", "item", "itemprop"+        , "itemscope", "itemtype"+        , "keytype", "label", "lang", "list", "loop", "low", "manifest", "max"+        , "maxlength", "media", "method", "min", "multiple", "name"+        , "novalidate", "onbeforeonload", "onbeforeprint", "onblur", "oncanplay"+        , "oncanplaythrough", "onchange", "oncontextmenu", "onclick"+        , "ondblclick", "ondrag", "ondragend", "ondragenter", "ondragleave"+        , "ondragover", "ondragstart", "ondrop", "ondurationchange", "onemptied"+        , "onended", "onerror", "onfocus", "onformchange", "onforminput"+        , "onhaschange", "oninput", "oninvalid", "onkeydown", "onkeyup"+        , "onload", "onloadeddata", "onloadedmetadata", "onloadstart"+        , "onmessage", "onmousedown", "onmousemove", "onmouseout", "onmouseover"+        , "onmouseup", "onmousewheel", "ononline", "onpagehide", "onpageshow"+        , "onpause", "onplay", "onplaying", "onprogress", "onpropstate"+        , "onratechange", "onreadystatechange", "onredo", "onresize", "onscroll"+        , "onseeked", "onseeking", "onselect", "onstalled", "onstorage"+        , "onsubmit", "onsuspend", "ontimeupdate", "onundo", "onunload"+        , "onvolumechange", "onwaiting", "open", "optimum", "pattern", "ping"+        , "placeholder", "preload", "pubdate", "radiogroup", "readonly", "rel"+        , "required", "reversed", "rows", "rowspan", "sandbox", "scope"+        , "scoped", "seamless", "selected", "shape", "size", "sizes", "span"+        , "spellcheck", "src", "srcdoc", "srcset", "start", "step", "style", "subject"+        , "summary", "tabindex", "target", "title", "type", "usemap", "value"+        , "width", "wrap", "xmlns"+        , "ontouchstart", "download"+        , "allowtransparency", "minlength", "maxlength", "property"+        , "role"+        , "d", "viewBox", "cx", "cy", "r", "x", "y", "text-anchor", "alignment-baseline"+        , "line-spacing", "letter-spacing"+        , "integrity", "crossorigin", "poster"+        , "accent-height", "accumulate", "additive", "alphabetic", "amplitude"+        , "arabic-form", "ascent", "attributeName", "attributeType", "azimuth"+        , "baseFrequency", "baseProfile", "bbox", "begin", "bias", "by", "calcMode"+        , "cap-height", "class", "clipPathUnits", "contentScriptType"+        , "contentStyleType", "cx", "cy", "d", "descent", "diffuseConstant", "divisor"+        , "dur", "dx", "dy", "edgeMode", "elevation", "end", "exponent"+        , "externalResourcesRequired", "filterRes", "filterUnits", "font-family"+        , "font-size", "font-stretch", "font-style", "font-variant", "font-weight"+        , "format", "from", "fx", "fy", "g1", "g2", "glyph-name", "glyphRef"+        , "gradientTransform", "gradientUnits", "hanging", "height", "horiz-adv-x"+        , "horiz-origin-x", "horiz-origin-y", "id", "ideographic", "in", "in2"+        , "intercept", "k", "k1", "k2", "k3", "k4", "kernelMatrix", "kernelUnitLength"+        , "keyPoints", "keySplines", "keyTimes", "lang", "lengthAdjust"+        , "limitingConeAngle", "local", "markerHeight", "markerUnits", "markerWidth"+        , "maskContentUnits", "maskUnits", "mathematical", "max", "media", "method"+        , "min", "mode", "name", "numOctaves", "offset", "onabort", "onactivate"+        , "onbegin", "onclick", "onend", "onerror", "onfocusin", "onfocusout", "onload"+        , "onmousedown", "onmousemove", "onmouseout", "onmouseover", "onmouseup"+        , "onrepeat", "onresize", "onscroll", "onunload", "onzoom", "operator", "order"+        , "orient", "orientation", "origin", "overline-position", "overline-thickness"+        , "panose-1", "path", "pathLength", "patternContentUnits", "patternTransform"+        , "patternUnits", "points", "pointsAtX", "pointsAtY", "pointsAtZ"+        , "preserveAlpha", "preserveAspectRatio", "primitiveUnits", "r", "radius"+        , "refX", "refY", "rendering-intent", "repeatCount", "repeatDur"+        , "requiredExtensions", "requiredFeatures", "restart", "result", "rotate", "rx"+        , "ry", "scale", "seed", "slope", "spacing", "specularConstant"+        , "specularExponent", "spreadMethod", "startOffset", "stdDeviation", "stemh"+        , "stemv", "stitchTiles", "strikethrough-position", "strikethrough-thickness"+        , "string", "style", "surfaceScale", "systemLanguage", "tableValues", "target"+        , "targetX", "targetY", "textLength", "title", "to", "transform", "type", "u1"+        , "u2", "underline-position", "underline-thickness", "unicode", "unicode-range"+        , "units-per-em", "v-alphabetic", "v-hanging", "v-ideographic", "v-mathematical"+        , "values", "version", "vert-adv-y", "vert-origin-x", "vert-origin-y", "viewBox"+        , "viewTarget", "width", "widths", "x", "x-height", "x1", "x2"+        , "xChannelSelector", "xlink:actuate", "xlink:arcrole", "xlink:href"+        , "xlink:role", "xlink:show", "xlink:title", "xlink:type", "xml:base"+        , "xml:lang", "xml:space", "y", "y1", "y2", "yChannelSelector", "z", "zoomAndPan"+        , "alignment-baseline", "baseline-shift", "clip-path", "clip-rule"+        , "clip", "color-interpolation-filters", "color-interpolation"+        , "color-profile", "color-rendering", "color", "cursor", "direction"+        , "display", "dominant-baseline", "enable-background", "fill-opacity"+        , "fill-rule", "fill", "filter", "flood-color", "flood-opacity"+        , "font-size-adjust", "glyph-orientation-horizontal"+        , "glyph-orientation-vertical", "image-rendering", "kerning", "letter-spacing"+        , "lighting-color", "marker-end", "marker-mid", "marker-start", "mask"+        , "opacity", "overflow", "pointer-events", "shape-rendering", "stop-color"+        , "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", "is"+        , "cellspacing", "cellpadding", "bgcolor", "classes"+        , "loading"+        , "frameborder", "allow", "allowfullscreen", "nonce", "referrerpolicy", "slot"+        , "kind"+        , "html"+        , "sse-connect", "sse-swap"+        , "muted", "onkeypress"+        ]++parents :: Set Text+parents = Set.fromList+          [ "a"+          , "abbr"+          , "address"+          , "animate"+          , "animateMotion"+          , "animateTransform"+          , "article"+          , "aside"+          , "audio"+          , "b"+          , "bdi"+          , "bdo"+          , "blink"+          , "blockquote"+          , "body"+          , "button"+          , "canvas"+          , "caption"+          , "circle"+          , "cite"+          , "clipPath"+          , "code"+          , "colgroup"+          , "command"+          , "data"+          , "datalist"+          , "dd"+          , "defs"+          , "del"+          , "desc"+          , "details"+          , "dfn"+          , "dialog"+          , "discard"+          , "div"+          , "dl"+          , "dt"+          , "ellipse"+          , "em"+          , "feBlend"+          , "feColorMatrix"+          , "feComponentTransfer"+          , "feComposite"+          , "feConvolveMatrix"+          , "feDiffuseLighting"+          , "feDisplacementMap"+          , "feDistantLight"+          , "feDropShadow"+          , "feFlood"+          , "feFuncA"+          , "feFuncB"+          , "feFuncG"+          , "feFuncR"+          , "feGaussianBlur"+          , "feImage"+          , "feMerge"+          , "feMergeNode"+          , "feMorphology"+          , "feOffset"+          , "fePointLight"+          , "feSpecularLighting"+          , "feSpotLight"+          , "feTile"+          , "feTurbulence"+          , "fieldset"+          , "figcaption"+          , "figure"+          , "filter"+          , "footer"+          , "foreignObject"+          , "form"+          , "g"+          , "h1"+          , "h2"+          , "h3"+          , "h4"+          , "h5"+          , "h6"+          , "hatch"+          , "hatchpath"+          , "head"+          , "header"+          , "hgroup"+          , "html"+          , "i"+          , "iframe"+          , "ins"+          , "ion-icon"+          , "kbd"+          , "label"+          , "legend"+          , "li"+          , "line"+          , "linearGradient"+          , "loading"+          , "main"+          , "map"+          , "mark"+          , "marker"+          , "marquee"+          , "mask"+          , "menu"+          , "mesh"+          , "meshgradient"+          , "meshpatch"+          , "meshrow"+          , "metadata"+          , "meter"+          , "mpath"+          , "nav"+          , "noscript"+          , "object"+          , "ol"+          , "optgroup"+          , "option"+          , "output"+          , "p"+          , "path"+          , "pattern"+          , "picture"+          , "polygon"+          , "polyline"+          , "pre"+          , "progress"+          , "q"+          , "radialGradient"+          , "rect"+          , "rp"+          , "rt"+          , "ruby"+          , "s"+          , "samp"+          , "script"+          , "section"+          , "select"+          , "set"+          , "slot"+          , "small"+          , "source"+          , "span"+          , "stop"+          , "strong"+          , "style"+          , "sub"+          , "summary"+          , "sup"+          , "svg"+          , "switch"+          , "symbol"+          , "table"+          , "tbody"+          , "td"+          , "template"+          , "text"+          , "textPath"+          , "textarea"+          , "tfoot"+          , "th"+          , "thead"+          , "time"+          , "title"+          , "tr"+          , "track"+          , "tspan"+          , "u"+          , "ul"+          , "unknown"+          , "use"+          , "var"+          , "video"+          , "view"+          , "wbr"+          ]++leafs :: Set Text+leafs = Set.fromList+        [ "area"+        , "base"+        , "br"+        , "col"+        , "embed"+        , "hr"+        , "img"+        , "input"+        , "link"+        , "meta"+        , "param"+        , "!DOCTYPE"+        ]++stripTextNodeWhitespaces nodes = stripLastTextNodeWhitespaces (stripFirstTextNodeWhitespaces nodes)++stripLastTextNodeWhitespaces nodes =+    let strippedLastElement = if List.length nodes > 0+            then case List.last nodes of+                TextNode text -> Just $ TextNode (Text.stripEnd text)+                otherwise -> Nothing+            else Nothing+    in case strippedLastElement of+        Just last -> (fst $ List.splitAt ((List.length nodes) - 1) nodes) <> [last]+        Nothing -> nodes++stripFirstTextNodeWhitespaces nodes =+    let strippedFirstElement = if List.length nodes > 0+            then case List.head nodes of+                TextNode text -> Just $ TextNode (Text.stripStart text)+                otherwise -> Nothing+            else Nothing+    in case strippedFirstElement of+        Just first -> first:(List.tail nodes)+        Nothing -> nodes++-- | Replaces multiple space characters with a single one+collapseSpace :: Text -> Text+collapseSpace text = cs $ filterDuplicateSpaces (cs text)+    where+        filterDuplicateSpaces :: String -> String+        filterDuplicateSpaces string = filterDuplicateSpaces' string False++        filterDuplicateSpaces' :: String -> Bool -> String+        filterDuplicateSpaces' (char:rest) True | Char.isSpace char = filterDuplicateSpaces' rest True+        filterDuplicateSpaces' (char:rest) False | Char.isSpace char = ' ':(filterDuplicateSpaces' rest True)+        filterDuplicateSpaces' (char:rest) isRemovingSpaces = char:(filterDuplicateSpaces' rest False)+        filterDuplicateSpaces' [] isRemovingSpaces = []