{-# 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
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 Html
h | Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
attr = 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') AttributeValue
"false") -- data attribute set to "false"
    applyAttribute Text
attr Text
attr' Bool
false Html
h = Html
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 {-# 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