diff --git a/ihp-hsx/IHP/HSX/UncheckedHSX.hs b/ihp-hsx/IHP/HSX/UncheckedHSX.hs new file mode 100644 index 000000000..dd0c731ae --- /dev/null +++ b/ihp-hsx/IHP/HSX/UncheckedHSX.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module IHP.HSX.UncheckedHSX (uncheckedHsx) where + +import Prelude +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Text.Blaze.Html5 ((!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char +import Data.Void +import Data.String.Conversions (cs) +import qualified Data.Set as Set + +uncheckedHsx :: QuasiQuoter +uncheckedHsx = QuasiQuoter + { quoteExp = quoteUncheckedHsxExpression + , quotePat = error "quotePat not implemented for uncheckedHsx" + , quoteType = error "quoteType not implemented for uncheckedHsx" + , quoteDec = error "quoteDec not implemented for uncheckedHsx" + } + +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 + 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 + +manyUncheckedElement :: Parser UNode +manyUncheckedElement = do + children <- many uncheckedChild + return $ UNode "div" [] children False + +uncheckedElement :: Parser UNode +uncheckedElement = do + char '<' + tagName <- some (alphaNumChar <|> 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) + +uncheckedAttribute :: Parser (Text, Text) +uncheckedAttribute = do + space + name <- some (alphaNumChar <|> char '-' <|> char '_') + value <- option "" (char '=' *> (quoted <|> unquoted)) + return (T.pack name, T.pack value) + where + quoted = char '"' *> manyTill anySingle (char '"') + unquoted = some (alphaNumChar <|> char '-' <|> char '_') + +uncheckedChild :: Parser UNode +uncheckedChild = uncheckedElement <|> uncheckedTextNode <|> uncheckedSplicedNode + +uncheckedTextNode :: Parser UNode +uncheckedTextNode = UTextNode . T.pack <$> some (anySingleBut '<') + +uncheckedSplicedNode :: Parser UNode +uncheckedSplicedNode = between (string "{") (string "}") $ do + expr <- parseHaskellExpression + return $ USplicedNode expr + +parseHaskellExpression :: Parser Exp +parseHaskellExpression = error "Implement Haskell expression parsing here" + +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 + applyChildren = if null children + then applyAttrs + else [| $applyAttrs <> mconcat $(listE (map compileToHaskell children)) <> H.preEscapedText $(litE $ stringL $ T.unpack $ " name <> ">") |] + 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 diff --git a/ihp-hsx/ihp-hsx.cabal b/ihp-hsx/ihp-hsx.cabal index b6973912d..42df73cea 100644 --- a/ihp-hsx/ihp-hsx.cabal +++ b/ihp-hsx/ihp-hsx.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ihp-hsx -version: 1.3.0 +version: 1.4.0 synopsis: JSX-like but for Haskell description: JSX-like templating syntax for Haskell license: MIT @@ -89,6 +89,7 @@ library , IHP.HSX.HaskellParser , IHP.HSX.HsExpToTH , IHP.HSX.Attribute + , IHP.HSX.UncheckedHSX test-suite ihp-hsx-tests type: exitcode-stdio-1.0