From e0c882acfa21c14a34ac304654d76cbdedf95315 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Fri, 2 Aug 2024 17:56:21 -0400 Subject: [PATCH 1/2] Refactored HSX to use Text instead of blaze --- ihp-hsx/IHP/HSX/Attribute.hs | 63 ++--- ihp-hsx/IHP/HSX/Html.hs | 94 ++++++++ ihp-hsx/IHP/HSX/QQ.hs | 409 +++------------------------------ ihp-hsx/IHP/HSX/ToHtml.hs | 18 +- ihp-hsx/Test/IHP/HSX/QQSpec.hs | 10 +- ihp-hsx/ihp-hsx.cabal | 2 + 6 files changed, 179 insertions(+), 417 deletions(-) create mode 100644 ihp-hsx/IHP/HSX/Html.hs diff --git a/ihp-hsx/IHP/HSX/Attribute.hs b/ihp-hsx/IHP/HSX/Attribute.hs index c533a86eb..13032bf01 100644 --- a/ihp-hsx/IHP/HSX/Attribute.hs +++ b/ihp-hsx/IHP/HSX/Attribute.hs @@ -4,7 +4,7 @@ Module: IHP.HSX.Attribute Copyright: (c) digitally induced GmbH, 2023 -} module IHP.HSX.Attribute -( ApplyAttribute (..) +( AttributeConverter (..) ) where import Prelude @@ -15,29 +15,40 @@ import Data.String.Conversions import IHP.HSX.ToHtml import qualified Data.Text as Text import Data.Text (Text) +import IHP.HSX.Html +import Data.ByteString -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 , 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 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 #-} \ No newline at end of file +class AttributeConverter value where + attributeValueToText :: Text -> value -> Maybe Html + +instance AttributeConverter Bool where + attributeValueToText name True = + Just if "data-" `Text.isPrefixOf` name + then preEscapedToHtml "\"true\"" -- "true" for data attributes + else "\"" <> textToHtml name <> "\"" -- normal html boolean attriubtes, like , see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes + attributeValueToText name False | "data-" `Text.isPrefixOf` name = Just $ preEscapedToHtml "\"false\"" -- data attribute set to "false" + attributeValueToText name value = Nothing -- html boolean attribute, like will be dropped as there is no other way to specify that it's set to false + {-# INLINE attributeValueToText #-} + +instance AttributeConverter attribute => AttributeConverter (Maybe attribute) where + attributeValueToText name (Just value) = attributeValueToText name value + attributeValueToText name Nothing = Nothing + {-# INLINE attributeValueToText #-} + +instance AttributeConverter Text where + attributeValueToText name value = Just $ preEscapedToHtml name <> preEscapedToHtml "=\"" <> textToHtml value <> preEscapedToHtml "\"" + +--instance AttributeConverter Html5.AttributeValue where +-- attributeValueToText name value = mempty + +instance AttributeConverter Html where + attributeValueToText name value = Just $ "\"" <> value <> "\"" + +instance AttributeConverter ByteString where + attributeValueToText name value = attributeValueToText name (cs @ByteString @Text value) + + -- applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value) + +--instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where +-- applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h +-- {-# INLINE applyAttribute #-} \ No newline at end of file diff --git a/ihp-hsx/IHP/HSX/Html.hs b/ihp-hsx/IHP/HSX/Html.hs new file mode 100644 index 000000000..770b72870 --- /dev/null +++ b/ihp-hsx/IHP/HSX/Html.hs @@ -0,0 +1,94 @@ +module IHP.HSX.Html +( preEscapedToHtml +, renderHtml +, Html +, spaceSep +, concat +, textToHtml +, spaceSepWithLeadingSpace +, renderHtmlBuilder +, concat +, renderMarkup +) where + +import Prelude hiding (concat) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Coerce (coerce) +import qualified "template-haskell" Language.Haskell.TH as TH +import qualified "template-haskell" Language.Haskell.TH.Syntax as TH +import Data.String +import qualified Data.Binary.Builder as Builder +import qualified Data.Text.Encoding as Text + +-- We have to keep the type variable to allow for a Monad instance +-- The Monad instance is needed to keep b.c. with existing IHP apps +newtype Html' a = Html Text +type Html = Html' () + +instance Monoid Html where + mempty = Html "" + +instance Semigroup Html where + Html first <> Html second = Html (first <> second) + +preEscapedToHtml :: Text -> Html +preEscapedToHtml preEscaped = Html preEscaped + +renderHtml :: Html -> Text +renderHtml (Html html) = html + +renderMarkup :: Html -> Text +renderMarkup = renderHtml + +instance TH.Lift Html where + lift (Html text) = [| Html $(TH.lift text) |] + liftTyped (Html text) = [|| Html $$(TH.liftTyped text) ||] + +spaceSep :: [Html] -> Html +spaceSep values = Html (Text.unwords (coerce values)) + +spaceSepWithLeadingSpace :: [Html] -> Html +spaceSepWithLeadingSpace values = + let + spaceSep'@(Html spaceSeperatedHtml) = spaceSep values + in + if Text.null spaceSeperatedHtml + then spaceSep' + else " " <> spaceSep' + +concat :: [Html] -> Html +concat values = Html (Text.concat (coerce values)) + +escapeChar :: Char -> Text +escapeChar char = + case char of + '<' -> "<" + '>' -> ">" + '&' -> "&" + '"' -> """ + '\'' -> "'" + x -> Text.singleton x + +textToHtml :: Text -> Html +textToHtml text = + Html (Text.concatMap escapeChar text) + +instance IsString Html where + fromString string = preEscapedToHtml (Text.pack string) + + +instance Functor Html' where + fmap f (Html text) = undefined + +instance Applicative Html' where + pure value = (Html "") + Html a <*> Html b = Html (a <> b) + +instance Monad Html' where + return = pure + (>>=) :: forall a b. Html' a -> (a -> Html' b) -> Html' b + Html x >>= f = Html x + +renderHtmlBuilder :: Html -> Builder.Builder +renderHtmlBuilder html = Text.encodeUtf8Builder (renderHtml html) \ No newline at end of file diff --git a/ihp-hsx/IHP/HSX/QQ.hs b/ihp-hsx/IHP/HSX/QQ.hs index a064f2fb4..374c37f87 100644 --- a/ihp-hsx/IHP/HSX/QQ.hs +++ b/ihp-hsx/IHP/HSX/QQ.hs @@ -27,6 +27,10 @@ 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.List as List +import IHP.HSX.Html +import qualified IHP.HSX.Html as Html +import qualified Data.Maybe as Maybe hsx :: QuasiQuoter hsx = QuasiQuoter { @@ -52,410 +56,55 @@ quoteHsxExpression code = do 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 "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True) = [| Html.preEscapedToHtml "\n" |] compileToHaskell (Node name attributes children isLeaf) = let renderedChildren = TH.listE $ map compileToHaskell children stringAttributes = TH.listE $ map toStringAttribute attributes + startTag = preEscapedToHtml ("<" <> name) in if isLeaf then - let - element = nodeToBlazeLeaf name - in - [| applyAttributes $element $stringAttributes |] + if List.null attributes + then let tag = preEscapedToHtml ("<" <> name <> ">") in [| tag |] + else [| startTag <> Html.spaceSepWithLeadingSpace $stringAttributes <> ">" |] else let - element = nodeToBlazeElement name - in [| applyAttributes ($element (mconcat $renderedChildren)) $stringAttributes |] + endTag = preEscapedToHtml (" name <> ">") + in + if List.null attributes + then let startTag = preEscapedToHtml ("<" <> name <> ">") in [| startTag <> Html.concat $renderedChildren <> endTag |] + else [| startTag <> Html.spaceSepWithLeadingSpace $stringAttributes <> ">" <> Html.concat $renderedChildren <> endTag |] compileToHaskell (Children children) = let renderedChildren = TH.listE $ map compileToHaskell children - in [| mconcat $(renderedChildren) |] + in [| Html.concat $(renderedChildren) |] -compileToHaskell (TextNode value) = [| Html5.preEscapedText value |] -compileToHaskell (PreEscapedTextNode value) = [| Html5.preEscapedText value |] +compileToHaskell (TextNode value) = let value' = Html.preEscapedToHtml value in [| value' |] +compileToHaskell (PreEscapedTextNode value) = let value' = Html.preEscapedToHtml value in [| 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)) ()) |] +compileToHaskell (CommentNode value) = let value' = Html.preEscapedToHtml ("") in [| value' |] +compileToHaskell (NoRenderCommentNode) = [| "" |] 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 (StaticAttribute name (ExpressionValue expression)) = + [| case attributeValueToText name $(pure expression) of + Just value -> preEscapedToHtml name <> "=" <> value + Nothing -> "" + |] 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 <> "=\"" + staticAttribute = preEscapedToHtml (name <> "=\"" <> value <> "\"") 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 #-} + [| staticAttribute |] -textToStaticString :: Text -> StaticString -textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 text) text -{-# INLINE textToStaticString #-} -instance Show (MarkupM ()) where - show html = BlazeString.renderHtml html +spreadAttributes :: AttributeConverter value => [(Text, value)] -> IHP.HSX.Html.Html +spreadAttributes attributes = Html.spaceSep $ Maybe.mapMaybe (\(name, value) -> attributeValueToText name value) attributes +{-# INLINE spreadAttributes #-} \ No newline at end of file diff --git a/ihp-hsx/IHP/HSX/ToHtml.hs b/ihp-hsx/IHP/HSX/ToHtml.hs index c764a0d97..28fff0303 100644 --- a/ihp-hsx/IHP/HSX/ToHtml.hs +++ b/ihp-hsx/IHP/HSX/ToHtml.hs @@ -15,25 +15,28 @@ import Data.Text import Data.ByteString import Data.String.Conversions (cs) import IHP.HSX.ConvertibleStrings () +import qualified Text.Blaze.Html.Renderer.Text as Blaze +import qualified Data.Text as Text +import IHP.HSX.Html class ToHtml a where - toHtml :: a -> Html5.Html + toHtml :: a -> Html instance ToHtml (Text.Blaze.Internal.MarkupM ()) where {-# INLINE toHtml #-} - toHtml a = a + toHtml html = textToHtml (cs (Blaze.renderHtml html)) instance ToHtml Text where {-# INLINE toHtml #-} - toHtml = Html5.text + toHtml text = textToHtml text instance ToHtml String where {-# INLINE toHtml #-} - toHtml = Html5.string + toHtml string = textToHtml (cs string) instance ToHtml ByteString where {-# INLINE toHtml #-} - toHtml value = toHtml (cs value :: Text) + toHtml value = textToHtml (cs value) instance {-# OVERLAPPABLE #-} ToHtml a => ToHtml (Maybe a) where {-# INLINE toHtml #-} @@ -41,4 +44,7 @@ instance {-# OVERLAPPABLE #-} ToHtml a => ToHtml (Maybe a) where instance {-# OVERLAPPABLE #-} Show a => ToHtml a where {-# INLINE toHtml #-} - toHtml value = Html5.string (show value) + toHtml value = toHtml (show value) + +instance ToHtml Html where + toHtml value = value \ No newline at end of file diff --git a/ihp-hsx/Test/IHP/HSX/QQSpec.hs b/ihp-hsx/Test/IHP/HSX/QQSpec.hs index 9bd65c05d..2ac808b16 100644 --- a/ihp-hsx/Test/IHP/HSX/QQSpec.hs +++ b/ihp-hsx/Test/IHP/HSX/QQSpec.hs @@ -8,8 +8,9 @@ import Test.Hspec import Prelude import IHP.HSX.QQ import qualified Text.Blaze.Renderer.Text as Blaze -import Text.Blaze (preEscapedTextValue) +import IHP.HSX.Html (preEscapedToHtml) import Data.Text +import IHP.HSX.Html tests :: SpecWith () tests = do @@ -183,7 +184,7 @@ tests = do it "should support pre escaped class names" do -- See https://github.com/digitallyinduced/ihp/issues/1527 - let className = preEscapedTextValue "a&" + let className = preEscapedToHtml "a&" [hsx|
|] `shouldBeHtml` "
" it "should support support doctype" do @@ -200,6 +201,5 @@ newtype NewPlaceId = NewPlaceId Text newPlaceData = NewPlaceId "New Punches Cross" locationId = LocationId 17 (PlaceId "Punches Cross") - - -shouldBeHtml hsx expectedHtml = (Blaze.renderMarkup hsx) `shouldBe` expectedHtml +shouldBeHtml :: Html -> Text -> IO () +shouldBeHtml hsx expectedHtml = (renderHtml hsx) `shouldBe` expectedHtml diff --git a/ihp-hsx/ihp-hsx.cabal b/ihp-hsx/ihp-hsx.cabal index b6973912d..40a25e018 100644 --- a/ihp-hsx/ihp-hsx.cabal +++ b/ihp-hsx/ihp-hsx.cabal @@ -30,6 +30,7 @@ library , megaparsec >= 9.2.2 && < 9.7 , string-conversions >= 0.4.0 && < 0.5 , unordered-containers + , binary default-extensions: OverloadedStrings , NoImplicitPrelude @@ -89,6 +90,7 @@ library , IHP.HSX.HaskellParser , IHP.HSX.HsExpToTH , IHP.HSX.Attribute + , IHP.HSX.Html test-suite ihp-hsx-tests type: exitcode-stdio-1.0 From 04ef532eecad242a299ab79c99496f0aa2c62614 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Fri, 2 Aug 2024 17:57:02 -0400 Subject: [PATCH 2/2] Use HSX types instead of blaze everywhere --- IHP/AutoRefresh/View.hs | 2 +- IHP/Breadcrumb/Types.hs | 4 +-- IHP/Breadcrumb/ViewFunctions.hs | 2 +- IHP/Controller/AccessDenied.hs | 4 +-- IHP/Controller/NotFound.hs | 3 +- IHP/Controller/Render.hs | 4 +-- IHP/ErrorController.hs | 6 ++-- IHP/FlashMessages/ViewFunctions.hs | 2 +- IHP/Modal/Types.hs | 2 +- IHP/Modal/ViewFunctions.hs | 2 +- IHP/PageHead/ViewFunctions.hs | 2 +- IHP/Pagination/ViewFunctions.hs | 2 +- IHP/RouterSupport.hs | 8 +++-- IHP/View/CSSFramework.hs | 2 +- IHP/View/Form.hs | 4 +-- IHP/View/Types.hs | 2 +- IHP/ViewPrelude.hs | 3 +- IHP/ViewSupport.hs | 29 ++++--------------- IHP/Welcome/Controller.hs | 2 +- NixSupport/haskell-packages/ihp-hsx.nix | 17 +++++++++++ Test/Main.hs | 4 --- Test/View/CSSFrameworkSpec.hs | 4 +-- Test/View/FormSpec.hs | 2 +- Test/ViewSupportSpec.hs | 3 +- ihp-ide/IHP/IDE/Data/View/EditValue.hs | 2 +- .../View/Columns/EditForeignKey.hs | 10 +++---- .../View/Columns/NewForeignKey.hs | 7 +++-- ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs | 22 +++++++------- .../SchemaDesigner/View/Migrations/Index.hs | 3 +- .../IDE/SchemaDesigner/View/Schema/Code.hs | 4 +-- .../View/Schema/GeneratedCode.hs | 2 +- ihp-ide/IHP/IDE/StatusServer.hs | 4 +-- ihp-ide/IHP/IDE/ToolServer/Helper/View.hs | 14 ++++----- ihp-ide/IHP/IDE/ToolServer/Layout.hs | 12 ++++---- 34 files changed, 97 insertions(+), 98 deletions(-) diff --git a/IHP/AutoRefresh/View.hs b/IHP/AutoRefresh/View.hs index 9ffc4c190..7baa506c9 100644 --- a/IHP/AutoRefresh/View.hs +++ b/IHP/AutoRefresh/View.hs @@ -3,7 +3,7 @@ module IHP.AutoRefresh.View where import IHP.Prelude import IHP.AutoRefresh.Types import IHP.HSX.QQ (hsx) -import qualified Text.Blaze.Html5 as Html5 +import qualified IHP.HSX.Html as Html5 import IHP.Controller.Context autoRefreshMeta :: (?context :: ControllerContext) => Html5.Html diff --git a/IHP/Breadcrumb/Types.hs b/IHP/Breadcrumb/Types.hs index 15fc6bc4f..909d96fab 100644 --- a/IHP/Breadcrumb/Types.hs +++ b/IHP/Breadcrumb/Types.hs @@ -1,8 +1,8 @@ module IHP.Breadcrumb.Types where import IHP.Prelude -import Text.Blaze.Html (Html) -import Text.Blaze.Html.Renderer.String (renderHtml) +import IHP.HSX.Html (Html) +import IHP.HSX.Html (renderHtml) import ClassyPrelude data BreadcrumbItem = diff --git a/IHP/Breadcrumb/ViewFunctions.hs b/IHP/Breadcrumb/ViewFunctions.hs index 3aaced023..e2ed0687d 100644 --- a/IHP/Breadcrumb/ViewFunctions.hs +++ b/IHP/Breadcrumb/ViewFunctions.hs @@ -11,7 +11,7 @@ import IHP.Breadcrumb.Types import IHP.ControllerSupport -import Text.Blaze.Html (Html) +import IHP.HSX.Html (Html) import IHP.View.Types (BreadcrumbsView(..), styledBreadcrumb, styledBreadcrumbItem) import IHP.ViewSupport (theCSSFramework) diff --git a/IHP/Controller/AccessDenied.hs b/IHP/Controller/AccessDenied.hs index abe1c9c9f..6e3a87277 100644 --- a/IHP/Controller/AccessDenied.hs +++ b/IHP/Controller/AccessDenied.hs @@ -18,7 +18,7 @@ import IHP.HSX.QQ (hsx) import qualified System.Directory as Directory import IHP.Controller.Context import IHP.Controller.Response (respondAndExit) - +import qualified IHP.HSX.Html as HSX -- | Stops the action execution with an access denied message (403) when the access condition is True. -- @@ -63,7 +63,7 @@ buildAccessDeniedResponse = do -- | The default IHP 403 not found page defaultAccessDeniedResponse :: Response -defaultAccessDeniedResponse = responseBuilder status403 [(hContentType, "text/html")] $ Blaze.renderHtmlBuilder [hsx| +defaultAccessDeniedResponse = responseBuilder status403 [(hContentType, "text/html")] $ HSX.renderHtmlBuilder [hsx| diff --git a/IHP/Controller/NotFound.hs b/IHP/Controller/NotFound.hs index 0d81a41e2..3b3930513 100644 --- a/IHP/Controller/NotFound.hs +++ b/IHP/Controller/NotFound.hs @@ -18,6 +18,7 @@ import IHP.HSX.QQ (hsx) import qualified System.Directory as Directory import IHP.Controller.Context import IHP.Controller.Response (respondAndExit) +import qualified IHP.HSX.Html as HSX -- | Stops the action execution with a not found message (404) when the access condition is True. @@ -64,7 +65,7 @@ buildNotFoundResponse = do -- | The default IHP 404 not found page defaultNotFoundResponse :: Response -defaultNotFoundResponse = responseBuilder status404 [(hContentType, "text/html")] $ Blaze.renderHtmlBuilder [hsx| +defaultNotFoundResponse = responseBuilder status404 [(hContentType, "text/html")] $ HSX.renderHtmlBuilder [hsx| diff --git a/IHP/Controller/Render.hs b/IHP/Controller/Render.hs index 7c36aef88..eaa40dfa1 100644 --- a/IHP/Controller/Render.hs +++ b/IHP/Controller/Render.hs @@ -12,8 +12,8 @@ import IHP.ControllerSupport import qualified Network.HTTP.Media as Accept import qualified Data.List as List -import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze -import Text.Blaze.Html (Html) +import qualified IHP.HSX.Html as Blaze +import IHP.HSX.Html (Html) import qualified IHP.Controller.Context as Context import IHP.Controller.Layout import qualified IHP.FrameworkConfig as FrameworkConfig diff --git a/IHP/ErrorController.hs b/IHP/ErrorController.hs index edf3625b7..ce5d00c6c 100644 --- a/IHP/ErrorController.hs +++ b/IHP/ErrorController.hs @@ -20,8 +20,8 @@ import Network.HTTP.Types (status500, status400) import Network.Wai import Network.HTTP.Types.Header -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze +import qualified IHP.HSX.Html as H +import qualified IHP.HSX.Html as Blaze import qualified Database.PostgreSQL.Simple as PG import qualified Data.ByteString.Char8 as ByteString @@ -401,7 +401,7 @@ handleRouterException exception request respond =

