{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Reflex.Dom.Pandoc.Footnotes where

import Control.Monad.Reader
import Data.List (nub, sortOn)
import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Map as Map
import qualified Data.Text as T
import Reflex.Dom.Core hiding (Link, Space)
import Text.Pandoc.Definition
import Text.Pandoc.Walk

newtype Footnote = Footnote {Footnote -> [Block]
unFootnote :: [Block]}
  deriving (Footnote -> Footnote -> Bool
(Footnote -> Footnote -> Bool)
-> (Footnote -> Footnote -> Bool) -> Eq Footnote
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Footnote -> Footnote -> Bool
$c/= :: Footnote -> Footnote -> Bool
== :: Footnote -> Footnote -> Bool
$c== :: Footnote -> Footnote -> Bool
Eq, Int -> Footnote -> ShowS
[Footnote] -> ShowS
Footnote -> String
(Int -> Footnote -> ShowS)
-> (Footnote -> String) -> ([Footnote] -> ShowS) -> Show Footnote
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Footnote] -> ShowS
$cshowList :: [Footnote] -> ShowS
show :: Footnote -> String
$cshow :: Footnote -> String
showsPrec :: Int -> Footnote -> ShowS
$cshowsPrec :: Int -> Footnote -> ShowS
Show, Eq Footnote
Eq Footnote
-> (Footnote -> Footnote -> Ordering)
-> (Footnote -> Footnote -> Bool)
-> (Footnote -> Footnote -> Bool)
-> (Footnote -> Footnote -> Bool)
-> (Footnote -> Footnote -> Bool)
-> (Footnote -> Footnote -> Footnote)
-> (Footnote -> Footnote -> Footnote)
-> Ord Footnote
Footnote -> Footnote -> Bool
Footnote -> Footnote -> Ordering
Footnote -> Footnote -> Footnote
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Footnote -> Footnote -> Footnote
$cmin :: Footnote -> Footnote -> Footnote
max :: Footnote -> Footnote -> Footnote
$cmax :: Footnote -> Footnote -> Footnote
>= :: Footnote -> Footnote -> Bool
$c>= :: Footnote -> Footnote -> Bool
> :: Footnote -> Footnote -> Bool
$c> :: Footnote -> Footnote -> Bool
<= :: Footnote -> Footnote -> Bool
$c<= :: Footnote -> Footnote -> Bool
< :: Footnote -> Footnote -> Bool
$c< :: Footnote -> Footnote -> Bool
compare :: Footnote -> Footnote -> Ordering
$ccompare :: Footnote -> Footnote -> Ordering
$cp1Ord :: Eq Footnote
Ord)

type Footnotes = Map Footnote Int

-- | Make a footnote from the Pandoc `Note` node's block elements
mkFootnote :: [Block] -> Footnote
mkFootnote :: [Block] -> Footnote
mkFootnote [Block]
blocks =
  [Block] -> Footnote
Footnote [Block]
blocks

-- | Traverse the Pandoc document accumulating any footnotes
queryFootnotes :: Pandoc -> Footnotes
queryFootnotes :: Pandoc -> Footnotes
queryFootnotes =
  [Footnote] -> Footnotes
buildFootnotes
    ([Footnote] -> Footnotes)
-> (Pandoc -> [Footnote]) -> Pandoc -> Footnotes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> [Footnote]) -> Pandoc -> [Footnote]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query
      ( \case
          Note [Block]
xs -> [[Block] -> Footnote
mkFootnote [Block]
xs]
          Inline
_ -> []
      )
  where
    buildFootnotes :: [Footnote] -> Footnotes
    buildFootnotes :: [Footnote] -> Footnotes
buildFootnotes [Footnote]
fs =
      [(Footnote, Int)] -> Footnotes
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Footnote, Int)] -> Footnotes) -> [(Footnote, Int)] -> Footnotes
forall a b. (a -> b) -> a -> b
$
        (((Footnote, Int) -> (Footnote, Int))
 -> [(Footnote, Int)] -> [(Footnote, Int)])
-> [(Footnote, Int)]
-> ((Footnote, Int) -> (Footnote, Int))
-> [(Footnote, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Footnote, Int) -> (Footnote, Int))
-> [(Footnote, Int)] -> [(Footnote, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Footnote] -> [Int] -> [(Footnote, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Footnote] -> [Footnote]
forall a. Eq a => [a] -> [a]
nub [Footnote]
fs) [Int
1 ..]) (((Footnote, Int) -> (Footnote, Int)) -> [(Footnote, Int)])
-> ((Footnote, Int) -> (Footnote, Int)) -> [(Footnote, Int)]
forall a b. (a -> b) -> a -> b
$ \(Footnote
fn, Int
idx) ->
          (Footnote
fn, Int
idx)

