{-# LANGUAGE GHC2024 #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Rendering functions for markup.
module Data.Markup.Render
  ( markdown,
    markdown_,
    detokenize,
    escapeChar,
    escape,
    content,
  )
where

import Control.Category ((>>>))
import Data.Bifunctor
import Data.Bool
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.Markup
import Data.Markup.Parser (normContent, selfClosers)
import Data.Markup.Warn (MarkupWarning (..), Warn, concatWarns, warnError)
import Data.These
import Data.Tree

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Markup
-- >>> import Data.Tree

-- | Escape a single character.
escapeChar :: Char -> ByteString
escapeChar :: Char -> ByteString
escapeChar Char
'<' = ByteString
"&lt;"
escapeChar Char
'>' = ByteString
"&gt;"
escapeChar Char
'&' = ByteString
"&amp;"
escapeChar Char
'\'' = ByteString
"&apos;"
escapeChar Char
'"' = ByteString
"&quot;"
escapeChar Char
x = Char -> ByteString
B.singleton Char
x

-- | Escape the following predefined character entity references:
--
-- @
-- escapeChar \'<\' = "&lt;"
-- escapeChar \'>\' = "&gt;"
-- escapeChar \'&\' = "&amp;"
-- escapeChar \'\'\' = "&apos;"
-- escapeChar '"' = "&quot;"
-- @
--
-- No attempt is made to meet the <https://en.wikipedia.org/wiki/List_of_XML_and_HTML_character_entity_references HTML Standards>
--
-- >>> escape "<foo class=\"a\" bar='b'>"
-- "&lt;foo class=&quot;a&quot; bar=&apos;b&apos;&gt;"
escape :: ByteString -> ByteString
escape :: ByteString -> ByteString
escape = (Char -> ByteString) -> ByteString -> ByteString
B.concatMap Char -> ByteString
escapeChar

-- | Create 'Markup' 'Content' from a bytestring, escaping the usual characters.
--
-- >>> content "<content>"
-- Markup {elements = [Node {rootLabel = Content "&lt;content&gt;", subForest = []}]}
content :: ByteString -> Markup
content :: ByteString -> Markup
content ByteString
b = [Element] -> Markup
Markup [Token -> Element
forall a. a -> Tree a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Element) -> Token -> Element
forall a b. (a -> b) -> a -> b
$ ByteString -> Token
Content (ByteString -> ByteString
escape ByteString
b)]

-- | render attributes
renderAttrs :: [Attr] -> ByteString
renderAttrs :: [Attr] -> ByteString
renderAttrs [] = ByteString
forall a. Monoid a => a
mempty
renderAttrs [Attr]
xs = Char -> ByteString
B.singleton Char
' ' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ([ByteString] -> ByteString
B.unwords ([ByteString] -> ByteString)
-> ([Attr] -> [ByteString]) -> [Attr] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> ByteString) -> [Attr] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attr -> ByteString
renderAttr ([Attr] -> ByteString) -> [Attr] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Attr]
xs)

-- | render an attribute
--
-- Does not attempt to escape double quotes.
renderAttr :: Attr -> ByteString
renderAttr :: Attr -> ByteString
renderAttr (Attr ByteString
k ByteString
v) = ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=\"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\""

-- | bytestring representation of 'Token'.
--
-- >>> detokenize Html (OpenTag StartTag "foo" [])
-- "<foo>"
detokenize :: Standard -> Token -> ByteString
detokenize :: Standard -> Token -> ByteString
detokenize Standard
s = \case
  (OpenTag OpenTagType
StartTag ByteString
n []) -> ByteString
"<" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
">"
  (OpenTag OpenTagType
StartTag ByteString
n [Attr]
as) -> ByteString
"<" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Attr] -> ByteString
renderAttrs [Attr]
as ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
">"
  (OpenTag OpenTagType
EmptyElemTag ByteString
n [Attr]
as) ->
    ByteString -> ByteString -> Bool -> ByteString
forall a. a -> a -> Bool -> a
bool
      (ByteString
"<" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Attr] -> ByteString
renderAttrs [Attr]
as ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/>")
      (ByteString
"<" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Attr] -> ByteString
renderAttrs [Attr]
as ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" />")
      (Standard
s Standard -> Standard -> Bool
forall a. Eq a => a -> a -> Bool
== Standard
Html)
  (EndTag ByteString
n) -> ByteString
"</" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
">"
  (Content ByteString
t) -> ByteString
t
  (Comment ByteString
t) -> ByteString
"<!--" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"-->"
  (Doctype ByteString
t) -> ByteString
"<!" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
">"
  (Decl ByteString
t [Attr]
as) -> ByteString -> ByteString -> Bool -> ByteString
forall a. a -> a -> Bool -> a
bool (ByteString
"<?" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Attr] -> ByteString
renderAttrs [Attr]
as ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"?>") (ByteString
"<!" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"!>") (Standard
s Standard -> Standard -> Bool
forall a. Eq a => a -> a -> Bool
== Standard
Html)

indentChildren :: RenderStyle -> [ByteString] -> [ByteString]
indentChildren :: RenderStyle -> [ByteString] -> [ByteString]
indentChildren RenderStyle
Compact = [ByteString] -> [ByteString]
forall a. a -> a
id
indentChildren (Indented Int
x) =
  (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char -> ByteString
B.replicate Int
x Char
' ' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)

