{- |

Text elements and attribute values are escaped.
Tag names, attribute keys, and comments are neither escaped
nor validated; it is possible to construct malformed documents.

Build an 'Html' value using 'tag', 'tag'', 'attr', 'attr'', 'text',
'comment', and 'inline'. Then use 'runHtml' to get a 'TextBuilder'.

'Html' has a 'Monoid' instance. It is often more convenient to apply
'fold' a list literal than to chain the '(<>)' operator. You can use
'mempty' when you need an HTML tag with an empty body.

-}
module PrettyHTML
  (
    {- * The Html type -}  Html, runHtml,
    {- * Tags          -}  tag, tag',
    {- * Attributes    -}  Attr, attr, attr',
    {- * Plain text    -}  text,
    {- * Comments      -}  comment,
    {- * Formatting    -}  inline,
    {- * Text aliases  -}  LazyText, TextBuilder
  ) where

import Foldable (fold)
import Natural (Natural)
import Semigroup (stimes)

import qualified TextBuilder
import qualified LazyText

type LazyText = LazyText.Text
type TextBuilder = TextBuilder.Builder

data Html = NoHtml | Html (Context -> TextBuilder)

runHtml :: Html -> TextBuilder
runHtml :: Html -> TextBuilder
runHtml = \case
    Html
NoHtml -> forall a. Monoid a => a
mempty
    Html Context -> TextBuilder
f -> Context -> TextBuilder
f (Natural -> Context
Block Natural
0)

instance Semigroup Html where
    Html
NoHtml <> :: Html -> Html -> Html
<> Html
x = Html
x
    Html
x <> Html
NoHtml = Html
x
    Html Context -> TextBuilder
f <> Html Context -> TextBuilder
g = (Context -> TextBuilder) -> Html
Html \Context
c -> Context -> TextBuilder
f Context
c forall a. Semigroup a => a -> a -> a
<> Context -> TextBuilder
g Context
c

instance Monoid Html where
    mempty :: Html
mempty = Html
NoHtml

data Context = Block Natural | Inline

-- | See 'attr' and 'attr''.
type Attr = (LazyText, Maybe LazyText)

raw :: TextBuilder -> Html
raw :: TextBuilder -> Html
raw TextBuilder
x = (Context -> TextBuilder) -> Html
Html \Context
_ -> TextBuilder
x

indent :: Html
indent :: Html
indent = (Context -> TextBuilder) -> Html
Html \case
    Block Natural
0 -> forall a. Monoid a => a
mempty
    Block Natural
n -> forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Natural
n TextBuilder
"\t"
    Context
Inline -> forall a. Monoid a => a
mempty

endOfLine :: Html
endOfLine :: Html
endOfLine = (Context -> TextBuilder) -> Html
Html \case
    Block Natural
_ -> TextBuilder
"\n"
    Context
Inline -> forall a. Monoid a => a
mempty

changeContext :: (Context -> Context) -> Html -> Html
changeContext :: (Context -> Context) -> Html -> Html
changeContext Context -> Context
f = \case
    Html
NoHtml -> Html
NoHtml
    Html Context -> TextBuilder
g -> (Context -> TextBuilder) -> Html
Html (Context -> TextBuilder
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
f)

changeIndent :: (Natural -> Natural) -> Context -> Context
changeIndent :: (Natural -> Natural) -> Context -> Context
changeIndent Natural -> Natural
f = \case
    Block Natural
n -> Natural -> Context
Block (Natural -> Natural
f Natural
n)
    Context
Inline -> Context
Inline

-- | Content wrapped in 'inline' is rendered tersely, without line breaks and indentation.
--
-- Typically paragraphs should be rendered inline,
-- e.g. @'inline' ('tag' "p" [] $ 'fold' [ _, _, _ ])@
inline :: Html -> Html
inline :: Html -> Html
inline Html
x = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , (Context -> Context) -> Html -> Html
changeContext (forall a b. a -> b -> a
const Context
Inline) Html
x
    , Html
endOfLine
    ]

-- | Attribute with a key and value.
attr ::
    LazyText -- ^ Attribute key. This must be a valid key; no checking or escaping is done.
    -> LazyText -- ^ Attribute value. This can safely be anything; it will be escaped.
    -> Attr
attr :: LazyText -> LazyText -> Attr
attr LazyText
k LazyText
v = (LazyText
k, forall a. a -> Maybe a
Just LazyText
v)

-- | Attribute without a value, e.g. "autofocus", "checked".
attr' ::
    LazyText -- ^ Attribute key. This must be a valid key; no checking or escaping is done.
    -> Attr
attr' :: LazyText -> Attr
attr' LazyText
x = (LazyText
x, forall a. Maybe a
Nothing)

-- | Element with opening and closing tags.
tag :: Foldable t =>
    LazyText -- ^ Tag name. This must be a valid tag name; no checking or escaping is done.
    -> t Attr -- ^ List of attributes. See 'attr' and 'attr''.
    -> Html -- ^ Content nested within the tag.
    -> Html
