{-# LANGUAGE TemplateHaskell, UndecidableInstances, BangPatterns, PackageImports, FlexibleInstances, OverloadedStrings #-}
module IHP.HSX.QQ (hsx) where
import Prelude
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 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
hsx = 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
[Extension]
extensions <- Q [Extension]
TH.extsEnabled
Node
expression <- case SourcePos
-> [Extension] -> Text -> Either (ParseErrorBundle Text Void) Node
parseHsx SourcePos
hsxPosition [Extension]
extensions (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
code) of
Left ParseErrorBundle Text Void
error -> String -> Q Node
forall a. String -> Q a
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 a. a -> Q a
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 a. a -> Q a
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
"!DOCTYPE" [StaticAttribute Text
"html" (TextValue Text
"html")] [] Bool
True) = [| Html5.docType |]
compileToHaskell (Node Text
name [Attribute]
attributes [Node]
children Bool
isLeaf) =
let
renderedChildren :: Q Exp
renderedChildren = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m 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 a b. (a -> b) -> [a] -> [b]
map Node -> Q Exp
compileToHaskell [Node]
children
stringAttributes :: Q Exp
stringAttributes = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m 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 a b. (a -> b) -> [a] -> [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 $(Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
tag)) (textToStaticString $(Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
openTag)) (textToStaticString $(Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
closeTag)) ()) $(Q Exp
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 $(Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
name)) (textToStaticString $(Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
openTag)) (textToStaticString $(Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
closeTag)) $Q Exp
renderedChildren) $(Q Exp
stringAttributes)) |]
compileToHaskell (Children [Node]
children) =
let
renderedChildren :: Q Exp
renderedChildren = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m 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 a b. (a -> b) -> [a] -> [b]
map Node -> Q Exp
compileToHaskell [Node]
children
in [| mconcat $(Q Exp
renderedChildren) |]
compileToHaskell (TextNode Text
value) = [| Html5.preEscapedText value |]
compileToHaskell (PreEscapedTextNode Text
value) = [| Html5.preEscapedText value |]
compileToHaskell (SplicedNode Exp
expression) = [| toHtml $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expression) |]
compileToHaskell (CommentNode Text
value) = [| Html5.textComment value |]
compileToHaskell (Node
NoRenderCommentNode) = [| mempty |]
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
Text.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 $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expression) |]
toStringAttribute (SpreadAttributes Exp
expression) = [| spreadAttributes $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expression) |]
spreadAttributes :: ApplyAttribute value => [(Text, value)] -> Html5.Html -> Html5.Html
spreadAttributes :: forall value.
ApplyAttribute value =>
[(Text, value)] -> MarkupM () -> MarkupM ()
spreadAttributes [(Text, value)]
attributes MarkupM ()
html = MarkupM () -> [MarkupM () -> MarkupM ()] -> MarkupM ()
applyAttributes MarkupM ()
html ([MarkupM () -> MarkupM ()] -> MarkupM ())
-> [MarkupM () -> MarkupM ()] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ ((Text, value) -> MarkupM () -> MarkupM ())
-> [(Text, value)] -> [MarkupM () -> MarkupM ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
name, value
value) -> Text -> Text -> value -> MarkupM () -> MarkupM ()
forall value.
ApplyAttribute value =>
Text -> Text -> value -> MarkupM () -> MarkupM ()
applyAttribute Text
name (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=\"") value
value) [(Text, value)]
attributes
{-# INLINE spreadAttributes #-}
applyAttributes :: Html5.Html -> [Html5.Html -> Html5.Html] -> Html5.Html
applyAttributes :: MarkupM () -> [MarkupM () -> MarkupM ()] -> MarkupM ()
applyAttributes MarkupM ()
element [MarkupM () -> MarkupM ()]
attributes = (MarkupM () -> (MarkupM () -> MarkupM ()) -> MarkupM ())
-> MarkupM () -> [MarkupM () -> MarkupM ()] -> MarkupM ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\MarkupM ()
element MarkupM () -> MarkupM ()
attribute -> MarkupM () -> MarkupM ()
attribute MarkupM ()
element) MarkupM ()
element [MarkupM () -> MarkupM ()]
attributes
{-# INLINE applyAttributes #-}
makeParent :: StaticString -> StaticString -> StaticString -> [Html] -> Html
makeParent :: StaticString
-> StaticString -> StaticString -> [MarkupM ()] -> MarkupM ()
makeParent StaticString
tag StaticString
openTag StaticString
closeTag [MarkupM ()]
children = StaticString
-> StaticString -> StaticString -> MarkupM () -> MarkupM ()
forall a.
StaticString
-> StaticString -> StaticString -> MarkupM a -> MarkupM a
Parent StaticString
tag StaticString
openTag StaticString
closeTag ([MarkupM ()] -> MarkupM ()
forall a. Monoid a => [a] -> a
mconcat [MarkupM ()]
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 a. [a] -> [a] -> [a]
++) (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 -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' Bool
True MarkupM ()
h = MarkupM ()
h MarkupM () -> Attribute -> MarkupM ()
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
value))
where
value :: Text
value = if Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
attr
then Text
"true"
else Text
attr
applyAttribute Text
attr Text
attr' Bool
false MarkupM ()
h | Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
attr = MarkupM ()
h MarkupM () -> Attribute -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! (Tag -> Tag -> AttributeValue -> Attribute
attribute (Text -> Tag
Html5.textTag Text
attr) (Text -> Tag
Html5.textTag Text
attr') AttributeValue
"false")
applyAttribute Text
attr Text
attr' Bool
false MarkupM ()
h = MarkupM ()
h
{-# INLINE applyAttribute #-}
instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where
applyAttribute :: Text -> Text -> Maybe attribute -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' (Just attribute
value) MarkupM ()
h = Text -> Text -> attribute -> MarkupM () -> MarkupM ()
forall value.
ApplyAttribute value =>
Text -> Text -> value -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' attribute
value MarkupM ()
h
applyAttribute Text
attr Text
attr' Maybe attribute
Nothing MarkupM ()
h = MarkupM ()
h
{-# INLINE applyAttribute #-}
instance ApplyAttribute Html5.AttributeValue where
applyAttribute :: Text -> Text -> AttributeValue -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' AttributeValue
value MarkupM ()
h = MarkupM ()
h MarkupM () -> Attribute -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! (Tag -> Tag -> AttributeValue -> Attribute
attribute (Text -> Tag
Html5.textTag Text
attr) (Text -> Tag
Html5.textTag Text
attr') AttributeValue
value)
{-# INLINE applyAttribute #-}
instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where
applyAttribute :: Text -> Text -> value -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' value
value MarkupM ()
h = Text -> Text -> AttributeValue -> MarkupM () -> MarkupM ()
forall value.
ApplyAttribute value =>
Text -> Text -> value -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' ((value -> AttributeValue
forall a b. ConvertibleStrings a b => a -> b
cs value
value) :: Html5.AttributeValue) MarkupM ()
h
{-# INLINE applyAttribute #-}
instance Show (MarkupM ()) where
show :: MarkupM () -> String
show MarkupM ()
html = MarkupM () -> String
BlazeString.renderHtml MarkupM ()
html