diff --git a/IHP/HSX/ConvertibleStrings.hs b/IHP/HSX/ConvertibleStrings.hs
new file mode 100644
--- /dev/null
+++ b/IHP/HSX/ConvertibleStrings.hs
@@ -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
diff --git a/IHP/HSX/Parser.hs b/IHP/HSX/Parser.hs
new file mode 100644
--- /dev/null
+++ b/IHP/HSX/Parser.hs
@@ -0,0 +1,632 @@
+{-# 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
+) 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 Control.Monad.Fail
+import Data.String.Conversions
+import qualified Data.List as List
+import Control.Monad (unless)
+import Prelude (show)
+import qualified Language.Haskell.Meta as Haskell
+import qualified Language.Haskell.TH.Syntax as Haskell
+import qualified "template-haskell" Language.Haskell.TH as TH
+import qualified Data.Set as Set
+import qualified Data.Containers.ListUtils as List
+
+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
+ 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 = "Hello"
+-- >
+-- > let (Right node) = parseHsx position hsxText
+parseHsx :: SourcePos -> Text -> Either (ParseErrorBundle Text Void) Node
+parseHsx position code = runParser (setPosition position *> parser) "" code
+
+type Parser = Parsec Void Text
+
+setPosition pstateSourcePos = updateParserState (\state -> state {
+ statePosState = (statePosState state) { pstateSourcePos }
+ })
+
+parser :: Parser Node
+parser = do
+ space
+ node <- manyHsxElement <|> hsxElement
+ space
+ eof
+ pure node
+
+hsxElement = try hsxComment <|> try hsxSelfClosingElement <|> hsxNormalElement
+
+manyHsxElement = do
+ children <- many hsxChild
+ pure (Children (stripTextNodeWhitespaces children))
+
+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 = do
+ (name, attributes) <- hsxOpeningElement
+ let parsePreEscapedTextChildren transformText = do
+ let closingElement = " name <> ">"
+ text <- cs <$> manyTill anySingle (string closingElement)
+ pure [PreEscapedTextNode (transformText text)]
+ let parseNormalHSXChildren = stripTextNodeWhitespaces <$> (space >> (manyTill (try hsxChild) (try (space >> hsxClosingElement name))))
+
+ -- script and style tags have special handling for their children. Inside those tags
+ -- we allow any kind of content. Using a haskell expression like @@
+ -- will just literally output the string @{myHaskellExpr}@ without evaluating the haskell expression itself.
+ --
+ -- Here is an example HSX code explaining the problem:
+ -- [hsx||]
+ -- The @{ color: red; }@ would be parsed as a inline haskell expression without the special handling
+ --
+ -- Additionally we don't do the usual escaping for style and script bodies, as this will make e.g. the
+ -- javascript unusuable.
+ children <- case name of
+ "script" -> parsePreEscapedTextChildren Text.strip
+ "style" -> parsePreEscapedTextChildren (collapseSpace . Text.strip)
+ otherwise -> parseNormalHSXChildren
+ pure (Node name attributes children False)
+
+hsxOpeningElement = do
+ char '<'
+ name <- hsxElementName
+ space
+ attributes <- hsxNodeAttributes (char '>')
+ pure (name, attributes)
+
+hsxComment :: Parser Node
+hsxComment = do
+ string "")
+ space
+ pure (CommentNode (cs body))
+
+
+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
+ name <- between (string "{...") (string "}") (takeWhile1P Nothing (\c -> c /= '}'))
+ space
+ haskellExpression <- case Haskell.parseExp (cs name) of
+ Right expression -> pure (patchExpr expression)
+ Left error -> fail (show error)
+ pure (SpreadAttributes haskellExpression)
+
+hsxNodeAttribute = do
+ key <- hsxAttributeName
+ space
+
+ -- Boolean attributes like will be represented as
+ -- as there is currently no other way to represent them with blaze-html.
+ --
+ -- There's a special case for data attributes: Data attributes like will be represented as
+ --
+ -- 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
+ let attributeWithValue = do
+ _ <- char '='
+ space
+ value <- hsxQuotedValue <|> hsxSplicedValue
+ space
+ pure (StaticAttribute key value)
+
+ attributeWithValue <|> attributeWithoutValue
+
+
+hsxAttributeName :: Parser Text
+hsxAttributeName = do
+ name <- rawAttribute
+ unless (isValidAttributeName name) (fail $ "Invalid attribute name: " <> cs name)
+ pure name
+ where
+ isValidAttributeName name =
+ "data-" `Text.isPrefixOf` name
+ || "aria-" `Text.isPrefixOf` name
+ || "hx-" `Text.isPrefixOf` name
+ || "hx-" `Text.isPrefixOf` name
+ || name `Set.member` attributes
+
+ rawAttribute = takeWhile1P Nothing (\c -> Char.isAlphaNum c || c == '-')
+
+
+hsxQuotedValue :: Parser AttributeValue
+hsxQuotedValue = do
+ value <- between (char '"') (char '"') (takeWhileP Nothing (\c -> c /= '\"'))
+ pure (TextValue value)
+
+hsxSplicedValue :: Parser AttributeValue
+hsxSplicedValue = do
+ value <- between (char '{') (char '}') (takeWhile1P Nothing (\c -> c /= '}'))
+ haskellExpression <- case Haskell.parseExp (cs value) of
+ Right expression -> pure (patchExpr expression)
+ Left error -> fail (show error)
+ pure (ExpressionValue haskellExpression)
+
+hsxClosingElement name = (hsxClosingElement' name) friendlyErrorMessage
+ where
+ friendlyErrorMessage = show (Text.unpack (" name <> ">"))
+ hsxClosingElement' name = do
+ _ <- string (" name)
+ space
+ char ('>')
+ pure ()
+
+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
+ expression <- doParse
+ haskellExpression <- case Haskell.parseExp (cs expression) of
+ Right expression -> pure (patchExpr expression)
+ Left error -> fail (show error)
+ pure (SplicedNode haskellExpression)
+ where
+ doParse = do
+ tree <- node
+ let value = (treeToString "" tree)
+ pure $ Text.init $ Text.tail value
+
+ parseTree = node <|> leaf
+ node = TokenNode <$> between (char '{') (char '}') (many parseTree)
+ 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 == '-')
+ let isValidParent = name `Set.member` parents
+ let isValidLeaf = name `Set.member` leafs
+ let isValidCustomWebComponent = "-" `Text.isInfixOf` name
+ unless (isValidParent || isValidLeaf || isValidCustomWebComponent) (fail $ "Invalid tag name: " <> cs name)
+ space
+ pure name
+
+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"
+ ]
+
+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"
+ ]
+
+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 = []
+
+
+patchExpr :: TH.Exp -> TH.Exp
+patchExpr (TH.UInfixE (TH.VarE varName) (TH.VarE hash) (TH.VarE labelValue)) | hash == TH.mkName "#" = TH.AppE (TH.VarE varName) fromLabel
+ where
+ fromLabel = TH.AppTypeE (TH.VarE (TH.mkName "fromLabel")) (TH.LitT (TH.StrTyLit (show labelValue)))
+--- UInfixE (UInfixE a (VarE |>) (VarE get)) (VarE #) (VarE firstName)
+patchExpr input@(TH.UInfixE (TH.UInfixE a (TH.VarE arrow) (TH.VarE get)) (TH.VarE hash) (TH.VarE labelValue)) | (hash == TH.mkName "#") && (arrow == TH.mkName "|>") && (get == TH.mkName "get") =
+ (TH.UInfixE (patchExpr a) (TH.VarE arrow) (TH.AppE (TH.VarE get) fromLabel))
+ where
+ fromLabel = TH.AppTypeE (TH.VarE (TH.mkName "fromLabel")) (TH.LitT (TH.StrTyLit (show labelValue)))
+-- UInfixE (UInfixE a (VarE $) (VarE get)) (VarE #) (AppE (VarE id) (VarE checklist))
+patchExpr (TH.UInfixE (TH.UInfixE a b get) (TH.VarE hash) (TH.AppE (TH.VarE labelValue) (TH.VarE d))) | (hash == TH.mkName "#") =
+ TH.UInfixE (patchExpr a) (patchExpr b) (TH.AppE (TH.AppE get fromLabel) (TH.VarE d))
+ where
+ fromLabel = TH.AppTypeE (TH.VarE (TH.mkName "fromLabel")) (TH.LitT (TH.StrTyLit (show labelValue)))
+patchExpr (TH.UInfixE (TH.VarE varName) (TH.VarE hash) (TH.AppE (TH.VarE labelValue) arg)) | hash == TH.mkName "#" = TH.AppE (TH.AppE (TH.VarE varName) fromLabel) arg
+ where
+ fromLabel = TH.AppTypeE (TH.VarE (TH.mkName "fromLabel")) (TH.LitT (TH.StrTyLit (show labelValue)))
+patchExpr (TH.UInfixE (TH.VarE a) (TH.VarE hash) (TH.AppE (TH.VarE labelValue) (TH.VarE b))) | hash == TH.mkName "#" =
+ TH.AppE (TH.AppE (TH.VarE a) fromLabel) (TH.VarE b)
+ where
+ fromLabel = TH.AppTypeE (TH.VarE (TH.mkName "fromLabel")) (TH.LitT (TH.StrTyLit (show labelValue)))
+
+patchExpr (TH.UInfixE a b c) = TH.UInfixE (patchExpr a) (patchExpr b) (patchExpr c)
+patchExpr (TH.ParensE e) = TH.ParensE (patchExpr e)
+patchExpr (TH.RecUpdE a b) = TH.RecUpdE (patchExpr a) b
+patchExpr (TH.AppE a b) = TH.AppE (patchExpr a) (patchExpr b)
+patchExpr (TH.LamE a b) = TH.LamE a (patchExpr b)
+patchExpr (TH.LetE a b) = TH.LetE a' (patchExpr b)
+ where
+ a' = List.map patchDec a
+ patchDec (TH.ValD a (TH.NormalB b) c) = (TH.ValD a (TH.NormalB (patchExpr b)) c)
+ patchDec a = a
+patchExpr (TH.CondE a b c) = TH.CondE (patchExpr a) (patchExpr b) (patchExpr c)
+patchExpr (TH.SigE a b) = TH.SigE (patchExpr a) b
+patchExpr e = e
diff --git a/IHP/HSX/QQ.hs b/IHP/HSX/QQ.hs
new file mode 100644
--- /dev/null
+++ b/IHP/HSX/QQ.hs
@@ -0,0 +1,132 @@
+{-# 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) where
+
+import Prelude
+import qualified Data.Text as Text
+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 Control.Monad.Fail
+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')
+
+hsx :: QuasiQuoter
+hsx = QuasiQuoter {
+ quoteExp = quoteHsxExpression,
+ quotePat = error "quotePat: not defined",
+ quoteDec = error "quoteDec: not defined",
+ quoteType = error "quoteType: not defined"
+ }
+
+quoteHsxExpression :: String -> TH.ExpQ
+quoteHsxExpression code = do
+ hsxPosition <- findHSXPosition
+ expression <- case parseHsx hsxPosition (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 name attributes children isLeaf) =
+ let
+ renderedChildren = TH.listE $ map compileToHaskell children
+ stringAttributes = TH.listE $ map toStringAttribute attributes
+ openTag :: Text
+ openTag = "<" <> tag
+ tag :: Text
+ tag = cs name
+ in
+ if isLeaf
+ then
+ let
+ closeTag :: Text
+ closeTag = ">"
+ in [| (applyAttributes (Leaf (textToStaticString $(TH.lift tag)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) ()) $(stringAttributes)) |]
+ else
+ let
+ closeTag :: Text
+ closeTag = " tag <> ">"
+ in [| (applyAttributes (makeParent (textToStaticString $(TH.lift name)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) $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 |]
+
+
+toStringAttribute :: Attribute -> TH.ExpQ
+toStringAttribute (StaticAttribute name (TextValue value)) = do
+ let nameWithSuffix = " " <> name <> "=\""
+ if Text.null value
+ then [| \h -> h ! ((attribute (Html5.textTag name) (Html5.textTag nameWithSuffix)) mempty) |]
+ else [| \h -> h ! ((attribute (Html5.textTag name) (Html5.textTag nameWithSuffix)) (Html5.preEscapedTextValue value)) |]
+
+toStringAttribute (StaticAttribute name (ExpressionValue expression)) = let nameWithSuffix = " " <> name <> "=\"" in [| applyAttribute name nameWithSuffix $(pure expression) |]
+toStringAttribute (SpreadAttributes expression) = [| spreadAttributes $(pure expression) |]
+
+spreadAttributes :: ApplyAttribute value => [(Text, value)] -> Html5.Html -> Html5.Html
+spreadAttributes attributes html = applyAttributes html $ map (\(name, value) -> applyAttribute name (" " <> name <> "=\"") value) attributes
+
+applyAttributes :: Html5.Html -> [Html5.Html -> Html5.Html] -> Html5.Html
+applyAttributes element attributes = foldl' (\element attribute -> attribute element) element attributes
+{-# INLINE applyAttributes #-}
+
+makeParent :: StaticString -> StaticString -> StaticString -> [Html] -> Html
+makeParent tag openTag closeTag children = Parent tag openTag closeTag (mconcat children)
+{-# INLINE makeParent #-}
+
+textToStaticString :: Text -> StaticString
+textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 text) text
+{-# INLINE textToStaticString #-}
+
+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
+
+instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where
+ applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') (cs value))
+ {-# INLINE applyAttribute #-}
+
+instance Show (MarkupM ()) where
+ show html = BlazeString.renderHtml html
diff --git a/IHP/HSX/ToHtml.hs b/IHP/HSX/ToHtml.hs
new file mode 100644
--- /dev/null
+++ b/IHP/HSX/ToHtml.hs
@@ -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
+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)
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2020 digitally induced GmbH
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,406 @@
+# HSX
+
+This `ihp-hsx` package provides `[hsx|
Hello World
|]` syntax to IHP projects.
+
+To use it outside of IHP, add this package to your cabal file and use the modules like this:
+
+```haskell
+import IHP.HSX.QQ -- <- The main thing
+import IHP.HSX.ConvertibleStrings () -- <- Helper instancess
+import IHP.HSX.ToHtml () -- <- More helper instances
+
+import Text.Blaze.Html5 -- The blaze html library, IHP HSX is built on top of that
+
+view :: Html
+view = [hsx|
+
Hello World
+|]
+
+-- To render the above view:
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+rendered :: Text
+rendered = renderHtml view
+```
+
+## Introduction
+
+HSX can be written pretty much like normal HTML. You can write an HSX expression inside your Haskell code by wrapping it with [`[hsx|YOUR HSX CODE|]`](https://ihp.digitallyinduced.com/api-docs/IHP-ViewPrelude.html#v:hsx). HSX expressions are just a syntax for [BlazeHtml](https://jaspervdj.be/blaze/) and thus are automatically escaped as described in the blaze documentation.
+
+Because the HSX is parsed, you will get a syntax error when you type in invalid HTML.
+
+### Inline Haskell
+
+HSX can access Haskell variables wrapped with `{}` like this:
+
+```haskell
+let
+ x :: Text = "World"
+in
+ [hsx|Hello {x}!|]
+```
+
+**If the variable is another HSX expression, a blaze HTML element, a text or string**: it is just included as you would expect.
+
+**If the variable is any other custom Haskell data structure**: it will first be converted to a string representation by calling [`show`](https://ihp.digitallyinduced.com/api-docs/IHP-Prelude.html#v:show) on it. You can add a custom [`ToHtml`](https://ihp.digitallyinduced.com/api-docs/IHP-HSX-ToHtml.html#t:ToHtml) (import it from `IHP.HSX.ToHtml`) instance, to customize rendering a data structure.
+
+You can also write more complex code like:
+
+```haskell
+let
+ items :: [Int] = [ 0, 1, 2 ]
+ renderItem n = [hsx|Hello {n}!|]
+in
+ [hsx|Complex demo: {forEach items renderItem}!|]
+```
+
+As the HSX expressions are compiled to Haskell code at compile-time, type errors inside these `{}` expressions will be reported to you by the compiler.
+
+### Dynamic Attributes
+
+The variable syntax can also be used in attribute values:
+
+```haskell
+let
+ inputValue = "Hello World" :: Text
+in
+ [hsx||]
+```
+
+#### Boolean Attribute Values
+
+HSX has special handling for Boolean values to make it easy to deal with HTML Boolean attributes like `disabled`, `readonly`, `checked`, etc.
+
+You can write
+
+```haskell
+
+```
+
+as a short form for:
+
+```haskell
+
+```
+
+Writing `False`:
+
+```haskell
+
+```
+
+This will not render the attribute, [as specified in the HTML standard](https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes):
+
+```haskell
+
+```
+
+#### Boolean data attributes
+
+This behavior of omiting a attribute when it's set to `False` does not apply to `data-` attributes.
+
+You can write
+
+```haskell
+
+```
+
+When set to `False`, like this:
+
+```haskell
+
+```
+
+#### Maybe Attribute Values / Optional Attributes
+
+HSX has special handling for Maybe values to make it easy to deal with optional attributes.
+
+You can write
+
+```haskell
+let
+ target :: Maybe Text
+ target = Just "_blank"
+in
+ [hsx||]
+```
+
+and it will render to:
+
+```haskell
+
+```
+
+Using `Nothing` results in the `target` attribute not being in the output HTML:
+
+```haskell
+let
+ target :: Maybe Text
+ target = Nothing
+in
+ [hsx||]
+```
+
+This will render to:
+
+```haskell
+
+```
+
+### Spread Values
+
+For dynamic use cases you can use `{...attributeList}`:
+
+```haskell
+
+
tshow userId, tshow userFirstname) ] } />
+
+```
+
+Note the `<>` concatenation operator.
+
+### Special Elements: `
+
+
+
+
+
+
+```
+
+Inside those tags using a Haskell expression will not work:
+
+```haskell
+
+```
+
+This will just literally output the string `{myHaskellExpr}` without evaluating the Haskell expression itself. This is because JavaScript usually uses `{}` for object expressions like `{ a: "hello" }`. The same applies to inline CSS inside `