{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Text.Pandoc.SideNote (usingSideNotes) where

import           Data.List           (intercalate)
import           Data.Text           (Text, append, pack)

import           Control.Monad.State

import           Text.Pandoc.JSON
import           Text.Pandoc.Walk    (walk, walkM)

getFirstStr :: [Inline] -> Maybe Text
getFirstStr :: [Inline] -> Maybe Text
getFirstStr []                 = Maybe Text
forall a. Maybe a
Nothing
getFirstStr (Str Text
text:[Inline]
_      ) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text
getFirstStr (Inline
_       :[Inline]
inlines) = [Inline] -> Maybe Text
getFirstStr [Inline]
inlines

newline :: [Inline]
newline :: [Inline]
newline = [Inline
LineBreak, Inline
LineBreak]

-- This could be implemented more concisely, but I think this is more clear.
getThenIncr :: State Int Int
getThenIncr :: State Int Int
getThenIncr = do
  Int
i <- State Int Int
forall s (m :: * -> *). MonadState s m => m s
get
  Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Int -> State Int Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

-- Extract inlines from blocks
coerceToInline :: [Block] -> [Inline]
coerceToInline :: [Block] -> [Inline]
coerceToInline = (Block -> [Inline]) -> [Block] -> [Inline]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Inline]
deBlock ([Block] -> [Inline])
-> ([Block] -> [Block]) -> [Block] -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Inline) -> [Block] -> [Block]
forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
deNote
 where
  deBlock :: Block -> [Inline]
  deBlock :: Block -> [Inline]
deBlock (Plain     [Inline]
ls    ) = [Inline]
ls
  -- Simulate paragraphs with double LineBreak
  deBlock (Para      [Inline]
ls    ) = [Inline]
ls [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Inline]
newline
  -- See extension: line_blocks
  deBlock (LineBlock [[Inline]]
lss   ) = [Inline] -> [[Inline]] -> [Inline]
forall a. [a] -> [[a]] -> [a]
intercalate [Inline
LineBreak] [[Inline]]
lss [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Inline]
newline
  -- Pretend RawBlock is RawInline (might not work!)
  -- Consider: raw <div> now inside RawInline... what happens?
  deBlock (RawBlock Format
fmt Text
str) = [Format -> Text -> Inline
RawInline Format
fmt Text
str]
  -- lists, blockquotes, headers, hrs, and tables are all omitted
  -- Think they shouldn't be? I'm open to sensible PR's.
  deBlock Block
_                  = []

  deNote :: Inline -> Inline
deNote (Note [Block]
_) = Text -> Inline
Str Text
""
  deNote Inline
x        = Inline
x

filterInline :: Inline -> State Int Inline
filterInline :: Inline -> State Int Inline
filterInline (Note [Block]
blocks) = do
  -- Generate a unique number for the 'for=' attribute
  Int
i <- State Int Int
getThenIncr

  -- Note has a [Block], but Span needs [Inline]
  let content :: [Inline]
content  = [Block] -> [Inline]
coerceToInline [Block]
blocks

  -- The '{-}' symbol differentiates between margin note and side note
  let nonu :: Bool
nonu     = [Inline] -> Maybe Text
getFirstStr [Inline]
content Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"{-}"
  let content' :: [Inline]
content' = if Bool
nonu then [Inline] -> [Inline]
forall a. [a] -> [a]
tail [Inline]
content else [Inline]
content

  let labelCls :: Text
labelCls = Text
"margin-toggle" Text -> Text -> Text
`append`
                 (if Bool
nonu then Text
"" else Text
" sidenote-number")
  let labelSym :: Text
labelSym = if Bool
nonu then Text
"&#8853;" else Text
""
  let labelHTML :: Text
labelHTML = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
         [ Text
"<label for=\"sn-"
         , String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
i)
         , Text
"\" class=\""
         , Text
labelCls
         , Text
"\">"
         , Text
labelSym
         , Text
"</label>"
         ]
  let label :: Inline
label = Format -> Text -> Inline
RawInline (Text -> Format
Format Text
"html") Text
labelHTML

  let inputHTML :: Text
inputHTML = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"<input type=\"checkbox\" id=\"sn-"
        , String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
i)
        , Text
"\" "
        , Text
"class=\"margin-toggle\"/>"
        ]
  let input :: Inline
input             = Format -> Text -> Inline
RawInline (Text -> Format
Format Text
"html") Text
inputHTML

  let (Text
ident, [Text]
_, [(Text, Text)]
attrs) = (Text, [Text], [(Text, Text)])
nullAttr
  let noteTypeCls :: Text
noteTypeCls       = if Bool
nonu then Text
"marginnote" else Text
"sidenote"
  let note :: Inline
note              = (Text, [Text], [(Text, Text)]) -> [Inline] -> Inline
Span (Text
ident, [Text
noteTypeCls], [(Text, Text)]
attrs) [Inline]
content'

  Inline -> State Int Inline
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> State Int Inline) -> Inline -> State Int Inline
forall a b. (a -> b) -> a -> b
$ (Text, [Text], [(Text, Text)]) -> [Inline] -> Inline
Span (Text, [Text], [(Text, Text)])
nullAttr [Inline
label, Inline
input, Inline
note]

filterInline Inline
inline = Inline -> State Int Inline
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
inline

usingSideNotes :: Pandoc -> Pandoc
usingSideNotes :: Pandoc -> Pandoc
usingSideNotes (Pandoc Meta
meta [Block]
blocks) =
  Meta -> [Block] -> Pandoc
Pandoc Meta
meta (State Int [Block] -> Int -> [Block]
forall s a. State s a -> s -> a
evalState ((Inline -> State Int Inline) -> [Block] -> State Int [Block]
forall a b (m :: * -> *).
(Walkable a b, Monad m, Applicative m, Functor m) =>
(a -> m a) -> b -> m b
walkM Inline -> State Int Inline
filterInline [Block]
blocks) Int
0)