finalConcat :: RenderStyle -> [ByteString] -> ByteString
finalConcat :: RenderStyle -> [ByteString] -> ByteString
finalConcat RenderStyle
Compact = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
finalConcat (Indented Int
_) =
  ByteString -> [ByteString] -> ByteString
B.intercalate (Char -> ByteString
B.singleton Char
'\n')
    ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"")

-- | Convert 'Markup' to bytestrings
markdown :: RenderStyle -> Standard -> Markup -> Warn ByteString
markdown :: RenderStyle -> Standard -> Markup -> Warn ByteString
markdown RenderStyle
r Standard
s Markup
m = ([ByteString] -> ByteString)
-> Warn [ByteString] -> Warn ByteString
forall b c a. (b -> c) -> These a b -> These a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [ByteString] -> ByteString
finalConcat RenderStyle
r) (Warn [ByteString] -> Warn ByteString)
-> Warn [ByteString] -> Warn ByteString
forall a b. (a -> b) -> a -> b
$ [Warn [ByteString]] -> Warn [ByteString]
forall a. [Warn [a]] -> Warn [a]
concatWarns ([Warn [ByteString]] -> Warn [ByteString])
-> [Warn [ByteString]] -> Warn [ByteString]
forall a b. (a -> b) -> a -> b
$ (Token -> [Warn [ByteString]] -> Warn [ByteString])
-> Element -> Warn [ByteString]
forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (RenderStyle
-> Standard -> Token -> [Warn [ByteString]] -> Warn [ByteString]
renderBranch RenderStyle
r Standard
s) (Element -> Warn [ByteString]) -> [Element] -> [Warn [ByteString]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Markup -> [Element]
elements (Markup -> Markup
normContent Markup
m)

-- | Convert 'Markup' to 'ByteString' and error on warnings.
markdown_ :: RenderStyle -> Standard -> Markup -> ByteString
markdown_ :: RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
r Standard
s = RenderStyle -> Standard -> Markup -> Warn ByteString
markdown RenderStyle
r Standard
s (Markup -> Warn ByteString)
-> (Warn ByteString -> ByteString) -> Markup -> ByteString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Warn ByteString -> ByteString
forall a. Warn a -> a
warnError

-- note that renderBranch adds in EndTags for StartTags when needed
renderBranch :: RenderStyle -> Standard -> Token -> [Warn [ByteString]] -> Warn [ByteString]
renderBranch :: RenderStyle
-> Standard -> Token -> [Warn [ByteString]] -> Warn [ByteString]
renderBranch RenderStyle
r Standard
std s :: Token
s@(OpenTag OpenTagType
StartTag ByteString
n [Attr]
_) [Warn [ByteString]]
xs
  | ByteString
n ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
selfClosers Bool -> Bool -> Bool
&& Standard
std Standard -> Standard -> Bool
forall a. Eq a => a -> a -> Bool
== Standard
Html =
      [ByteString] -> Warn [ByteString]
forall a b. b -> These a b
That [Standard -> Token -> ByteString
detokenize Standard
std Token
s] Warn [ByteString] -> Warn [ByteString] -> Warn [ByteString]
forall a. Semigroup a => a -> a -> a
<> ([ByteString] -> [ByteString])
-> Warn [ByteString] -> Warn [ByteString]
forall b c a. (b -> c) -> These a b -> These a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [ByteString] -> [ByteString]
indentChildren RenderStyle
r) ([Warn [ByteString]] -> Warn [ByteString]
forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [ByteString]]
xs)
  | Bool
otherwise =
      [ByteString] -> Warn [ByteString]
forall a b. b -> These a b
That [Standard -> Token -> ByteString
detokenize Standard
std Token
s] Warn [ByteString] -> Warn [ByteString] -> Warn [ByteString]
forall a. Semigroup a => a -> a -> a
<> ([ByteString] -> [ByteString])
-> Warn [ByteString] -> Warn [ByteString]
forall b c a. (b -> c) -> These a b -> These a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [ByteString] -> [ByteString]
indentChildren RenderStyle
r) ([Warn [ByteString]] -> Warn [ByteString]
forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [ByteString]]
xs) Warn [ByteString] -> Warn [ByteString] -> Warn [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Warn [ByteString]
forall a b. b -> These a b
That [Standard -> Token -> ByteString
detokenize Standard
std (ByteString -> Token
EndTag ByteString
n)]
renderBranch RenderStyle
_ Standard
std Token
x [] =
  [ByteString] -> Warn [ByteString]
forall a b. b -> These a b
That [Standard -> Token -> ByteString
detokenize Standard
std Token
x]
renderBranch RenderStyle
r Standard
std Token
x [Warn [ByteString]]
xs =
  [MarkupWarning] -> [ByteString] -> Warn [ByteString]
forall a b. a -> b -> These a b
These [MarkupWarning
LeafWithChildren] [Standard -> Token -> ByteString
detokenize Standard
std Token
x] Warn [ByteString] -> Warn [ByteString] -> Warn [ByteString]
forall a. Semigroup a => a -> a -> a
<> ([ByteString] -> [ByteString])
-> Warn [ByteString] -> Warn [ByteString]
forall b c a. (b -> c) -> These a b -> These a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenderStyle -> [ByteString] -> [ByteString]
indentChildren RenderStyle
r) ([Warn [ByteString]] -> Warn [ByteString]
forall a. [Warn [a]] -> Warn [a]
concatWarns [Warn [ByteString]]
xs)