{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

-- |
-- Module      :  Text.MMark.Extension.Footnotes
-- Copyright   :  © 2018–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- An extension to add footnotes to your documents.
--
-- @since 0.1.1.0
module Text.MMark.Extension.Footnotes
  ( footnotes,
  )
where

import Control.Monad
import Data.Char (isDigit)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as T
import Lens.Micro ((^.))
import Lucid
import Text.MMark.Extension (Block (..), Extension, Inline (..), getOis)
import qualified Text.MMark.Extension as Ext
import qualified Text.URI as URI
import Text.URI.Lens (uriPath)
import Text.URI.QQ (scheme)

-- | The extension performs two transformations:
--
--     * It turns links with URIs with @footnote@ scheme and single path
--       piece consisting of a number into links to footnote references.
--     * It turns block quotes with the @\"footnotes\"@ label (see the
--       example below) into a footnote section.
--
-- > Here goes some text [1](footnote:1).
-- >
-- > > footnotes
-- >
-- >   1. Here we have the footnote.
--
-- The extension is not fully safe though in the sense that we can't check
-- that a footnote reference refers to an existing footnote and that
-- footnotes have the corresponding references, or that they are present in
-- the document in the right order.
footnotes :: Extension
footnotes :: Extension
footnotes = Extension
footnoteRefs Extension -> Extension -> Extension
forall a. Semigroup a => a -> a -> a
<> Extension
footnoteSection

-- | Create footnote references.
footnoteRefs :: Extension
footnoteRefs :: Extension
footnoteRefs = ((Inline -> Html ()) -> Inline -> Html ()) -> Extension
Ext.inlineRender (((Inline -> Html ()) -> Inline -> Html ()) -> Extension)
-> ((Inline -> Html ()) -> Inline -> Html ()) -> Extension
forall a b. (a -> b) -> a -> b
$ \Inline -> Html ()
old Inline
inline ->
  case Inline
inline of
    l :: Inline
l@(Link NonEmpty Inline
_ URI
uri Maybe Text
_) ->
      if URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri Maybe (RText 'Scheme) -> Maybe (RText 'Scheme) -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'Scheme -> Maybe (RText 'Scheme)
forall a. a -> Maybe a
Just [scheme|footnote|]
        then case URI
uri URI
-> Getting [RText 'PathPiece] URI [RText 'PathPiece]
-> [RText 'PathPiece]
forall s a. s -> Getting a s a -> a
^. Getting [RText 'PathPiece] URI [RText 'PathPiece]
Lens' URI [RText 'PathPiece]
uriPath of
          [RText 'PathPiece
x'] ->
            let x :: Text
x = RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'PathPiece
x'
             in if (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
x
                  then
                    [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_
                      [ Text -> Attribute
fragmentHref (Text -> Text
footnoteId Text
x),
                        Text -> Attribute
id_ (Text -> Text
referenceId Text
x)
                      ]
                      (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Html () -> Html ()
forall arg result. Term arg result => arg -> result
sup_ (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
x)
                  else Inline -> Html ()
old Inline
l
          [RText 'PathPiece]
_ -> Inline -> Html ()
old Inline
l
        else Inline -> Html ()
old Inline
l
    Inline
other -> Inline -> Html ()
old Inline
other

-- | Create a footnote section.
footnoteSection :: Extension
footnoteSection :: Extension
footnoteSection = ((Block (Ois, Html ()) -> Html ())
 -> Block (Ois, Html ()) -> Html ())
-> Extension
Ext.blockRender (((Block (Ois, Html ()) -> Html ())
  -> Block (Ois, Html ()) -> Html ())
 -> Extension)
-> ((Block (Ois, Html ()) -> Html ())
    -> Block (Ois, Html ()) -> Html ())
-> Extension
forall a b. (a -> b) -> a -> b
$ \Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
block ->
  case Block (Ois, Html ())
block of
    b :: Block (Ois, Html ())
b@(Blockquote [Paragraph (Ois
pOis, Html ()
_), OrderedList Word
i NonEmpty [Block (Ois, Html ())]
items]) ->
      if Ois -> NonEmpty Inline
getOis Ois
pOis NonEmpty Inline -> NonEmpty Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Inline
Plain Text
"footnotes" Inline -> [Inline] -> NonEmpty Inline
forall a. a -> [a] -> NonEmpty a
:| []
        then do
          let startIndex :: [Attribute]
startIndex = [Text -> Attribute
start_ (Word -> Text
renderIx Word
i) | Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
1]
              renderIx :: Word -> Text
renderIx = String -> Text
T.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show
          [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
ol_ [Attribute]
startIndex (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
            Html ()
newline
            NonEmpty (Word, [Block (Ois, Html ())])
-> ((Word, [Block (Ois, Html ())]) -> Html ()) -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (NonEmpty Word
-> NonEmpty [Block (Ois, Html ())]
-> NonEmpty (Word, [Block (Ois, Html ())])
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip ((Word -> Word) -> Word -> NonEmpty Word
forall a. (a -> a) -> a -> NonEmpty a
NE.iterate (Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) Word
i) NonEmpty [Block (Ois, Html ())]
items) (((Word, [Block (Ois, Html ())]) -> Html ()) -> Html ())
-> ((Word, [Block (Ois, Html ())]) -> Html ()) -> Html ()
forall a b. (a -> b) -> a -> b
$ \(Word
j, [Block (Ois, Html ())]
x) -> do
              let j' :: Text
j' = Word -> Text
renderIx Word
j
              [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
li_ [Text -> Attribute
id_ (Text -> Text
footnoteId Text
j')] (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
                Html ()
newline
                (Block (Ois, Html ()) -> Html ())
-> [Block (Ois, Html ())] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block (Ois, Html ()) -> Html ()
old [Block (Ois, Html ())]
x
                [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
fragmentHref (Text -> Text
referenceId Text
j')] Html ()
"↩"
              Html ()
newline
          Html ()
newline
        else Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
b
    Block (Ois, Html ())
other -> Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
other
  where
    newline :: Html ()
newline = Html ()
"\n"

fragmentHref :: Text -> Attribute
fragmentHref :: Text -> Attribute
fragmentHref = Text -> Attribute
href_ (Text -> Attribute) -> (Text -> Text) -> Text -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Text
URI.render (URI -> Text) -> (Text -> URI) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> URI
Ext.headerFragment

footnoteId :: Text -> Text
footnoteId :: Text -> Text
footnoteId Text
x = Text
"fn" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x

referenceId :: Text -> Text
referenceId :: Text -> Text
referenceId Text
x = Text
"fnref" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x