SideNoteHTML.hs

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
   Module      : Text.Pandoc.SideNoteHTML
   Description : Convert pandoc footnotes to sidenotes
   Copyright   : (c) Tony Zorman  2023
   License     : MIT
   Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>
   Stability   : experimental
   Portability : non-portable
-}
module Text.Pandoc.SideNoteHTML (usingSideNotesHTML) where

import Control.Monad (foldM)
import Control.Monad.State (State, get, modify', runState)
import Data.Text (Text)
import Text.Pandoc (runPure, writeHtml5String)
import Text.Pandoc.Definition (Block (..), Inline (..), Pandoc (..))
import Text.Pandoc.Options (WriterOptions)
import Text.Pandoc.Shared (tshow)
import Text.Pandoc.Walk (walkM)
import qualified Data.Text as T

-- type NoteType :: Type
data NoteType = Sidenote | Marginnote
  deriving stock (Show, Eq)

-- type SidenoteState :: Type
data SidenoteState = SNS
  { _writer :: !WriterOptions
  , counter :: !Int
  }

-- type Sidenote :: Type -> Type
type Sidenote = State SidenoteState

-- | Like 'Text.Pandoc.SideNote.usingSideNotes', but immediately
-- pre-render the sidenotes.  This has the advantage that sidenotes may
-- be wrapped in a @<div>@ (instead of a 'Span'), which allows arbitrary
-- blocks to be nested in them.  The disadvantage is that one now has to
-- specify the 'WriterOptions' for the current document, meaning this is
-- meant to be used as a module and is unlikely to be useful as a
-- standalone application.
--
-- ==== __Example__
--
-- Using this function with <https://jaspervdj.be/hakyll/ hakyll> could
-- look something like the following, defining an equivalent to the
-- default @pandocCompiler@.
--
-- > myPandocCompiler :: Compiler (Item String)
-- > myPandocCompiler =
-- >   pandocCompilerWithTransformM
-- >     defaultHakyllReaderOptions
-- >     defaultHakyllWriterOptions
-- >     (usingSideNotesHTML defaultHakyllWriterOptions)
--
usingSideNotesHTML :: WriterOptions -> Pandoc -> Pandoc
usingSideNotesHTML writer (Pandoc meta blocks) =
  -- Drop a superfluous paragraph at the start of the document.
  Pandoc meta . someStart . walkBlocks (SNS writer 0) $ blocks
 where
  someStart :: [Block] -> [Block]
  someStart = \case
    (Para [Str ""] : bs) -> bs
    bs                   -> bs

  walkBlocks :: SidenoteState -> [Block] -> [Block]
  walkBlocks sns = \case
    []       -> []
    (b : bs) -> b' <> walkBlocks s' bs
     where (b', s') = walkM mkSidenote [b] `runState` sns

-- Sidenotes can probably appear in more places; this should be
-- filled-in at some point.
mkSidenote :: [Block] -> Sidenote [Block]
mkSidenote = foldM (\acc b -> (acc <>) <$> single b) []
 where
  -- Try to find and render a sidenote in a single block.
  single :: Block -> Sidenote [Block]
  single = \case
    -- Simulate a paragraph by inserting a dummy block; this is needed
    -- in case two consecutive paragraphs have sidenotes, or a paragraph
    -- doesn't have one at all.
    Para inlines         -> (Para [Str ""] :) <$> renderSidenote [] inlines
    Plain inlines        -> renderSidenote [] inlines
    OrderedList attrs bs -> (:[]) . OrderedList attrs <$> traverse mkSidenote bs
    BulletList        bs -> (:[]) . BulletList        <$> traverse mkSidenote bs
    block                -> pure [block]

renderSidenote :: [Inline] -> [Inline] -> Sidenote [Block]
renderSidenote !inlines = \case
  []           -> pure [plain inlines]
  Note bs : xs -> do block <- go bs
                     mappend [ -- Start gluing before, see [Note Comment].
                               plain (RawInline "html" commentStart : inlines)
                             , block
                             ]
                         <$> renderSidenote
                               [RawInline "html" commentEnd] -- End gluing after
                               xs
  b       : xs -> renderSidenote (b : inlines) xs
 where
  go :: [Block] -> Sidenote Block
  go blocks = do
    SNS w i <- get <* modify' (\sns -> sns{ counter = 1 + counter sns })
    let (typ, noteText) = getNoteType (render w blocks)
    pure . RawBlock "html" $
      mconcat [ commentEnd     -- End gluing before
              , label typ i <> input i <> note typ noteText
              , commentStart   -- Start gluing after
              ]

  -- The '{-}' symbol differentiates between margin note and side note.
  getNoteType :: Text -> (NoteType, Text)
  getNoteType t
    | "{-} " `T.isPrefixOf` t = (Marginnote, T.drop 4 t)
    | otherwise               = (Sidenote  , t)

  render :: WriterOptions -> [Block] -> Text
  render w bs = case runPure (writeHtml5String w (Pandoc mempty bs)) of
    Left  err -> error $ "Text.Pandoc.SideNoteHTML.writePandocWith: " ++ show err
    Right txt -> T.drop 1 (T.dropWhile (/= '\n') txt)

  commentEnd :: T.Text
  commentEnd   = "-->"

  commentStart :: T.Text
  commentStart = "<!--"

  plain :: [Inline] -> Block
  plain = Plain . reverse

label :: NoteType -> Int -> Text
label nt i = "<label for=\"sn-" <> tshow i <> "\" class=\"margin-toggle" <> sidenoteNumber <> "\">" <> altSymbol <> "</label>"
 where
  sidenoteNumber :: Text = case nt of
    Sidenote   -> " sidenote-number"
    Marginnote -> ""
  altSymbol :: Text = case nt of
    Sidenote   -> ""
    Marginnote -> "&#8853;"

input :: Int -> Text
input i = "<input type=\"checkbox\" id=\"sn-" <> tshow i <> "\" class=\"margin-toggle\"/>"

note :: NoteType -> Text -> Text
note nt body = "<div class=\"" <> T.toLower (tshow nt) <> "\">" <> body <> "</div>"

{- [Note Comment]

This is obviously horrible, but we have to do this in order for the
blocks (which are now not inline elements anymore!) immediately before
and after the sidenote to be "glued" to the sidenote itself. In this
way, the number indicating the sidenote does not have an extra space
associated to it on either side, which otherwise would be the case.

-}