Possible Solutions

Are you trying to do a DELETE action, but your link is missing class="js-delete"?

|] - let title = H.text "Routing failed" + let title = "Routing failed" respond $ responseBuilder status500 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) diff --git a/IHP/FlashMessages/ViewFunctions.hs b/IHP/FlashMessages/ViewFunctions.hs index 8ef6fca18..b7a65091a 100644 --- a/IHP/FlashMessages/ViewFunctions.hs +++ b/IHP/FlashMessages/ViewFunctions.hs @@ -6,7 +6,7 @@ Copyright: (c) digitally induced GmbH, 2020 module IHP.FlashMessages.ViewFunctions where import IHP.FlashMessages.Types -import qualified Text.Blaze.Html5 as Html5 +import qualified IHP.HSX.Html as Html5 import IHP.ViewSupport import IHP.View.Types import IHP.Controller.Context diff --git a/IHP/Modal/Types.hs b/IHP/Modal/Types.hs index 5d4a5854c..b52dde0a5 100644 --- a/IHP/Modal/Types.hs +++ b/IHP/Modal/Types.hs @@ -8,7 +8,7 @@ module IHP.Modal.Types ) where import IHP.Prelude -import Text.Blaze.Html5 (Html) +import IHP.HSX.Html (Html) data Modal = Modal { modalContent :: Html diff --git a/IHP/Modal/ViewFunctions.hs b/IHP/Modal/ViewFunctions.hs index dc908db0e..5f6be2f6a 100644 --- a/IHP/Modal/ViewFunctions.hs +++ b/IHP/Modal/ViewFunctions.hs @@ -9,7 +9,7 @@ import IHP.Prelude import IHP.Controller.Context import IHP.HSX.QQ (hsx) import IHP.Modal.Types -import Text.Blaze.Html5 (Html) +import IHP.HSX.Html (Html) renderModal modal = renderModal' modal True renderModal' Modal { .. } show = [hsx| diff --git a/IHP/PageHead/ViewFunctions.hs b/IHP/PageHead/ViewFunctions.hs index 00e108b8c..faf60b652 100644 --- a/IHP/PageHead/ViewFunctions.hs +++ b/IHP/PageHead/ViewFunctions.hs @@ -21,7 +21,7 @@ import IHP.PageHead.Types import IHP.Controller.Context import IHP.PageHead.ControllerFunctions import IHP.HSX.QQ (hsx) -import Text.Blaze.Html5 (Html) +import IHP.HSX.Html (Html) -- | Returns the current page title. The title can be set using @setTitle "my title"@ from the action. -- diff --git a/IHP/Pagination/ViewFunctions.hs b/IHP/Pagination/ViewFunctions.hs index 1cb99bb0b..966726a31 100644 --- a/IHP/Pagination/ViewFunctions.hs +++ b/IHP/Pagination/ViewFunctions.hs @@ -10,7 +10,7 @@ import IHP.Pagination.Helpers import IHP.ControllerSupport -import Text.Blaze.Html (Html) +import IHP.HSX.Html (Html) import IHP.HSX.QQ (hsx) import IHP.Controller.Param (paramOrNothing) diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 863d8a7a6..91257ed51 100644 --- a/IHP/RouterSupport.hs +++ b/IHP/RouterSupport.hs @@ -55,6 +55,8 @@ import qualified Data.ByteString.Char8 as ByteString import qualified Data.Char as Char import Control.Monad.Fail import Data.String.Conversions (ConvertibleStrings (convertString), cs) +import qualified IHP.HSX.ToHtml as HSX +import qualified IHP.HSX.Attribute as HSX import qualified Text.Blaze.Html5 as Html5 import qualified IHP.ErrorController as ErrorController import qualified Control.Exception as Exception @@ -879,9 +881,9 @@ catchAll action = do {-# INLINABLE catchAll #-} -- | This instances makes it possible to write @@ in HSX -instance {-# OVERLAPPABLE #-} (HasPath action) => ConvertibleStrings action Html5.AttributeValue where - convertString action = Html5.textValue (pathTo action) - {-# INLINE convertString #-} +instance {-# OVERLAPPABLE #-} (HasPath action) => HSX.AttributeConverter action where + attributeValueToText name action = HSX.attributeValueToText name (pathTo action) + {-# INLINE attributeValueToText #-} -- | Parses and returns an UUID parseUUID :: Parser UUID diff --git a/IHP/View/CSSFramework.hs b/IHP/View/CSSFramework.hs index 45fcbb77d..18b0a2566 100644 --- a/IHP/View/CSSFramework.hs +++ b/IHP/View/CSSFramework.hs @@ -7,7 +7,7 @@ module IHP.View.CSSFramework where import IHP.Prelude import IHP.FlashMessages.Types -import qualified Text.Blaze.Html5 as Blaze +import qualified IHP.HSX.Html as Blaze import IHP.HSX.QQ (hsx) import IHP.HSX.ToHtml () import IHP.View.Types diff --git a/IHP/View/Form.hs b/IHP/View/Form.hs index 5114fd565..51f0eae0e 100644 --- a/IHP/View/Form.hs +++ b/IHP/View/Form.hs @@ -16,7 +16,7 @@ import IHP.ValidationSupport import IHP.HSX.ConvertibleStrings () import IHP.ViewErrorMessages () import IHP.ViewSupport -import qualified Text.Blaze.Html5 as Html5 +import qualified IHP.HSX.Html as Html5 import IHP.HSX.ToHtml import GHC.Types import IHP.ModelSupport (getModelName, inputValue, isNew, Id', InputValue, didTouchField) @@ -312,7 +312,7 @@ submitButton = buttonText = modelName |> humanize -- We do this to turn 'Create ProjectTask' into 'Create Project Task' isNew = IHP.ModelSupport.isNew (model ?formContext) in SubmitButton - { label = cs $ (if isNew then "Create " else "Save ") <> buttonText + { label = Html5.textToHtml $ (if isNew then "Create " else "Save ") <> buttonText , buttonClass = mempty , buttonDisabled = False , cssFramework = ?formContext.cssFramework diff --git a/IHP/View/Types.hs b/IHP/View/Types.hs index a13f1b285..b121051c3 100644 --- a/IHP/View/Types.hs +++ b/IHP/View/Types.hs @@ -19,7 +19,7 @@ module IHP.View.Types where import IHP.Prelude hiding (div) -import qualified Text.Blaze.Html5 as Blaze +import qualified IHP.HSX.Html as Blaze import IHP.FlashMessages.Types import IHP.ModelSupport (Violation) import IHP.Breadcrumb.Types diff --git a/IHP/ViewPrelude.hs b/IHP/ViewPrelude.hs index 0e8f37eeb..b943c3c87 100644 --- a/IHP/ViewPrelude.hs +++ b/IHP/ViewPrelude.hs @@ -13,7 +13,6 @@ module IHP.ViewPrelude ( hsx, toHtml, preEscapedToHtml, - preEscapedTextValue, module IHP.ValidationSupport, pathTo, urlTo, @@ -42,7 +41,7 @@ import IHP.Prelude import IHP.ViewErrorMessages () import IHP.ViewSupport import Text.Blaze (stringValue, (!)) -import Text.Blaze.Html5 (preEscapedToHtml, preEscapedTextValue) +import IHP.HSX.Html (preEscapedToHtml) import IHP.View.Form import IHP.HSX.QQ (hsx) import IHP.HSX.ToHtml diff --git a/IHP/ViewSupport.hs b/IHP/ViewSupport.hs index e902e3a06..c757b59aa 100644 --- a/IHP/ViewSupport.hs +++ b/IHP/ViewSupport.hs @@ -19,7 +19,6 @@ module IHP.ViewSupport , onLoad , theRequest , viewContext -, addStyle , ViewFetchHelpMessage , param , fetch @@ -34,7 +33,7 @@ module IHP.ViewSupport ) where import IHP.Prelude -import qualified Text.Blaze.Html5 as Html5 +import qualified IHP.HSX.Html as Html5 import IHP.ControllerSupport import IHP.ModelSupport import qualified Data.Aeson as JSON @@ -56,6 +55,7 @@ import IHP.View.Types import qualified IHP.FrameworkConfig as FrameworkConfig import IHP.Controller.Context import qualified IHP.HSX.Attribute as HSX +import qualified IHP.HSX.Html as HSX class View theView where -- | Hook which is called before the render is called @@ -200,25 +200,6 @@ viewContext :: (?context :: ControllerContext) => ControllerContext viewContext = ?context {-# INLINE viewContext #-} --- | Adds an inline style element to the html. --- --- This helps to work around the issue, that our HSX parser cannot deal with CSS yet. --- --- __Example:__ --- --- > myStyle = addStyle "#my-div { color: blue; }" --- > [hsx|{myStyle}
Hello World
|] --- --- This will render like: --- --- > --- >
Hello World
-addStyle :: (ConvertibleStrings string Text) => string -> Html5.Markup -addStyle style = Html5.style (Html5.preEscapedText (cs style)) -{-# INLINE addStyle #-} - -- | This class provides helpful compile-time error messages when you use common -- controller functions inside of your views. class ViewParamHelpMessage where @@ -253,7 +234,7 @@ nl2br :: (Sequences.Textual text, ToHtml text) => text -> Html5.Html nl2br content = content |> Sequences.lines |> map (\line -> [hsx|{line}
|]) - |> mconcat + |> HSX.concat type Html = HtmlWithContext ControllerContext @@ -263,5 +244,5 @@ liveReloadWebsocketUrl = ?context.frameworkConfig.ideBaseUrl |> Text.replace "http://" "ws://" |> Text.replace "https://" "wss://" -instance InputValue (PrimaryKey table) => HSX.ApplyAttribute (Id' table) where - applyAttribute attr attr' value h = HSX.applyAttribute attr attr' (inputValue value) h \ No newline at end of file +instance InputValue (PrimaryKey table) => HSX.AttributeConverter (Id' table) where + attributeValueToText name value = HSX.attributeValueToText name (inputValue value) \ No newline at end of file diff --git a/IHP/Welcome/Controller.hs b/IHP/Welcome/Controller.hs index 563280437..99e4ad2c0 100644 --- a/IHP/Welcome/Controller.hs +++ b/IHP/Welcome/Controller.hs @@ -60,6 +60,6 @@ renderLayout view = [hsx| bodyStyle :: Text bodyStyle = "margin: 0; font-family: -apple-system, BlinkMacSystemFont, \"Segoe UI\", \"Roboto\", \"Helvetica Neue\", Arial, sans-serif;" -icon = preEscapedToHtml [plain| +icon = preEscapedToHtml [trimming| experience design |] diff --git a/NixSupport/haskell-packages/ihp-hsx.nix b/NixSupport/haskell-packages/ihp-hsx.nix index 3e1559116..5061911aa 100644 --- a/NixSupport/haskell-packages/ihp-hsx.nix +++ b/NixSupport/haskell-packages/ihp-hsx.nix @@ -12,6 +12,8 @@ , haskell-src-meta , containers , unordered-containers +, hspec +, binary }: mkDerivation { pname = "ihp-hsx"; @@ -31,6 +33,21 @@ mkDerivation { template-haskell containers unordered-containers + binary + ]; + testHaskellDepends = [ + classy-prelude + string-conversions + blaze-html + blaze-markup + text + bytestring + basic-prelude + megaparsec + template-haskell + containers + unordered-containers + hspec ]; license = lib.licenses.mit; enableLibraryForGhci = true; diff --git a/Test/Main.hs b/Test/Main.hs index c6b52477c..4a26b94cd 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -27,8 +27,6 @@ import qualified Test.IDE.CodeGeneration.ControllerGenerator import qualified Test.IDE.CodeGeneration.ViewGenerator import qualified Test.IDE.CodeGeneration.MailGenerator import qualified Test.IDE.CodeGeneration.JobGenerator -import qualified Test.HSX.QQSpec -import qualified Test.HSX.ParserSpec import qualified Test.NameSupportSpec import qualified Test.HaskellSupportSpec import qualified Test.View.CSSFrameworkSpec @@ -64,10 +62,8 @@ main = hspec do Test.IDE.CodeGeneration.ViewGenerator.tests Test.IDE.CodeGeneration.MailGenerator.tests Test.IDE.CodeGeneration.JobGenerator.tests - Test.HSX.QQSpec.tests Test.NameSupportSpec.tests Test.HaskellSupportSpec.tests - Test.HSX.ParserSpec.tests Test.View.CSSFrameworkSpec.tests Test.View.FormSpec.tests Test.Controller.ContextSpec.tests diff --git a/Test/View/CSSFrameworkSpec.hs b/Test/View/CSSFrameworkSpec.hs index 945defe00..cb542d2ec 100644 --- a/Test/View/CSSFrameworkSpec.hs +++ b/Test/View/CSSFrameworkSpec.hs @@ -14,8 +14,8 @@ import IHP.View.Types import IHP.View.CSSFramework import IHP.FlashMessages.Types import IHP.Controller.Session -import qualified Text.Blaze.Renderer.Text as Blaze -import qualified Text.Blaze.Html5 as H +import qualified IHP.HSX.Html as Blaze +import qualified IHP.HSX.Html as H import IHP.HSX.QQ (hsx) import IHP.ModelSupport import IHP.Breadcrumb.Types diff --git a/Test/View/FormSpec.hs b/Test/View/FormSpec.hs index 75532c411..17a834c28 100644 --- a/Test/View/FormSpec.hs +++ b/Test/View/FormSpec.hs @@ -7,7 +7,7 @@ module Test.View.FormSpec where import Test.Hspec import IHP.FrameworkConfig as FrameworkConfig import IHP.Controller.RequestContext -import qualified Text.Blaze.Renderer.Text as Blaze +import qualified IHP.HSX.Html as Blaze import IHP.ModelSupport import qualified Network.Wai as Wai import IHP.ViewPrelude diff --git a/Test/ViewSupportSpec.hs b/Test/ViewSupportSpec.hs index 191bda6e8..57dfa2b35 100644 --- a/Test/ViewSupportSpec.hs +++ b/Test/ViewSupportSpec.hs @@ -31,6 +31,7 @@ import Data.String.Conversions import Data.Text as Text import Unsafe.Coerce import IHP.ApplicationContext +import qualified IHP.HSX.Html as HSX import qualified Network.Wai.Session as Session import qualified Network.Wai.Session.Map as Session @@ -134,6 +135,6 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do id :: Id' "users" id = Id ("70a10b53-a776-470a-91a8-900cdda06aa2" :: UUID) - (ClassyPrelude.tshow [hsx||]) `shouldBe` "" + (HSX.renderHtml [hsx||]) `shouldBe` "" type instance PrimaryKey "users" = UUID \ No newline at end of file diff --git a/ihp-ide/IHP/IDE/Data/View/EditValue.hs b/ihp-ide/IHP/IDE/Data/View/EditValue.hs index 520b35bd2..1129a2f68 100644 --- a/ihp-ide/IHP/IDE/Data/View/EditValue.hs +++ b/ihp-ide/IHP/IDE/Data/View/EditValue.hs @@ -52,7 +52,7 @@ instance View EditValueView where |] renderField id DynamicField { .. } | fieldName == "id" = [hsx|{renderId (sqlValueToText fieldValue)}|] renderField id DynamicField { .. } = [hsx|{sqlValueToText fieldValue}|] - script = preEscapedToHtml [plain| + script = preEscapedToHtml $ cs [plain| diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs index 057253439..68905e35d 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs @@ -66,11 +66,12 @@ instance View NewForeignKeyView where {select2} |] where + onDeleteSelector :: Text -> Html onDeleteSelector option = if option == "NoAction" - then preEscapedToHtml [plain||] - else preEscapedToHtml [plain||] + then [hsx||] + else [hsx||] renderTableNameSelector tableName = [hsx||] - select2 = preEscapedToHtml [plain| + select2 = [hsx| diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs index 2105f17cc..c4eb72444 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -97,7 +97,7 @@ migrationStatus = if hasPendingMigrations |] migrationStatusIcon :: Html - migrationStatusIcon = preEscapedToHtml [plain| + migrationStatusIcon = preEscapedToHtml [trimming| @@ -725,31 +725,31 @@ replace i e xs = case List.splitAt i xs of (a, b) -> a ++ b -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/schemas/tables/static/img/table.svg -tableIcon = preEscapedToHtml [plain|table|] +tableIcon = preEscapedToHtml [trimming|table|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/schemas/types/static/img/type.svg -enumIcon = preEscapedToHtml [plain|type|] +enumIcon = preEscapedToHtml [trimming|type|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/schemas/tables/indexes/static/img/index.svg -indexIcon = preEscapedToHtml [plain|index|] +indexIcon = preEscapedToHtml [trimming|index|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/schemas/tables/constraints/index_constraint/static/img/unique_constraint.svg -uniqueIndexIcon = preEscapedToHtml [plain|unique index1|] +uniqueIndexIcon = preEscapedToHtml [trimming|unique index1|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/schemas/tables/constraints/check_constraint/static/img/check-constraint.svg -constraintIcon = preEscapedToHtml [plain|constraint|] +constraintIcon = preEscapedToHtml [trimming|constraint|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/languages/static/img/language.svg -commentIcon = preEscapedToHtml [plain|comment|] +commentIcon = preEscapedToHtml [trimming|comment|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/extensions/static/img/extension.svg -extensionIcon = preEscapedToHtml [plain|extension|] +extensionIcon = preEscapedToHtml [trimming|extension|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/browser/server_groups/servers/databases/schemas/functions/static/img/function.svg -functionIcon = preEscapedToHtml [plain|function|] +functionIcon = preEscapedToHtml [trimming|function|] -- | https://github.com/postgres/pgadmin4/blob/master/web/pgadmin/misc/static/explain/img/ex_unknown.svg -unknownIcon = preEscapedToHtml [plain|unknown|] +unknownIcon = preEscapedToHtml [trimming|unknown|] -- | https://fonts.google.com/icons?icon.query=shield -shieldIcon = preEscapedToHtml [plain||] +shieldIcon = preEscapedToHtml [trimming||] diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Migrations/Index.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Migrations/Index.hs index 475b045ec..f66b706b6 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Migrations/Index.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Migrations/Index.hs @@ -114,7 +114,8 @@ code _ src = [hsx| |] -checkmark = preEscapedToHtml [plain| +checkmark :: Html +checkmark = preEscapedToHtml [trimming| diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/Code.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/Code.hs index 9239fdaa0..baf70b0be 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/Code.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/Code.hs @@ -26,8 +26,8 @@ instance View CodeView where submitUrl = pathTo SaveCodeAction errorDiv = case error of Nothing -> mempty - Just error -> preEscapedToHtml [plain| + Just error -> [hsx|
- 
#{error}
+ 
{error}
|] diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/GeneratedCode.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/GeneratedCode.hs index cd1dd61fb..e6efd2c5d 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/GeneratedCode.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Schema/GeneratedCode.hs @@ -29,7 +29,7 @@ instance View GeneratedCodeView where modalCloseUrl = pathTo TablesAction modalTitle = "Generated Haskell Code" modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle } - customCss = preEscapedToHtml [plain| + customCss = [hsx|