{-# 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 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 = forall a. HasCallStack => String -> a
error String
"quotePat: not defined",
        quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"quoteDec: not defined",
        quoteType :: String -> Q Type
quoteType = 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 (forall a b. ConvertibleStrings a b => a -> b
cs String
code) of
                Left ParseErrorBundle Text Void
error   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty ParseErrorBundle Text Void
error)
                Right Node
result -> 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
            forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Node -> Q Exp
compileToHaskell [Node]
children
        stringAttributes :: Q Exp
stringAttributes = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Q Exp
toStringAttribute [Attribute]
attributes
        openTag :: Text
        openTag :: Text
openTag = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
tag
        tag :: Text
        tag :: Text
tag = 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
"</" forall a. Semigroup a => a -> a -> a
<> Text
tag 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [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
" " forall a. Semigroup a => a -> a -> a
<> Text
name 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
" " forall a. Semigroup a => a -> a -> a
<> Text
name 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 :: forall value.
ApplyAttribute value =>
[(Text, value)] -> MarkupM () -> MarkupM ()
spreadAttributes [(Text, value)]
attributes MarkupM ()
html = MarkupM () -> [MarkupM () -> MarkupM ()] -> MarkupM ()
applyAttributes MarkupM ()
html forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Text
name, value
value) -> forall value.
ApplyAttribute value =>
Text -> Text -> value -> MarkupM () -> MarkupM ()
applyAttribute Text
name (Text
" " forall a. Semigroup a => a -> a -> a
<> Text
name 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 = 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 = forall a.
StaticString
-> StaticString -> StaticString -> MarkupM a -> MarkupM a
Parent StaticString
tag StaticString
openTag StaticString
closeTag (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 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 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" -- "true" for data attributes
                    else Text
attr -- normal html boolean attriubtes, like <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes
    applyAttribute Text
attr Text
attr' Bool
false MarkupM ()
h | Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
attr = MarkupM ()
h 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") -- data attribute set to "false"
    applyAttribute Text
attr Text
attr' Bool
false MarkupM ()
h = MarkupM ()
h -- html boolean attribute, like <input disabled/> 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 :: Text -> Text -> Maybe attribute -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' (Just attribute
value) MarkupM ()
h = 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 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 = forall value.
ApplyAttribute value =>
Text -> Text -> value -> MarkupM () -> MarkupM ()
applyAttribute Text
attr Text
attr' ((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