diff --git a/ihp-hsx/IHP/HSX/QQ.hs b/ihp-hsx/IHP/HSX/QQ.hs index a064f2fb4..7b4cf7ddf 100644 --- a/ihp-hsx/IHP/HSX/QQ.hs +++ b/ihp-hsx/IHP/HSX/QQ.hs @@ -5,7 +5,7 @@ Module: IHP.HSX.QQ Description: Defines the @[hsx||]@ syntax Copyright: (c) digitally induced GmbH, 2022 -} -module IHP.HSX.QQ (hsx) where +module IHP.HSX.QQ (hsx, uncheckedHsx) where import Prelude import Data.Text (Text) @@ -27,6 +27,7 @@ import Data.List (foldl') import IHP.HSX.Attribute import qualified Text.Blaze.Html5.Attributes as Attributes import qualified Data.HashMap.Strict as HashMap +import IHP.HSX.UncheckedHSX (uncheckedHsx) hsx :: QuasiQuoter hsx = QuasiQuoter { @@ -459,3 +460,4 @@ textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 te instance Show (MarkupM ()) where show html = BlazeString.renderHtml html + diff --git a/ihp-hsx/IHP/HSX/UncheckedHSX.hs b/ihp-hsx/IHP/HSX/UncheckedHSX.hs index dd0c731ae..f8c91ca0e 100644 --- a/ihp-hsx/IHP/HSX/UncheckedHSX.hs +++ b/ihp-hsx/IHP/HSX/UncheckedHSX.hs @@ -13,7 +13,18 @@ import Text.Megaparsec import Text.Megaparsec.Char import Data.Void import Data.String.Conversions (cs) -import qualified Data.Set as Set +import qualified IHP.HSX.HaskellParser as HaskellParser +import Text.Blaze.Internal (MarkupM(Parent, Leaf), attribute) +import qualified Data.List.NonEmpty as NE + +type Parser = Parsec Void Text + +data UNode = UNode Text [(Text, AttributeValue)] [UNode] Bool + | UTextNode Text + | USplicedNode Exp + deriving (Show) + +data AttributeValue = TextValue Text | ExpressionValue Exp deriving (Show) uncheckedHsx :: QuasiQuoter uncheckedHsx = QuasiQuoter @@ -27,89 +38,76 @@ quoteUncheckedHsxExpression :: String -> Q Exp quoteUncheckedHsxExpression code = do loc <- location let position = SourcePos (loc_filename loc) (mkPos (fst (loc_start loc))) (mkPos (snd (loc_start loc))) - case runParser uncheckedParser "" (cs code) of + extensions <- extsEnabled + case runParser (uncheckedParser extensions) "" (cs code) of Left err -> fail $ errorBundlePretty err Right result -> compileToHaskell result -type Parser = Parsec Void Text - -data UNode = UNode Text [(Text, Text)] [UNode] Bool - | UTextNode Text - | USplicedNode Exp - deriving (Show) - -uncheckedParser :: Parser UNode -uncheckedParser = space *> (manyUncheckedElement <|> uncheckedElement) <* space <* eof +uncheckedParser :: [Extension] -> Parser UNode +uncheckedParser extensions = space *> manyUncheckedElement <* eof manyUncheckedElement :: Parser UNode manyUncheckedElement = do - children <- many uncheckedChild + children <- many (try uncheckedElement <|> uncheckedTextNode <|> uncheckedSplicedNode) return $ UNode "div" [] children False uncheckedElement :: Parser UNode uncheckedElement = do char '<' - tagName <- some (alphaNumChar <|> char '-' <|> char '_') + tagName <- some (alphaNumChar <|> char '-' <|> char '_' <|> char ':') attrs <- many uncheckedAttribute space (do string "/>" return $ UNode (T.pack tagName) attrs [] True) <|> (do char '>' - children <- many uncheckedChild - string "' - return $ UNode (T.pack tagName) attrs children False) - <|> - (do char '>' - if tagName `Set.member` selfClosingTags - then return $ UNode (T.pack tagName) attrs [] True - else do - children <- many uncheckedChild - string "' - return $ UNode (T.pack tagName) attrs children False) + children <- many (try uncheckedElement <|> uncheckedTextNode <|> uncheckedSplicedNode) + closing <- optional (try $ string "> string (T.pack tagName) >> char '>') + case closing of + Just _ -> return $ UNode (T.pack tagName) attrs children False + Nothing -> return $ UNode (T.pack tagName) attrs children True) -uncheckedAttribute :: Parser (Text, Text) +uncheckedAttribute :: Parser (Text, AttributeValue) uncheckedAttribute = do space - name <- some (alphaNumChar <|> char '-' <|> char '_') - value <- option "" (char '=' *> (quoted <|> unquoted)) - return (T.pack name, T.pack value) + name <- some (alphaNumChar <|> char '-' <|> char '_' <|> char ':') + value <- option (TextValue "") (char '=' *> (quotedValue <|> unquotedValue <|> expressionValue)) + return (T.pack name, value) where - quoted = char '"' *> manyTill anySingle (char '"') - unquoted = some (alphaNumChar <|> char '-' <|> char '_') - -uncheckedChild :: Parser UNode -uncheckedChild = uncheckedElement <|> uncheckedTextNode <|> uncheckedSplicedNode + quotedValue = TextValue . T.pack <$> (char '"' *> manyTill anySingle (char '"')) + unquotedValue = TextValue . T.pack <$> some (alphaNumChar <|> char '-' <|> char '_') + expressionValue = ExpressionValue <$> (char '{' *> parseHaskellExpression <* char '}') uncheckedTextNode :: Parser UNode -uncheckedTextNode = UTextNode . T.pack <$> some (anySingleBut '<') +uncheckedTextNode = UTextNode . T.pack <$> some (satisfy (\c -> c /= '<' && c /= '{' && c /= '}')) uncheckedSplicedNode :: Parser UNode -uncheckedSplicedNode = between (string "{") (string "}") $ do - expr <- parseHaskellExpression - return $ USplicedNode expr +uncheckedSplicedNode = USplicedNode <$> (char '{' *> parseHaskellExpression <* char '}') parseHaskellExpression :: Parser Exp -parseHaskellExpression = error "Implement Haskell expression parsing here" +parseHaskellExpression = do + pos <- getSourcePos + code <- takeWhileP Nothing (\c -> c /= '}') + case HaskellParser.parseHaskellExpression pos [] (cs code) of + Right exp -> return exp + Left err -> fail $ show err compileToHaskell :: UNode -> Q Exp compileToHaskell (UNode name attrs children isLeaf) = - let element = if isLeaf - then [| H.preEscapedText $(litE $ stringL $ T.unpack $ "<" <> name <> "/>") |] - else [| H.preEscapedText $(litE $ stringL $ T.unpack $ "<" <> name <> ">") |] - applyAttrs = foldr (\(k, v) e -> [| $e ! H.customAttribute (H.stringTag $(litE $ stringL $ T.unpack k)) $(litE $ stringL $ T.unpack v) |]) element attrs + let element = [| H.preEscapedText $(litE $ stringL $ "<" ++ T.unpack name) |] + applyAttrs = foldr (\(k, v) e -> [| $e <> $(compileAttribute k v) |]) element attrs + closeTag = if isLeaf + then [| H.preEscapedText $(litE $ stringL "/>") |] + else [| H.preEscapedText $(litE $ stringL ">") |] applyChildren = if null children - then applyAttrs - else [| $applyAttrs <> mconcat $(listE (map compileToHaskell children)) <> H.preEscapedText $(litE $ stringL $ T.unpack $ " name <> ">") |] + then [| $applyAttrs <> $closeTag |] + else [| $applyAttrs <> H.preEscapedText $(litE $ stringL ">") <> + mconcat $(listE (map compileToHaskell children)) <> + H.preEscapedText $(litE $ stringL $ "") |] in applyChildren compileToHaskell (UTextNode text) = [| H.text $(litE $ stringL $ T.unpack text) |] compileToHaskell (USplicedNode exp) = [| H.preEscapedToHtml $(return exp) |] -selfClosingTags :: Set.Set String -selfClosingTags = Set.fromList ["area", "base", "br", "col", "embed", "hr", "img", "input", "link", "meta", "param", "source", "track", "wbr"] - --- You can add more helper functions here as needed +compileAttribute :: Text -> AttributeValue -> Q Exp +compileAttribute name (TextValue value) = [| H.preEscapedText $(litE $ stringL $ " " ++ T.unpack name ++ "=\"" ++ T.unpack value ++ "\"") |] +compileAttribute name (ExpressionValue exp) = [| H.preEscapedText (T.pack $ " " ++ T.unpack name ++ "=\"") <> H.toHtml $(return exp) <> H.preEscapedText "\"" |]