{-# LANGUAGE TemplateHaskell, UndecidableInstances, BangPatterns #-} module IHP.HtmlSupport.QQ (hsx) where import ClassyPrelude import IHP.HtmlSupport.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.Html5.Attributes as A import Text.Blaze.Html (Html) import Text.Blaze.Internal (attribute, MarkupM (Parent, Leaf), StaticString (..)) import Data.String.Conversions import IHP.HtmlSupport.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 hsx :: QuasiQuoter hsx :: QuasiQuoter hsx = QuasiQuoter :: (String -> Q Exp) -> (String -> Q Pat) -> (String -> Q Type) -> (String -> Q [Dec]) -> QuasiQuoter QuasiQuoter { quoteExp :: String -> Q Exp quoteExp = String -> Q Exp quoteHsxExpression, quotePat :: String -> Q Pat quotePat = String -> String -> Q Pat forall a. HasCallStack => String -> a error String "quotePat: not defined", quoteDec :: String -> Q [Dec] quoteDec = String -> String -> Q [Dec] forall a. HasCallStack => String -> a error String "quoteDec: not defined", quoteType :: String -> Q Type quoteType = String -> String -> Q Type forall a. HasCallStack => String -> a error String "quoteType: not defined" } quoteHsxExpression :: String -> TH.ExpQ quoteHsxExpression :: String -> Q Exp quoteHsxExpression String code = do SourcePos hsxPosition <- Q SourcePos findHSXPosition Node expression <- case SourcePos -> Text -> Either (ParseErrorBundle Text Void) Node parseHsx SourcePos hsxPosition (String -> Text forall a b. ConvertibleStrings a b => a -> b cs String code) of Left ParseErrorBundle Text Void error -> String -> Q Node forall (m :: * -> *) a. MonadFail m => String -> m a fail (ParseErrorBundle Text Void -> String forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String Megaparsec.errorBundlePretty ParseErrorBundle Text Void error) Right Node result -> Node -> Q Node forall (f :: * -> *) a. Applicative f => a -> f a pure Node result Node -> Q Exp compileToHaskell Node expression where findHSXPosition :: Q SourcePos findHSXPosition = do Loc loc <- Q Loc TH.location let (Int line, Int col) = Loc -> (Int, Int) TH.loc_start Loc loc SourcePos -> Q SourcePos forall (f :: * -> *) a. Applicative f => a -> f a pure (SourcePos -> Q SourcePos) -> SourcePos -> Q SourcePos forall a b. (a -> b) -> a -> b $ String -> Pos -> Pos -> SourcePos Megaparsec.SourcePos (Loc -> String TH.loc_filename Loc loc) (Int -> Pos Megaparsec.mkPos Int line) (Int -> Pos Megaparsec.mkPos Int col) compileToHaskell :: Node -> TH.ExpQ compileToHaskell :: Node -> Q Exp compileToHaskell (Node Text name [Attribute] attributes [Node] children Bool isLeaf) = let renderedChildren :: Q Exp renderedChildren = [Q Exp] -> Q Exp TH.listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp forall a b. (a -> b) -> a -> b $ (Node -> Q Exp) -> [Node] -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b map Node -> Q Exp compileToHaskell [Node] children stringAttributes :: Q Exp stringAttributes = [Q Exp] -> Q Exp TH.listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp forall a b. (a -> b) -> a -> b $ (Attribute -> Q Exp) -> [Attribute] -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b map Attribute -> Q Exp toStringAttribute [Attribute] attributes openTag :: Text openTag :: Text openTag = Text "<" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text tag tag :: Text tag :: Text tag = Text -> Text forall a b. ConvertibleStrings a b => a -> b cs Text name in if Bool isLeaf then let closeTag :: Text closeTag :: Text closeTag = Text ">" in [| (applyAttributes (Leaf (textToStaticString $(TH.lift tag)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) ()) $(stringAttributes)) |] else let closeTag :: Text closeTag :: Text closeTag = Text "</" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text tag Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ">" in [| (applyAttributes (makeParent (textToStaticString $(TH.lift name)) (textToStaticString $(TH.lift openTag)) (textToStaticString $(TH.lift closeTag)) $renderedChildren) $(stringAttributes)) |] compileToHaskell (Children [Node] children) = let renderedChildren :: Q Exp renderedChildren = [Q Exp] -> Q Exp TH.listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp forall a b. (a -> b) -> a -> b $ (Node -> Q Exp) -> [Node] -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b map Node -> Q Exp compileToHaskell [Node] children in [| mconcat $(renderedChildren) |] compileToHaskell (TextNode Text value) = [| Html5.preEscapedText value |] compileToHaskell (PreEscapedTextNode Text value) = [| Html5.preEscapedText value |] compileToHaskell (SplicedNode Exp expression) = [| toHtml $(pure expression) |] compileToHaskell (CommentNode Text value) = [| Html5.textComment value |] toStringAttribute :: Attribute -> TH.ExpQ toStringAttribute :: Attribute -> Q Exp toStringAttribute (StaticAttribute Text name (TextValue Text value)) = do let nameWithSuffix :: Text nameWithSuffix = Text " " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text name Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text "=\"" if Text -> Bool forall mono. MonoFoldable mono => mono -> Bool null Text 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 Text name (ExpressionValue Exp expression)) = let nameWithSuffix :: Text nameWithSuffix = Text " " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text name Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text "=\"" in [| applyAttribute name nameWithSuffix $(pure expression) |] toStringAttribute (SpreadAttributes Exp expression) = [| spreadAttributes $(pure expression) |] spreadAttributes :: ApplyAttribute value => [(Text, value)] -> Html5.Html -> Html5.Html spreadAttributes :: [(Text, value)] -> Html -> Html spreadAttributes [(Text, value)] attributes Html html = Html -> [Html -> Html] -> Html applyAttributes Html html ([Html -> Html] -> Html) -> [Html -> Html] -> Html forall a b. (a -> b) -> a -> b $ ((Text, value) -> Html -> Html) -> [(Text, value)] -> [Html -> Html] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b map (\(Text name, value value) -> Text -> Text -> value -> Html -> Html forall value. ApplyAttribute value => Text -> Text -> value -> Html -> Html applyAttribute Text name (Text name Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text "=\"") value value) [(Text, value)] attributes applyAttributes :: Html5.Html -> [Html5.Html -> Html5.Html] -> Html5.Html applyAttributes :: Html -> [Html -> Html] -> Html applyAttributes Html element [Html -> Html] attributes = (Html -> Element [Html -> Html] -> Html) -> Html -> [Html -> Html] -> Html forall mono a. MonoFoldable mono => (a -> Element mono -> a) -> a -> mono -> a foldl' (\Html element Element [Html -> Html] attribute -> Element [Html -> Html] Html -> Html attribute Html element) Html element [Html -> Html] attributes {-# INLINE applyAttributes #-} makeParent :: StaticString -> StaticString -> StaticString -> [Html] -> Html makeParent :: StaticString -> StaticString -> StaticString -> [Html] -> Html makeParent StaticString tag StaticString openTag StaticString closeTag [Html] children = StaticString -> StaticString -> StaticString -> Html -> Html forall a. StaticString -> StaticString -> StaticString -> MarkupM a -> MarkupM a Parent StaticString tag StaticString openTag StaticString closeTag ([Html] -> Html forall a. Monoid a => [a] -> a mconcat [Html] children) {-# INLINE makeParent #-} textToStaticString :: Text -> StaticString textToStaticString :: Text -> StaticString textToStaticString Text text = (String -> String) -> ByteString -> Text -> StaticString StaticString (Text -> String Text.unpack Text text String -> String -> String forall m. Monoid m => m -> m -> m ++) (Text -> ByteString Text.encodeUtf8 Text text) Text text {-# INLINE textToStaticString #-} class ApplyAttribute value where applyAttribute :: Text -> Text -> value -> (Html5.Html -> Html5.Html) instance ApplyAttribute Bool where applyAttribute :: Text -> Text -> Bool -> Html -> Html applyAttribute Text attr Text attr' Bool True Html h = Html h Html -> Attribute -> Html forall h. Attributable h => h -> Attribute -> h ! (Tag -> Tag -> AttributeValue -> Attribute attribute (Text -> Tag Html5.textTag Text attr) (Text -> Tag Html5.textTag Text attr') (Text -> AttributeValue Html5.textValue Text attr)) applyAttribute Text attr Text attr' Bool false Html h = Html h {-# INLINE applyAttribute #-} instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where applyAttribute :: Text -> Text -> value -> Html -> Html applyAttribute Text attr Text attr' value value Html h = Html h Html -> Attribute -> Html forall h. Attributable h => h -> Attribute -> h ! (Tag -> Tag -> AttributeValue -> Attribute attribute (Text -> Tag Html5.textTag Text attr) (Text -> Tag Html5.textTag Text attr') (value -> AttributeValue forall a b. ConvertibleStrings a b => a -> b cs value value)) {-# INLINE applyAttribute #-} instance Show (MarkupM ()) where show :: Html -> String show Html html = Html -> String BlazeString.renderHtml Html html