{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
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)
footnotes :: Extension
= Extension
footnoteRefs Extension -> Extension -> Extension
forall a. Semigroup a => a -> a -> a
<> Extension
footnoteSection
footnoteRefs :: Extension
= ((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
footnoteSection :: Extension
= ((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
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