TableOfContents.hs

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

-- |
-- Module      :  Text.MMark.Extension.TableOfContents
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Place this markup in a markdown document where you want a table of
-- contents to be inserted:
--
-- > ```toc
-- > ```
--
-- You may use something different than @\"toc\"@ as the info string of the
-- code block.
module Text.MMark.Extension.TableOfContents
  ( Toc,
    tocScanner,
    toc,
  )
where

import Control.Foldl qualified as L
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Maybe (maybeToList)
import Data.Text (Text)
import Text.MMark qualified as MMark
import Text.MMark.Trans (Block (..), Bni, Inline (..), Span, Trans)
import Text.MMark.Trans qualified as Trans

-- | An opaque type representing a table of contents produced by the
-- 'tocScanner' scanner.
newtype Toc = Toc [(Int, NonEmpty Inline)]

-- | The scanner builds a table of contents 'Toc' that can then be passed to
-- 'toc' to obtain an extension that renders the table of contents in HTML.
tocScanner ::
  -- | Whether to include a header of this level (1–6)
  (Int -> Bool) ->
  L.Fold Bni Toc
tocScanner p = fmap (Toc . ($ [])) . MMark.scanner id $ \xs block ->
  case block of
    Heading1 _ x -> f 1 x xs
    Heading2 _ x -> f 2 x xs
    Heading3 _ x -> f 3 x xs
    Heading4 _ x -> f 4 x xs
    Heading5 _ x -> f 5 x xs
    Heading6 _ x -> f 6 x xs
    _ -> xs
  where
    f n a as =
      if p n
        then as . ((n, a) :)
        else as

-- | Create an extension that replaces a certain code block with the
-- previously constructed table of contents.
--
-- A document that asks for a table of contents but has no headings to put
-- in one is reported at the code block that asks, because there is nothing
-- to put in its place and leaving the block alone would render the marker
-- into the page as an empty code block.
toc ::
  -- | Label of the code block to replace by the table of contents
  Text ->
  -- | Previously generated by 'tocScanner'
  Toc ->
  Bni ->
  Trans Bni
toc label (Toc xs) = Trans.bottomUpBlocks $ \case
  old@(CodeBlock spn mlabel _)
    | mlabel == pure label ->
        case NE.nonEmpty xs of
          Nothing -> do
            Trans.report
              spn
              "there are no headings to put in the table of contents"
            return old
          Just ns -> return (renderToc spn ns)
  other -> return other

-- | Construct 'Bni' for a table of contents from a given collection of
-- headers. This is a non-public helper.
renderToc :: Span -> NonEmpty (Int, NonEmpty Inline) -> Bni
renderToc spn = UnorderedList spn . NE.unfoldr f
  where
    f ((n, x) :| xs) =
      let (sitems, fitems) = span ((> n) . fst) xs
          url = Trans.headerFragment (Trans.headerId x)
       in ( Naked spn (Link spn x url Nothing :| [])
              : maybeToList (renderToc spn <$> NE.nonEmpty sitems),
            NE.nonEmpty fitems
          )