tag :: forall (t :: * -> *).
Foldable t =>
LazyText -> t Attr -> Html -> Html
tag LazyText
x t Attr
a Html
mi = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , (TextBuilder -> Html
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
        [ TextBuilder
"<"
        , LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
x
        , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attr -> TextBuilder
buildAttr t Attr
a
        , TextBuilder
">"
        ]
    , case Html
mi of
        Html
NoHtml -> forall a. Monoid a => a
mempty
        Html
i -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
            [ Html
endOfLine
            , (Context -> Context) -> Html -> Html
changeContext ((Natural -> Natural) -> Context -> Context
changeIndent (forall a. Num a => a -> a -> a
+ Natural
1)) Html
i
            , Html
indent
            ]
    , (TextBuilder -> Html
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
        [ TextBuilder
"</"
        , LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
x
        , TextBuilder
">"
        ]
    , Html
endOfLine
    ]

-- | Self-closing tag, e.g. "meta", "br", "li".
tag' :: Foldable t =>
    LazyText -- ^ Tag name. This must be a valid tag name; no checking or escaping is done.
    -> t Attr -- ^ List of attributes. See 'attr' and 'attr''.
    -> Html
tag' :: forall (t :: * -> *). Foldable t => LazyText -> t Attr -> Html
tag' LazyText
x t Attr
a = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , (TextBuilder -> Html
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
        [ TextBuilder
"<"
        , LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
x
        , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attr -> TextBuilder
buildAttr t Attr
a
        , TextBuilder
">"
        ]
    , Html
endOfLine
    ]

buildAttr :: Attr -> TextBuilder
buildAttr :: Attr -> TextBuilder
buildAttr (LazyText
k, Maybe LazyText
vMaybe) = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ TextBuilder
" "
    , LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
k
    , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LazyText -> TextBuilder
attrValue Maybe LazyText
vMaybe
    ]

attrValue :: LazyText -> TextBuilder
attrValue :: LazyText -> TextBuilder
attrValue LazyText
v = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ TextBuilder
"=\""
    , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> TextBuilder
attrEscape (LazyText -> String
LazyText.unpack LazyText
v)
    , TextBuilder
"\""
    ]

attrEscape :: Char -> TextBuilder
attrEscape :: Char -> TextBuilder
attrEscape = \case
    Char
'<' -> TextBuilder
"&lt;"
    Char
'>' -> TextBuilder
"&gt;"
    Char
'&' -> TextBuilder
"&amp;"
    Char
'"' -> TextBuilder
"&quot;"
    Char
c -> Char -> TextBuilder
TextBuilder.singleton Char
c

-- | A text element.
text ::
    LazyText -- ^ Can safely be anything; it will be escaped.
    -> Html
text :: LazyText -> Html
text LazyText
x = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , TextBuilder -> Html
raw (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> TextBuilder
textEscape (LazyText -> String
LazyText.unpack LazyText
x))
    , Html
endOfLine
    ]

textEscape :: Char -> TextBuilder
textEscape :: Char -> TextBuilder
textEscape = \case
    Char
'<' -> TextBuilder
"&lt;"
    Char
'>' -> TextBuilder
"gt;"
    Char
'&' -> TextBuilder
"&amp;"
    Char
c -> Char -> TextBuilder
TextBuilder.singleton Char
c

-- | A comment appears in the HTML source code but is ignored when read.
comment ::
    LazyText -- ^ Must not contain a comment closing tag; this is neither checked nor escaped.
    -> Html
comment :: LazyText -> Html
comment LazyText
x = (Context -> TextBuilder) -> Html
Html \case
    c :: Context
c@Block{} -> let Html Context -> TextBuilder
f = LazyText -> Html
blockComment LazyText
x in Context -> TextBuilder
f Context
c
    c :: Context
c@Inline{} -> let Html Context -> TextBuilder
f = LazyText -> Html
oneLineComment LazyText
x in Context -> TextBuilder
f Context
c

oneLineComment :: LazyText -> Html
oneLineComment :: LazyText -> Html
oneLineComment LazyText
x = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , TextBuilder -> Html
raw TextBuilder
"<!-- "
    , (Context -> Context) -> Html -> Html
changeContext (forall a b. a -> b -> a
const Context
Inline) (LazyText -> Html
commentBody LazyText
x)
    , TextBuilder -> Html
raw TextBuilder
" -->"
    , Html
endOfLine
    ]

blockComment :: LazyText -> Html
blockComment :: LazyText -> Html
blockComment LazyText
i = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , TextBuilder -> Html
raw TextBuilder
"<!--"
    , Html
endOfLine
    , (Context -> Context) -> Html -> Html
changeContext ((Natural -> Natural) -> Context -> Context
changeIndent (forall a. Num a => a -> a -> a
+ Natural
1)) (LazyText -> Html
commentBody LazyText
i)
    , Html
indent
    , TextBuilder -> Html
raw TextBuilder
"-->"
    , Html
endOfLine
    ]

commentBody :: LazyText -> Html
commentBody :: LazyText -> Html
commentBody = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LazyText -> Html
commentLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyText -> [LazyText]
LazyText.lines

commentLine :: LazyText -> Html
commentLine :: LazyText -> Html
commentLine LazyText
l = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Html
indent
    , TextBuilder -> Html
raw (LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
l)
    , Html
endOfLine
    ]