{-# 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')
import IHP.HSX.Attribute

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 #-}

instance Show (MarkupM ()) where
    show :: MarkupM () -> String
show MarkupM ()
html = MarkupM () -> String
BlazeString.renderHtml MarkupM ()
html