renderFootnotes :: (DomBuilder t m, Monoid a) => ([Block] -> m a) -> Footnotes -> m a
renderFootnotes :: ([Block] -> m a) -> Footnotes -> m a
renderFootnotes [Block] -> m a
render Footnotes
footnotes = do
  if Footnotes -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Footnotes
footnotes
    then a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
    else do
      Text -> Map Text Text -> m a -> m a
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Map Text Text -> m a -> m a
elAttr Text
"div" (Index (Map Text Text)
"id" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: IxValue (Map Text Text)
"footnotes") (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
        Text -> m a -> m a
forall t (m :: * -> *) a. DomBuilder t m => Text -> m a -> m a
el Text
"ol" (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
          ([a] -> a) -> m [a] -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall a. Monoid a => [a] -> a
mconcat (m [a] -> m a) -> m [a] -> m a
forall a b. (a -> b) -> a -> b
$
            [(Footnote, Int)] -> ((Footnote, Int) -> m a) -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (((Footnote, Int) -> Int) -> [(Footnote, Int)] -> [(Footnote, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Footnote, Int) -> Int
forall a b. (a, b) -> b
snd ([(Footnote, Int)] -> [(Footnote, Int)])
-> [(Footnote, Int)] -> [(Footnote, Int)]
forall a b. (a -> b) -> a -> b
$ Footnotes -> [(Footnote, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Footnotes
footnotes) (((Footnote, Int) -> m a) -> m [a])
-> ((Footnote, Int) -> m a) -> m [a]
forall a b. (a -> b) -> a -> b
$ \(Footnote [Block]
blks, Int
idx) -> do
              Text -> Map Text Text -> m a -> m a
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Map Text Text -> m a -> m a
elAttr Text
"li" (Index (Map Text Text)
"id" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: (Text
"fn" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
idx))) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
                a
x <- [Block] -> m a
render [Block]
blks
                -- FIXME: This should appear inline if the footnote is a single paragraph.
                Text -> Map Text Text -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Map Text Text -> m a -> m a
elAttr Text
"a" (Index (Map Text Text)
"href" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: (Text
"#fnref" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
idx))) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall t (m :: * -> *). DomBuilder t m => Text -> m ()
text Text
"↩︎"
                a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

renderFootnoteRef :: DomBuilder t m => Int -> m ()
renderFootnoteRef :: Int -> m ()
renderFootnoteRef Int
idx = do
  Map Text Text -> m () -> m ()
forall t (m :: * -> *).
DomBuilder t m =>
Map Text Text -> m () -> m ()
elNoSnippetSpan Map Text Text
forall k a. Map k a
Map.empty (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> Text -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Text -> m a -> m a
elClass Text
"sup" Text
"footnote-ref" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> Map Text Text -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Map Text Text -> m a -> m a
elAttr Text
"a" (Index (Map Text Text)
"id" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: (Text
"fnref" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
idx)) Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Index (Map Text Text)
"href" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: (Text
"#fn" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
idx))) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m ()
forall t (m :: * -> *). DomBuilder t m => Text -> m ()
text (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
idx
  where
    -- Prevent this element from appearing in Google search results
    -- https://developers.google.com/search/reference/robots_meta_tag#data-nosnippet-attr
    elNoSnippetSpan :: DomBuilder t m => Map Text Text -> m () -> m ()
    elNoSnippetSpan :: Map Text Text -> m () -> m ()
elNoSnippetSpan Map Text Text
attrs = Text -> Map Text Text -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Map Text Text -> m a -> m a
elAttr Text
"span" (Index (Map Text Text)
"data-nosnippet" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: IxValue (Map Text Text)
"" Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Map Text Text
attrs)

sansFootnotes :: DomBuilder t m => ReaderT Footnotes m a -> m a
sansFootnotes :: ReaderT Footnotes m a -> m a
sansFootnotes = (ReaderT Footnotes m a -> Footnotes -> m a)
-> Footnotes -> ReaderT Footnotes m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Footnotes m a -> Footnotes -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Footnotes
forall a. Monoid a => a
mempty