{-# LANGUAGE LambdaCase #-}

-- |
-- 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 markdown document where you want 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 qualified Control.Foldl as L
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (maybeToList)
import Data.Text (Text)
import Text.MMark.Extension (Block (..), Bni, Extension, Inline (..))
import qualified Text.MMark.Extension as Ext

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

-- | The scanner builds 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 :: (Int -> Bool) -> Fold Bni Toc
tocScanner Int -> Bool
p = (([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]) -> Toc)
-> Fold Bni ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> Fold Bni Toc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Int, NonEmpty Inline)] -> Toc
Toc ([(Int, NonEmpty Inline)] -> Toc)
-> (([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
    -> [(Int, NonEmpty Inline)])
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> Toc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
forall a b. (a -> b) -> a -> b
$ [])) (Fold Bni ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
 -> Fold Bni Toc)
-> ((([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
     -> Bni -> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
    -> Fold Bni ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]))
-> (([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
    -> Bni -> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> Fold Bni Toc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> (([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
    -> Bni -> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> Fold Bni ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
forall a. a -> (a -> Bni -> a) -> Fold Bni a
Ext.scanner [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
forall a. a -> a
id ((([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
  -> Bni -> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
 -> Fold Bni Toc)
-> (([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
    -> Bni -> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> Fold Bni Toc
forall a b. (a -> b) -> a -> b
$ \[(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs Bni
block ->
  case Bni
block of
    Heading1 NonEmpty Inline
x -> Int
-> NonEmpty Inline
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)]
-> [(Int, NonEmpty Inline)]
forall b c. Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
1 NonEmpty Inline
x [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
    Heading2 NonEmpty Inline
x -> Int
-> NonEmpty Inline
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)]
-> [(Int, NonEmpty Inline)]
forall b c. Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
2 NonEmpty Inline
x [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
    Heading3 NonEmpty Inline
x -> Int
-> NonEmpty Inline
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)]
-> [(Int, NonEmpty Inline)]
forall b c. Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
3 NonEmpty Inline
x [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
    Heading4 NonEmpty Inline
x -> Int
-> NonEmpty Inline
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)]
-> [(Int, NonEmpty Inline)]
forall b c. Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
4 NonEmpty Inline
x [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
    Heading5 NonEmpty Inline
x -> Int
-> NonEmpty Inline
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)]
-> [(Int, NonEmpty Inline)]
forall b c. Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
5 NonEmpty Inline
x [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
    Heading6 NonEmpty Inline
x -> Int
-> NonEmpty Inline
-> ([(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)])
-> [(Int, NonEmpty Inline)]
-> [(Int, NonEmpty Inline)]
forall b c. Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
6 NonEmpty Inline
x [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
    Bni
_ -> [(Int, NonEmpty Inline)] -> [(Int, NonEmpty Inline)]
xs
  where
    f :: Int -> b -> ([(Int, b)] -> c) -> [(Int, b)] -> c
f Int
n b
a [(Int, b)] -> c
as =
      if Int -> Bool
p Int
n
        then [(Int, b)] -> c
as ([(Int, b)] -> c) -> ([(Int, b)] -> [(Int, b)]) -> [(Int, b)] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int
n, b
a) (Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
:)
        else [(Int, b)] -> c
as

-- | Create an extension that replaces a certain code block with the
-- previously constructed table of contents.
toc ::
  -- | Label of the code block to replace by the table of contents
  Text ->
  -- | Previously generated by 'tocScanner'
  Toc ->
  Extension
toc :: Text -> Toc -> Extension
toc Text
label (Toc [(Int, NonEmpty Inline)]
xs) = (Bni -> Bni) -> Extension
Ext.blockTrans ((Bni -> Bni) -> Extension) -> (Bni -> Bni) -> Extension
forall a b. (a -> b) -> a -> b
$ \case
  old :: Bni
old@(CodeBlock Maybe Text
mlabel Text
_) ->
    case [(Int, NonEmpty Inline)] -> Maybe (NonEmpty (Int, NonEmpty Inline))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Int, NonEmpty Inline)]
xs of
      Maybe (NonEmpty (Int, NonEmpty Inline))
Nothing -> Bni
old
      Just NonEmpty (Int, NonEmpty Inline)
ns ->
        if Maybe Text
mlabel Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
label
          then NonEmpty (Int, NonEmpty Inline) -> Bni
renderToc NonEmpty (Int, NonEmpty Inline)
ns
          else Bni
old
  Bni
other -> Bni
other

-- | Construct 'Bni' for a table of contents from given collection of
-- headers. This is a non-public helper.
renderToc :: NonEmpty (Int, NonEmpty Inline) -> Bni
renderToc :: NonEmpty (Int, NonEmpty Inline) -> Bni
renderToc = NonEmpty [Bni] -> Bni
forall a. NonEmpty [Block a] -> Block a
UnorderedList (NonEmpty [Bni] -> Bni)
-> (NonEmpty (Int, NonEmpty Inline) -> NonEmpty [Bni])
-> NonEmpty (Int, NonEmpty Inline)
-> Bni
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (Int, NonEmpty Inline)
 -> ([Bni], Maybe (NonEmpty (Int, NonEmpty Inline))))
-> NonEmpty (Int, NonEmpty Inline) -> NonEmpty [Bni]
forall a b. (a -> (b, Maybe a)) -> a -> NonEmpty b
NE.unfoldr NonEmpty (Int, NonEmpty Inline)
-> ([Bni], Maybe (NonEmpty (Int, NonEmpty Inline)))
f
  where
    f :: NonEmpty (Int, NonEmpty Inline)
-> ([Bni], Maybe (NonEmpty (Int, NonEmpty Inline)))
f ((Int
n, NonEmpty Inline
x) :| [(Int, NonEmpty Inline)]
xs) =
      let ([(Int, NonEmpty Inline)]
sitems, [(Int, NonEmpty Inline)]
fitems) = ((Int, NonEmpty Inline) -> Bool)
-> [(Int, NonEmpty Inline)]
-> ([(Int, NonEmpty Inline)], [(Int, NonEmpty Inline)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n) (Int -> Bool)
-> ((Int, NonEmpty Inline) -> Int)
-> (Int, NonEmpty Inline)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, NonEmpty Inline) -> Int
forall a b. (a, b) -> a
fst) [(Int, NonEmpty Inline)]
xs
          url :: URI
url = Text -> URI
Ext.headerFragment (NonEmpty Inline -> Text
Ext.headerId NonEmpty Inline
x)
       in ( NonEmpty Inline -> Bni
forall a. a -> Block a
Naked (NonEmpty Inline -> URI -> Maybe Text -> Inline
Link NonEmpty Inline
x URI
url Maybe Text
forall a. Maybe a
Nothing Inline -> [Inline] -> NonEmpty Inline
forall a. a -> [a] -> NonEmpty a
:| []) Bni -> [Bni] -> [Bni]
forall a. a -> [a] -> [a]
:
            Maybe Bni -> [Bni]
forall a. Maybe a -> [a]
maybeToList (NonEmpty (Int, NonEmpty Inline) -> Bni
renderToc (NonEmpty (Int, NonEmpty Inline) -> Bni)
-> Maybe (NonEmpty (Int, NonEmpty Inline)) -> Maybe Bni
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, NonEmpty Inline)] -> Maybe (NonEmpty (Int, NonEmpty Inline))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Int, NonEmpty Inline)]
sitems),
            [(Int, NonEmpty Inline)] -> Maybe (NonEmpty (Int, NonEmpty Inline))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Int, NonEmpty Inline)]
fitems
          )