content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  
  -- |
  -- Module      :  Text.MMark.Render
  -- Copyright   :  © 2017–present Mark Karpov
  -- License     :  BSD 3 clause
  --
  -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- MMark rendering machinery.
  --
  -- @since 0.0.8.0
  module Text.MMark.Render
    ( render,
      applyBlockRender,
      defaultBlockRender,
      applyInlineRender,
      defaultInlineRender,
      newline,
    )
  where
  
  import Control.Arrow
  import Control.Monad
  import Data.Char (isSpace)
  import Data.Function (fix)
  import Data.List.NonEmpty (NonEmpty (..))
  import Data.List.NonEmpty qualified as NE
  import Data.Text qualified as T
  import Lucid
  import Text.MMark.Internal.Type
  import Text.MMark.Trans
  import Text.MMark.Util
  import Text.URI qualified as URI
  
  -- | Render a 'MMark' markdown document. You can then render @'Html' ()@ to
  -- various things:
  --
  --     * to lazy 'Data.Taxt.Lazy.Text' with 'renderText'
  --     * to lazy 'Data.ByteString.Lazy.ByteString' with 'renderBS'
  --     * directly to file with 'renderToFile'
  render :: MMark -> Html ()
  render MMark {..} =
    mapM_ rBlock mmarkBlocks
    where
      Extension {..} = mmarkExtension
      rBlock =
        applyBlockRender extBlockRender
          . fmap rInlines
          . applyBlockTrans extBlockTrans
      rInlines =
        (mkOisInternal &&& mapM_ (applyInlineRender extInlineRender))
          . fmap (applyInlineTrans extInlineTrans)
  
  -- | Apply a 'Render' to a given @'Block' 'Html' ()@.
  --
  -- @since 0.0.8.0
  applyBlockRender ::
    Render (Block (Ois, Html ())) ->
    Block (Ois, Html ()) ->
    Html ()
  applyBlockRender r = fix (runRender r . defaultBlockRender)
  
  -- | The default 'Block' render.
  --
  -- @since 0.0.8.0
  defaultBlockRender ::
    -- | Rendering function to use to render sub-blocks
    (Block (Ois, Html ()) -> Html ()) ->
    Block (Ois, Html ()) ->
    Html ()
  defaultBlockRender blockRender = \case
    ThematicBreak ->
      hr_ [] >> newline
    Heading1 (h, html) ->
      h1_ (mkId h) html >> newline
    Heading2 (h, html) ->
      h2_ (mkId h) html >> newline
    Heading3 (h, html) ->
      h3_ (mkId h) html >> newline
    Heading4 (h, html) ->
      h4_ (mkId h) html >> newline
    Heading5 (h, html) ->
      h5_ (mkId h) html >> newline
    Heading6 (h, html) ->
      h6_ (mkId h) html >> newline
    CodeBlock infoString txt -> do
      let f x = class_ $ "language-" <> T.takeWhile (not . isSpace) x
      pre_ $ code_ (maybe [] (pure . f) infoString) (toHtml txt)
      newline
    Naked (_, html) ->
      html >> newline
    Paragraph (_, html) ->
      p_ html >> newline
    Blockquote blocks -> do
      blockquote_ (newline <* mapM_ blockRender blocks)
      newline
    OrderedList i items -> do
      let startIndex = [start_ (T.pack $ show i) | i /= 1]
      ol_ startIndex $ do
        newline
        forM_ items $ \x -> do
          li_ (newline <* mapM_ blockRender x)
          newline
      newline
    UnorderedList items -> do
      ul_ $ do
        newline
        forM_ items $ \x -> do
          li_ (newline <* mapM_ blockRender x)
          newline
      newline
    Table calign (hs :| rows) -> do
      table_ $ do
        newline
        thead_ $ do
          newline
          tr_ $
            forM_ (NE.zip calign hs) $ \(a, h) ->
              th_ (alignStyle a) (snd h)
          newline
        newline
        tbody_ $ do
          newline
          forM_ rows $ \row -> do
            tr_ $
              forM_ (NE.zip calign row) $ \(a, h) ->
                td_ (alignStyle a) (snd h)
            newline
        newline
      newline
    where
      mkId ois = [(id_ . headerId . getOis) ois]
      alignStyle = \case
        CellAlignDefault -> []
        CellAlignLeft -> [style_ "text-align:left"]
        CellAlignRight -> [style_ "text-align:right"]
        CellAlignCenter -> [style_ "text-align:center"]
  
  -- | Apply a render to a given 'Inline'.
  --
  -- @since 0.0.8.0
  applyInlineRender :: Render Inline -> Inline -> Html ()
  applyInlineRender r = fix (runRender r . defaultInlineRender)
  
  -- | The default render for 'Inline' elements.
  --
  -- @since 0.0.8.0
  defaultInlineRender ::
    -- | Rendering function to use to render sub-inlines
    (Inline -> Html ()) ->
    Inline ->
    Html ()
  defaultInlineRender inlineRender = \case
    Plain txt ->
      toHtml txt
    LineBreak ->
      br_ [] >> newline
    Emphasis inner ->
      em_ (mapM_ inlineRender inner)
    Strong inner ->
      strong_ (mapM_ inlineRender inner)
    Strikeout inner ->
      del_ (mapM_ inlineRender inner)
    Subscript inner ->
      sub_ (mapM_ inlineRender inner)
    Superscript inner ->
      sup_ (mapM_ inlineRender inner)
    CodeSpan txt ->
      code_ (toHtml txt)
    Link inner dest mtitle ->
      let title = maybe [] (pure . title_) mtitle
       in a_ (href_ (URI.render dest) : title) (mapM_ inlineRender inner)
    Image desc src mtitle ->
      let title = maybe [] (pure . title_) mtitle
       in img_ (alt_ (asPlainText desc) : src_ (URI.render src) : title)
  
  -- | HTML containing a newline.
  --
  -- @since 0.0.8.0
  newline :: Html ()
  newline = "\n"
  