{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Writers.FB2 (writeFB2) where
import Control.Monad (zipWithM)
import Control.Monad.Except (catchError)
import Control.Monad.State.Strict (StateT, evalStateT, get, gets, lift, liftM, modify)
import Data.ByteString.Base64 (encode)
import Data.Char (isAscii, isControl, isSpace)
import Data.Either (lefts, rights)
import Data.List (intercalate)
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Network.HTTP (urlEncode)
import Text.XML.Light
import qualified Text.XML.Light as X
import qualified Text.XML.Light.Cursor as XC
import qualified Text.XML.Light.Input as XI
import Text.Pandoc.Class.PandocMonad (PandocMonad, report)
import qualified Text.Pandoc.Class.PandocMonad as P
import Text.Pandoc.Definition
import Text.Pandoc.Logging
import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..), def)
import Text.Pandoc.Shared (capitalize, isURI, orderedListMarkers,
makeSections, tshow)
import Text.Pandoc.Writers.Shared (lookupMetaString)
data FbRenderState = FbRenderState
{ :: [ (Int, Text, [Content]) ]
, FbRenderState -> [(Text, Text)]
imagesToFetch :: [ (Text, Text) ]
, FbRenderState -> Text
parentListMarker :: Text
, FbRenderState -> WriterOptions
writerOptions :: WriterOptions
} deriving (Int -> FbRenderState -> ShowS
[FbRenderState] -> ShowS
FbRenderState -> String
(Int -> FbRenderState -> ShowS)
-> (FbRenderState -> String)
-> ([FbRenderState] -> ShowS)
-> Show FbRenderState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FbRenderState] -> ShowS
$cshowList :: [FbRenderState] -> ShowS
show :: FbRenderState -> String
$cshow :: FbRenderState -> String
showsPrec :: Int -> FbRenderState -> ShowS
$cshowsPrec :: Int -> FbRenderState -> ShowS
Show)
type FBM m = StateT FbRenderState m
newFB :: FbRenderState
newFB :: FbRenderState
newFB = FbRenderState :: [(Int, Text, [Content])]
-> [(Text, Text)] -> Text -> WriterOptions -> FbRenderState
FbRenderState { footnotes :: [(Int, Text, [Content])]
footnotes = [], imagesToFetch :: [(Text, Text)]
imagesToFetch = []
, parentListMarker :: Text
parentListMarker = ""
, writerOptions :: WriterOptions
writerOptions = WriterOptions
forall a. Default a => a
def }
data ImageMode = NormalImage | InlineImage deriving (ImageMode -> ImageMode -> Bool
(ImageMode -> ImageMode -> Bool)
-> (ImageMode -> ImageMode -> Bool) -> Eq ImageMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageMode -> ImageMode -> Bool
$c/= :: ImageMode -> ImageMode -> Bool
== :: ImageMode -> ImageMode -> Bool
$c== :: ImageMode -> ImageMode -> Bool
Eq)
instance Show ImageMode where
show :: ImageMode -> String
show NormalImage = "imageType"
show InlineImage = "inlineImageType"
writeFB2 :: PandocMonad m
=> WriterOptions
-> Pandoc
-> m Text
writeFB2 :: WriterOptions -> Pandoc -> m Text
writeFB2 opts :: WriterOptions
opts doc :: Pandoc
doc = (StateT FbRenderState m Text -> FbRenderState -> m Text)
-> FbRenderState -> StateT FbRenderState m Text -> m Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT FbRenderState m Text -> FbRenderState -> m Text
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT FbRenderState
newFB (StateT FbRenderState m Text -> m Text)
-> StateT FbRenderState m Text -> m Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> StateT FbRenderState m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> FBM m Text
pandocToFB2 WriterOptions
opts Pandoc
doc
pandocToFB2 :: PandocMonad m
=> WriterOptions
-> Pandoc
-> FBM m Text
pandocToFB2 :: WriterOptions -> Pandoc -> FBM m Text
pandocToFB2 opts :: WriterOptions
opts (Pandoc meta :: Meta
meta blocks :: [Block]
blocks) = do
(FbRenderState -> FbRenderState) -> StateT FbRenderState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: FbRenderState
s -> FbRenderState
s { writerOptions :: WriterOptions
writerOptions = WriterOptions
opts })
Content
desc <- Meta -> FBM m Content
forall (m :: * -> *). PandocMonad m => Meta -> FBM m Content
description Meta
meta
[Content]
title <- (Inline -> StateT FbRenderState m [Content])
-> [Inline] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> StateT FbRenderState m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml ([Inline] -> StateT FbRenderState m [Content])
-> (Meta -> [Inline]) -> Meta -> StateT FbRenderState m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Inline]
docTitle (Meta -> StateT FbRenderState m [Content])
-> Meta -> StateT FbRenderState m [Content]
forall a b. (a -> b) -> a -> b
$ Meta
meta
[Content]
secs <- Int -> [Block] -> StateT FbRenderState m [Content]
forall (m :: * -> *).
PandocMonad m =>
Int -> [Block] -> FBM m [Content]
renderSections 1 [Block]
blocks
let body :: Content
body = String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "body" ([Content] -> Content) -> [Content] -> Content
forall a b. (a -> b) -> a -> b
$ String -> Content -> Content
forall t. Node t => String -> t -> Content
el "title" (String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "p" [Content]
title) Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
secs
[Content]
notes <- StateT FbRenderState m [Content]
forall (m :: * -> *). PandocMonad m => FBM m [Content]
renderFootnotes
(imgs :: [Content]
imgs,missing :: [Text]
missing) <- (FbRenderState -> [(Text, Text)])
-> StateT FbRenderState m FbRenderState
-> StateT FbRenderState m [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FbRenderState -> [(Text, Text)]
imagesToFetch StateT FbRenderState m FbRenderState
forall s (m :: * -> *). MonadState s m => m s
get StateT FbRenderState m [(Text, Text)]
-> ([(Text, Text)] -> StateT FbRenderState m ([Content], [Text]))
-> StateT FbRenderState m ([Content], [Text])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: [(Text, Text)]
s -> m ([Content], [Text]) -> StateT FbRenderState m ([Content], [Text])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([(Text, Text)] -> m ([Content], [Text])
forall (m :: * -> *).
PandocMonad m =>
[(Text, Text)] -> m ([Content], [Text])
fetchImages [(Text, Text)]
s)
let body' :: Content
body' = [Text] -> Content -> Content
replaceImagesWithAlt [Text]
missing Content
body
let fb2_xml :: Content
fb2_xml = String -> ([Attr], [Content]) -> Content
forall t. Node t => String -> t -> Content
el "FictionBook" ([Attr]
fb2_attrs, [Content
desc, Content
body'] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
notes [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
imgs)
Text -> FBM m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> FBM m Text) -> Text -> FBM m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
xml_head String -> ShowS
forall a. [a] -> [a] -> [a]
++ Content -> String
showContent Content
fb2_xml String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
where
xml_head :: String
xml_head = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
fb2_attrs :: [Attr]
fb2_attrs =
let xmlns :: Text
xmlns = "http://www.gribuser.ru/xml/fictionbook/2.0"
xlink :: Text
xlink = "http://www.w3.org/1999/xlink"
in [ String -> Text -> Attr
uattr "xmlns" Text
xmlns
, (String, String) -> Text -> Attr
attr ("xmlns", "l") Text
xlink ]
description :: PandocMonad m => Meta -> FBM m Content
description :: Meta -> FBM m Content
description meta' :: Meta
meta' = do
let genre :: Content
genre = case Text -> Meta -> Text
lookupMetaString "genre" Meta
meta' of
"" -> String -> String -> Content
forall t. Node t => String -> t -> Content
el "genre" ("unrecognised" :: String)
s :: Text
s -> String -> String -> Content
forall t. Node t => String -> t -> Content
el "genre" (Text -> String
T.unpack Text
s)
[Content]
bt <- Meta -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Meta -> FBM m [Content]
booktitle Meta
meta'
let as :: [Content]
as = Meta -> [Content]
authors Meta
meta'
[Content]
dd <- Meta -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Meta -> FBM m [Content]
docdate Meta
meta'
[Content]
annotation <- case Text -> Meta -> Maybe MetaValue
lookupMeta "abstract" Meta
meta' of
Just (MetaBlocks bs :: [Block]
bs) -> Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> ([Content] -> Content) -> [Content] -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "annotation" ([Content] -> [Content]) -> FBM m [Content] -> FBM m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml ((Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Block
unPlain [Block]
bs)
_ -> [Content] -> FBM m [Content]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Content]
forall a. Monoid a => a
mempty
let lang :: [Content]
lang = case Text -> Meta -> Maybe MetaValue
lookupMeta "lang" Meta
meta' of
Just (MetaInlines [Str s :: Text
s]) -> [String -> String -> Content
forall t. Node t => String -> t -> Content
el "lang" (String -> Content) -> String -> Content
forall a b. (a -> b) -> a -> b
$ Text -> String
iso639 Text
s]
Just (MetaString s :: Text
s) -> [String -> String -> Content
forall t. Node t => String -> t -> Content
el "lang" (String -> Content) -> String -> Content
forall a b. (a -> b) -> a -> b
$ Text -> String
iso639 Text
s]
_ -> []
where iso639 :: Text -> String
iso639 = Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '-')
let coverimage :: Text -> StateT FbRenderState m [Content]
coverimage url :: Text
url = do
let img :: Inline
img = Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
nullAttr [Inline]
forall a. Monoid a => a
mempty (Text
url, "")
[Content]
im <- ImageMode -> Inline -> StateT FbRenderState m [Content]
forall (m :: * -> *).
PandocMonad m =>
ImageMode -> Inline -> FBM m [Content]
insertImage ImageMode
InlineImage Inline
img
[Content] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "coverpage" [Content]
im]
[Content]
coverpage <- case Text -> Meta -> Maybe MetaValue
lookupMeta "cover-image" Meta
meta' of
Just (MetaInlines [Str s :: Text
s]) -> Text -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> StateT FbRenderState m [Content]
coverimage Text
s
Just (MetaString s :: Text
s) -> Text -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> StateT FbRenderState m [Content]
coverimage Text
s
_ -> [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Content -> FBM m Content
forall (m :: * -> *) a. Monad m => a -> m a
return (Content -> FBM m Content) -> Content -> FBM m Content
forall a b. (a -> b) -> a -> b
$ String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "description"
[ String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "title-info" (Content
genre Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
:
([Content]
as [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
bt [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
annotation [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
dd [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
coverpage [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
lang))
, String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "document-info" [String -> String -> Content
forall t. Node t => String -> t -> Content
el "program-used" ("pandoc" :: String)]
]
booktitle :: PandocMonad m => Meta -> FBM m [Content]
booktitle :: Meta -> FBM m [Content]
booktitle meta' :: Meta
meta' = do
[Content]
t <- (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml ([Inline] -> FBM m [Content])
-> (Meta -> [Inline]) -> Meta -> FBM m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Inline]
docTitle (Meta -> FBM m [Content]) -> Meta -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ Meta
meta'
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content]) -> [Content] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ [String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "book-title" [Content]
t | Bool -> Bool
not ([Content] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Content]
t)]
authors :: Meta -> [Content]
authors :: Meta -> [Content]
authors meta' :: Meta
meta' = ([Inline] -> [Content]) -> [[Inline]] -> [Content]
forall a b. (a -> [b]) -> [a] -> [b]
cMap [Inline] -> [Content]
author (Meta -> [[Inline]]
docAuthors Meta
meta')
author :: [Inline] -> [Content]
author :: [Inline] -> [Content]
author ss :: [Inline]
ss =
let ws :: [String]
ws = String -> [String]
words (String -> [String])
-> ([Inline] -> String) -> [Inline] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain ([Inline] -> [String]) -> [Inline] -> [String]
forall a b. (a -> b) -> a -> b
$ [Inline]
ss
email :: [Content]
email = String -> String -> Content
forall t. Node t => String -> t -> Content
el "email" (String -> Content) -> [String] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take 1 ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ('@' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [String]
ws)
ws' :: [String]
ws' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ('@' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`) [String]
ws
names :: [Content]
names = case [String]
ws' of
[nickname :: String
nickname] -> [ String -> String -> Content
forall t. Node t => String -> t -> Content
el "nickname" String
nickname ]
[fname :: String
fname, lname :: String
lname] -> [ String -> String -> Content
forall t. Node t => String -> t -> Content
el "first-name" String
fname
, String -> String -> Content
forall t. Node t => String -> t -> Content
el "last-name" String
lname ]
(fname :: String
fname:rest :: [String]
rest) -> [ String -> String -> Content
forall t. Node t => String -> t -> Content
el "first-name" String
fname
, String -> String -> Content
forall t. Node t => String -> t -> Content
el "middle-name" ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
init ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
rest)
, String -> String -> Content
forall t. Node t => String -> t -> Content
el "last-name" ([String] -> String
forall a. [a] -> a
last [String]
rest) ]
[] -> []
in Content -> [Content]
forall a. a -> [a]
list (Content -> [Content]) -> Content -> [Content]
forall a b. (a -> b) -> a -> b
$ String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "author" ([Content]
names [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
email)
docdate :: PandocMonad m => Meta -> FBM m [Content]
docdate :: Meta -> FBM m [Content]
docdate meta' :: Meta
meta' = do
let ss :: [Inline]
ss = Meta -> [Inline]
docDate Meta
meta'
[Content]
d <- (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ss
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content]) -> [Content] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ [String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "date" [Content]
d | Bool -> Bool
not ([Content] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Content]
d)]
renderSections :: PandocMonad m => Int -> [Block] -> FBM m [Content]
renderSections :: Int -> [Block] -> FBM m [Content]
renderSections level :: Int
level blocks :: [Block]
blocks = do
let blocks' :: [Block]
blocks' = Bool -> Maybe Int -> [Block] -> [Block]
makeSections Bool
False Maybe Int
forall a. Maybe a
Nothing [Block]
blocks
let isSection :: Block -> Bool
isSection (Div (_,"section":_,_) (Header{}:_)) = Bool
True
isSection _ = Bool
False
let (initialBlocks :: [Block]
initialBlocks, secs :: [Block]
secs) = (Block -> Bool) -> [Block] -> ([Block], [Block])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Block -> Bool
isSection [Block]
blocks'
let blocks'' :: [Block]
blocks'' = if [Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
initialBlocks
then [Block]
blocks'
else Attr -> [Block] -> Block
Div ("",["section"],[])
(Int -> Attr -> [Inline] -> Block
Header 1 Attr
nullAttr [Inline]
forall a. Monoid a => a
mempty Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
initialBlocks) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
secs
(Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM (Int -> Block -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
Int -> Block -> FBM m [Content]
renderSection Int
level) [Block]
blocks''
renderSection :: PandocMonad m => Int -> Block -> FBM m [Content]
renderSection :: Int -> Block -> FBM m [Content]
renderSection lvl :: Int
lvl (Div (id' :: Text
id',"section":_,_) (Header _ _ title :: [Inline]
title : xs :: [Block]
xs)) = do
[Content]
title' <- if [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
title
then [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> ([Content] -> Content) -> [Content] -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "title" ([Content] -> [Content]) -> FBM m [Content] -> FBM m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => [Inline] -> FBM m [Content]
formatTitle [Inline]
title
[Content]
content <- (Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM (Int -> Block -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
Int -> Block -> FBM m [Content]
renderSection (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)) [Block]
xs
let sectionContent :: Content
sectionContent = if Text -> Bool
T.null Text
id'
then String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "section" ([Content]
title' [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
content)
else String -> ([Attr], [Content]) -> Content
forall t. Node t => String -> t -> Content
el "section" ([String -> Text -> Attr
uattr "id" Text
id'], [Content]
title' [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
content)
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content
sectionContent]
renderSection _ b :: Block
b = Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml Block
b
formatTitle :: PandocMonad m => [Inline] -> FBM m [Content]
formatTitle :: [Inline] -> FBM m [Content]
formatTitle inlines :: [Inline]
inlines =
([Inline] -> FBM m [Content]) -> [[Inline]] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM (Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml (Block -> FBM m [Content])
-> ([Inline] -> Block) -> [Inline] -> FBM m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Block
Para) ([[Inline]] -> FBM m [Content]) -> [[Inline]] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ (Inline -> Bool) -> [Inline] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [[a]]
split (Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Inline
LineBreak) [Inline]
inlines
split :: (a -> Bool) -> [a] -> [[a]]
split :: (a -> Bool) -> [a] -> [[a]]
split _ [] = []
split cond :: a -> Bool
cond xs :: [a]
xs = let (b :: [a]
b,a :: [a]
a) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
cond [a]
xs
in ([a]
b[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:(a -> Bool) -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [[a]]
split a -> Bool
cond (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop 1 [a]
a))
isLineBreak :: Inline -> Bool
isLineBreak :: Inline -> Bool
isLineBreak LineBreak = Bool
True
isLineBreak _ = Bool
False
renderFootnotes :: PandocMonad m => FBM m [Content]
= do
[(Int, Text, [Content])]
fns <- FbRenderState -> [(Int, Text, [Content])]
footnotes (FbRenderState -> [(Int, Text, [Content])])
-> StateT FbRenderState m FbRenderState
-> StateT FbRenderState m [(Int, Text, [Content])]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` StateT FbRenderState m FbRenderState
forall s (m :: * -> *). MonadState s m => m s
get
if [(Int, Text, [Content])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Text, [Content])]
fns
then [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content])
-> (Content -> [Content]) -> Content -> FBM m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> [Content]
forall a. a -> [a]
list (Content -> FBM m [Content]) -> Content -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$
String -> ([Attr], [Content]) -> Content
forall t. Node t => String -> t -> Content
el "body" ([String -> Text -> Attr
uattr "name" "notes"], ((Int, Text, [Content]) -> Content)
-> [(Int, Text, [Content])] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Text, [Content]) -> Content
forall a. Show a => (a, Text, [Content]) -> Content
renderFN ([(Int, Text, [Content])] -> [(Int, Text, [Content])]
forall a. [a] -> [a]
reverse [(Int, Text, [Content])]
fns))
where
renderFN :: (a, Text, [Content]) -> Content
renderFN (n :: a
n, idstr :: Text
idstr, cs :: [Content]
cs) =
let fn_texts :: [Content]
fn_texts = String -> Content -> Content
forall t. Node t => String -> t -> Content
el "title" (String -> String -> Content
forall t. Node t => String -> t -> Content
el "p" (a -> String
forall a. Show a => a -> String
show a
n)) Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
cs
in String -> ([Attr], [Content]) -> Content
forall t. Node t => String -> t -> Content
el "section" ([String -> Text -> Attr
uattr "id" Text
idstr], [Content]
fn_texts)
fetchImages :: PandocMonad m => [(Text,Text)] -> m ([Content],[Text])
fetchImages :: [(Text, Text)] -> m ([Content], [Text])
fetchImages links :: [(Text, Text)]
links = do
[Either Text Content]
imgs <- ((Text, Text) -> m (Either Text Content))
-> [(Text, Text)] -> m [Either Text Content]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Text -> Text -> m (Either Text Content))
-> (Text, Text) -> m (Either Text Content)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> m (Either Text Content)
forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> m (Either Text Content)
fetchImage) [(Text, Text)]
links
([Content], [Text]) -> m ([Content], [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either Text Content] -> [Content]
forall a b. [Either a b] -> [b]
rights [Either Text Content]
imgs, [Either Text Content] -> [Text]
forall a b. [Either a b] -> [a]
lefts [Either Text Content]
imgs)
fetchImage :: PandocMonad m => Text -> Text -> m (Either Text Content)
fetchImage :: Text -> Text -> m (Either Text Content)
fetchImage href :: Text
href link :: Text
link = do
Maybe (Text, Text)
mbimg <-
case (Text -> Bool
isURI Text
link, Text -> Maybe (Text, Text, Bool, Text)
readDataURI Text
link) of
(True, Just (mime :: Text
mime,_,True,base64 :: Text
base64)) ->
let mime' :: Text
mime' = Text -> Text
T.toLower Text
mime
in if Text
mime' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "image/png" Bool -> Bool -> Bool
|| Text
mime' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "image/jpeg"
then Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
mime',Text
base64))
else Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, Text)
forall a. Maybe a
Nothing
(True, Just _) -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, Text)
forall a. Maybe a
Nothing
_ ->
m (Maybe (Text, Text))
-> (PandocError -> m (Maybe (Text, Text)))
-> m (Maybe (Text, Text))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (do (bs :: ByteString
bs, mbmime :: Maybe Text
mbmime) <- Text -> m (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem Text
link
case Maybe Text
mbmime of
Nothing -> do
LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
CouldNotDetermineMimeType Text
link
Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, Text)
forall a. Maybe a
Nothing
Just mime :: Text
mime -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, Text) -> m (Maybe (Text, Text)))
-> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
mime,
ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encode ByteString
bs))
(\e :: PandocError
e ->
do LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
link (PandocError -> Text
forall a. Show a => a -> Text
tshow PandocError
e)
Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, Text)
forall a. Maybe a
Nothing)
case Maybe (Text, Text)
mbimg of
Just (imgtype :: Text
imgtype, imgdata :: Text
imgdata) ->
Either Text Content -> m (Either Text Content)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Content -> m (Either Text Content))
-> (Content -> Either Text Content)
-> Content
-> m (Either Text Content)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Either Text Content
forall a b. b -> Either a b
Right (Content -> m (Either Text Content))
-> Content -> m (Either Text Content)
forall a b. (a -> b) -> a -> b
$ String -> ([Attr], Content) -> Content
forall t. Node t => String -> t -> Content
el "binary"
( [String -> Text -> Attr
uattr "id" Text
href
, String -> Text -> Attr
uattr "content-type" Text
imgtype]
, Text -> Content
txt Text
imgdata )
_ -> Either Text Content -> m (Either Text Content)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text Content
forall a b. a -> Either a b
Left ("#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
href))
readDataURI :: Text
-> Maybe (Text,Text,Bool,Text)
readDataURI :: Text -> Maybe (Text, Text, Bool, Text)
readDataURI uri :: Text
uri =
case Text -> Text -> Maybe Text
T.stripPrefix "data:" Text
uri of
Nothing -> Maybe (Text, Text, Bool, Text)
forall a. Maybe a
Nothing
Just rest :: Text
rest ->
let meta :: Text
meta = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ',') Text
rest
uridata :: Text
uridata = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
meta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Text
rest
parts :: [Text]
parts = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ';') Text
meta
(mime :: Text
mime,cs :: Text
cs,enc :: Bool
enc)=(Text -> (Text, Text, Bool) -> (Text, Text, Bool))
-> (Text, Text, Bool) -> [Text] -> (Text, Text, Bool)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> (Text, Text, Bool) -> (Text, Text, Bool)
upd ("text/plain","US-ASCII",Bool
False) [Text]
parts
in (Text, Text, Bool, Text) -> Maybe (Text, Text, Bool, Text)
forall a. a -> Maybe a
Just (Text
mime,Text
cs,Bool
enc,Text
uridata)
where
upd :: Text -> (Text, Text, Bool) -> (Text, Text, Bool)
upd str :: Text
str m :: (Text, Text, Bool)
m@(mime :: Text
mime,cs :: Text
cs,enc :: Bool
enc)
| Text -> Bool
isMimeType Text
str = (Text
str,Text
cs,Bool
enc)
| Just str' :: Text
str' <- Text -> Text -> Maybe Text
T.stripPrefix "charset=" Text
str = (Text
mime,Text
str',Bool
enc)
| Text
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "base64" = (Text
mime,Text
cs,Bool
True)
| Bool
otherwise = (Text, Text, Bool)
m
isMimeType :: Text -> Bool
isMimeType :: Text -> Bool
isMimeType s :: Text
s =
case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') Text
s of
[mtype :: Text
mtype,msubtype :: Text
msubtype] ->
(Text -> Text
T.toLower Text
mtype Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
types
Bool -> Bool -> Bool
|| "x-" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.toLower Text
mtype)
Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
valid Text
mtype
Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
valid Text
msubtype
_ -> Bool
False
where
types :: [Text]
types = ["text","image","audio","video","application","message","multipart"]
valid :: Char -> Bool
valid c :: Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isControl Char
c) Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&&
Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ("()<>@,;:\\\"/[]?=" :: String)
footnoteID :: Int -> Text
i :: Int
i = "n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i
mkitem :: PandocMonad m => Text -> [Block] -> FBM m [Content]
mkitem :: Text -> [Block] -> FBM m [Content]
mkitem mrk :: Text
mrk bs :: [Block]
bs = do
Text
pmrk <- (FbRenderState -> Text) -> StateT FbRenderState m Text
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FbRenderState -> Text
parentListMarker
let nmrk :: Text
nmrk = Text
pmrk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mrk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " "
(FbRenderState -> FbRenderState) -> StateT FbRenderState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: FbRenderState
s -> FbRenderState
s { parentListMarker :: Text
parentListMarker = Text
nmrk})
[Content]
item <- (Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml ([Block] -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
plainToPara ([Block] -> [Block]) -> [Block] -> [Block]
forall a b. (a -> b) -> a -> b
$ Text -> [Block] -> [Block]
indentBlocks Text
nmrk [Block]
bs
(FbRenderState -> FbRenderState) -> StateT FbRenderState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: FbRenderState
s -> FbRenderState
s { parentListMarker :: Text
parentListMarker = Text
pmrk })
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
item
blockToXml :: PandocMonad m => Block -> FBM m [Content]
blockToXml :: Block -> FBM m [Content]
blockToXml (Plain ss :: [Inline]
ss) = (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ss
blockToXml (Para [Math DisplayMath formula :: Text
formula]) = ImageMode -> Text -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
ImageMode -> Text -> FBM m [Content]
insertMath ImageMode
NormalImage Text
formula
blockToXml (Para [Image atr :: Attr
atr alt :: [Inline]
alt (src :: Text
src,tgt :: Text
tgt)])
| Just tit :: Text
tit <- Text -> Text -> Maybe Text
T.stripPrefix "fig:" Text
tgt
= ImageMode -> Inline -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
ImageMode -> Inline -> FBM m [Content]
insertImage ImageMode
NormalImage (Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
atr [Inline]
alt (Text
src,Text
tit))
blockToXml (Para ss :: [Inline]
ss) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> ([Content] -> Content) -> [Content] -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "p" ([Content] -> [Content]) -> FBM m [Content] -> FBM m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ss
blockToXml (CodeBlock _ s :: Text
s) = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content])
-> (Text -> [Content]) -> Text -> FBM m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Content] -> [Content]
spaceBeforeAfter ([Content] -> [Content])
-> (Text -> [Content]) -> Text -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Text -> Content) -> [Text] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Content -> Content
forall t. Node t => String -> t -> Content
el "p" (Content -> Content) -> (Text -> Content) -> Text -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Content
forall t. Node t => String -> t -> Content
el "code" (String -> Content) -> (Text -> String) -> Text -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> [Content]) -> (Text -> [Text]) -> Text -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> FBM m [Content]) -> Text -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ Text
s
blockToXml (RawBlock f :: Format
f str :: Text
str) =
if Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format "fb2"
then [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content]) -> [Content] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ Text -> [Content]
forall s. XmlSource s => s -> [Content]
XI.parseXML Text
str
else [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
blockToXml (Div _ bs :: [Block]
bs) = (Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml [Block]
bs
blockToXml (BlockQuote bs :: [Block]
bs) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> ([Content] -> Content) -> [Content] -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "cite" ([Content] -> [Content]) -> FBM m [Content] -> FBM m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml [Block]
bs
blockToXml (LineBlock lns :: [[Inline]]
lns) =
Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> ([Content] -> Content) -> [Content] -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "poem" ([Content] -> [Content]) -> FBM m [Content] -> FBM m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([[Inline]] -> StateT FbRenderState m Content)
-> [[[Inline]]] -> FBM m [Content]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [[Inline]] -> StateT FbRenderState m Content
forall (t :: * -> *) (m :: * -> *).
(Node (t Content), Traversable t, PandocMonad m) =>
t [Inline] -> StateT FbRenderState m Content
stanza (([Inline] -> Bool) -> [[Inline]] -> [[[Inline]]]
forall a. (a -> Bool) -> [a] -> [[a]]
split [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Inline]]
lns)
where
v :: [Inline] -> StateT FbRenderState m Content
v xs :: [Inline]
xs = String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "v" ([Content] -> Content)
-> StateT FbRenderState m [Content]
-> StateT FbRenderState m Content
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> StateT FbRenderState m [Content])
-> [Inline] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> StateT FbRenderState m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
xs
stanza :: t [Inline] -> StateT FbRenderState m Content
stanza xs :: t [Inline]
xs = String -> t Content -> Content
forall t. Node t => String -> t -> Content
el "stanza" (t Content -> Content)
-> StateT FbRenderState m (t Content)
-> StateT FbRenderState m Content
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Inline] -> StateT FbRenderState m Content)
-> t [Inline] -> StateT FbRenderState m (t Content)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Inline] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> StateT FbRenderState m Content
v t [Inline]
xs
blockToXml (OrderedList a :: ListAttributes
a bss :: [[Block]]
bss) =
[[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Content]] -> [Content])
-> StateT FbRenderState m [[Content]] -> FBM m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> [Block] -> FBM m [Content])
-> [Text] -> [[Block]] -> StateT FbRenderState m [[Content]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Text -> [Block] -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Block] -> FBM m [Content]
mkitem [Text]
markers [[Block]]
bss
where
markers :: [Text]
markers = ListAttributes -> [Text]
orderedListMarkers ListAttributes
a
blockToXml (BulletList bss :: [[Block]]
bss) =
([Block] -> FBM m [Content]) -> [[Block]] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM (Text -> [Block] -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Block] -> FBM m [Content]
mkitem "•") [[Block]]
bss
blockToXml (DefinitionList defs :: [([Inline], [[Block]])]
defs) =
(([Inline], [[Block]]) -> FBM m [Content])
-> [([Inline], [[Block]])] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM ([Inline], [[Block]]) -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
([Inline], [[Block]]) -> StateT FbRenderState m [Content]
mkdef [([Inline], [[Block]])]
defs
where
mkdef :: ([Inline], [[Block]]) -> StateT FbRenderState m [Content]
mkdef (term :: [Inline]
term, bss :: [[Block]]
bss) = do
[Content]
items <- ([Block] -> StateT FbRenderState m [Content])
-> [[Block]] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM ((Block -> StateT FbRenderState m [Content])
-> [Block] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> StateT FbRenderState m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml ([Block] -> StateT FbRenderState m [Content])
-> ([Block] -> [Block])
-> [Block]
-> StateT FbRenderState m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> [Block]
plainToPara ([Block] -> [Block]) -> ([Block] -> [Block]) -> [Block] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Block] -> [Block]
indentBlocks (Int -> Text -> Text
T.replicate 4 " ")) [[Block]]
bss
Content
t <- String -> [Inline] -> FBM m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [Inline] -> FBM m Content
wrap "strong" [Inline]
term
[Content] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Content -> Content
forall t. Node t => String -> t -> Content
el "p" Content
t Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
items)
blockToXml h :: Block
h@Header{} = do
LogMessage -> StateT FbRenderState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FbRenderState m ())
-> LogMessage -> StateT FbRenderState m ()
forall a b. (a -> b) -> a -> b
$ Block -> LogMessage
BlockNotRendered Block
h
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
blockToXml HorizontalRule = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> () -> Content
forall t. Node t => String -> t -> Content
el "empty-line" () ]
blockToXml (Table caption :: [Inline]
caption aligns :: [Alignment]
aligns _ headers :: [[Block]]
headers rows :: [[[Block]]]
rows) = do
Content
hd <- String
-> [[Block]] -> [Alignment] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [[Block]] -> [Alignment] -> FBM m Content
mkrow "th" [[Block]]
headers [Alignment]
aligns
[Content]
bd <- ([[Block]] -> StateT FbRenderState m Content)
-> [[[Block]]] -> FBM m [Content]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\r :: [[Block]]
r -> String
-> [[Block]] -> [Alignment] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [[Block]] -> [Alignment] -> FBM m Content
mkrow "td" [[Block]]
r [Alignment]
aligns) [[[Block]]]
rows
Content
c <- String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "emphasis" ([Content] -> Content)
-> FBM m [Content] -> StateT FbRenderState m Content
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
caption
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "table" (Content
hd Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
bd), String -> Content -> Content
forall t. Node t => String -> t -> Content
el "p" Content
c]
where
mkrow :: PandocMonad m => String -> [TableCell] -> [Alignment] -> FBM m Content
mkrow :: String -> [[Block]] -> [Alignment] -> FBM m Content
mkrow tag :: String
tag cells :: [[Block]]
cells aligns' :: [Alignment]
aligns' =
String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el "tr" ([Content] -> Content)
-> StateT FbRenderState m [Content] -> FBM m Content
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Block], Alignment) -> FBM m Content)
-> [([Block], Alignment)] -> StateT FbRenderState m [Content]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> ([Block], Alignment) -> FBM m Content
forall (m :: * -> *).
PandocMonad m =>
String -> ([Block], Alignment) -> FBM m Content
mkcell String
tag) ([[Block]] -> [Alignment] -> [([Block], Alignment)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Block]]
cells [Alignment]
aligns')
mkcell :: PandocMonad m => String -> (TableCell, Alignment) -> FBM m Content
mkcell :: String -> ([Block], Alignment) -> FBM m Content
mkcell tag :: String
tag (cell :: [Block]
cell, align :: Alignment
align) = do
[Content]
cblocks <- (Block -> StateT FbRenderState m [Content])
-> [Block] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> StateT FbRenderState m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml [Block]
cell
Content -> FBM m Content
forall (m :: * -> *) a. Monad m => a -> m a
return (Content -> FBM m Content) -> Content -> FBM m Content
forall a b. (a -> b) -> a -> b
$ String -> ([Attr], [Content]) -> Content
forall t. Node t => String -> t -> Content
el String
tag ([Alignment -> Attr
align_attr Alignment
align], [Content]
cblocks)
align_attr :: Alignment -> Attr
align_attr a :: Alignment
a = QName -> String -> Attr
Attr (String -> Maybe String -> Maybe String -> QName
QName "align" Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing) (Alignment -> String
forall p. IsString p => Alignment -> p
align_str Alignment
a)
align_str :: Alignment -> p
align_str AlignLeft = "left"
align_str AlignCenter = "center"
align_str AlignRight = "right"
align_str AlignDefault = "left"
blockToXml Null = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
plainToPara :: [Block] -> [Block]
plainToPara :: [Block] -> [Block]
plainToPara [] = []
plainToPara (Plain inlines :: [Inline]
inlines : rest :: [Block]
rest) =
[Inline] -> Block
Para [Inline]
inlines Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block] -> [Block]
plainToPara [Block]
rest
plainToPara (Para inlines :: [Inline]
inlines : rest :: [Block]
rest) =
[Inline] -> Block
Para [Inline]
inlines Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: Block
HorizontalRule Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block] -> [Block]
plainToPara [Block]
rest
plainToPara (p :: Block
p:rest :: [Block]
rest) = Block
p Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block] -> [Block]
plainToPara [Block]
rest
unPlain :: Block -> Block
unPlain :: Block -> Block
unPlain (Plain inlines :: [Inline]
inlines) = [Inline] -> Block
Para [Inline]
inlines
unPlain x :: Block
x = Block
x
indentPrefix :: Text -> Block -> Block
indentPrefix :: Text -> Block -> Block
indentPrefix spacer :: Text
spacer = Block -> Block
indentBlock
where
indentBlock :: Block -> Block
indentBlock (Plain ins :: [Inline]
ins) = [Inline] -> Block
Plain (Text -> Inline
Str Text
spacerInline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:[Inline]
ins)
indentBlock (Para ins :: [Inline]
ins) = [Inline] -> Block
Para (Text -> Inline
Str Text
spacerInline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:[Inline]
ins)
indentBlock (CodeBlock a :: Attr
a s :: Text
s) =
let s' :: Text
s' = [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
spacerText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
s
in Attr -> Text -> Block
CodeBlock Attr
a Text
s'
indentBlock (BlockQuote bs :: [Block]
bs) = [Block] -> Block
BlockQuote ((Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Block
indent [Block]
bs)
indentBlock (Header l :: Int
l attr' :: Attr
attr' ins :: [Inline]
ins) = Int -> Attr -> [Inline] -> Block
Header Int
l Attr
attr' ([Inline] -> [Inline]
indentLines [Inline]
ins)
indentBlock everythingElse :: Block
everythingElse = Block
everythingElse
indentLines :: [Inline] -> [Inline]
indentLines :: [Inline] -> [Inline]
indentLines ins :: [Inline]
ins = let lns :: [[Inline]]
lns = (Inline -> Bool) -> [Inline] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [[a]]
split Inline -> Bool
isLineBreak [Inline]
ins :: [[Inline]]
in [Inline] -> [[Inline]] -> [Inline]
forall a. [a] -> [[a]] -> [a]
intercalate [Inline
LineBreak] ([[Inline]] -> [Inline]) -> [[Inline]] -> [Inline]
forall a b. (a -> b) -> a -> b
$ ([Inline] -> [Inline]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Inline
Str Text
spacerInline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:) [[Inline]]
lns
indent :: Block -> Block
indent :: Block -> Block
indent = Text -> Block -> Block
indentPrefix Text
spacer
where
spacer :: Text
spacer :: Text
spacer = Int -> Text -> Text
T.replicate 4 " "
indentBlocks :: Text -> [Block] -> [Block]
indentBlocks :: Text -> [Block] -> [Block]
indentBlocks _ [] = []
indentBlocks prefix :: Text
prefix (x :: Block
x:xs :: [Block]
xs) = Text -> Block -> Block
indentPrefix Text
prefix Block
x Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Block -> Block
indentPrefix (Text -> Block -> Block) -> Text -> Block -> Block
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
prefix) " ") [Block]
xs
toXml :: PandocMonad m => Inline -> FBM m [Content]
toXml :: Inline -> FBM m [Content]
toXml (Str s :: Text
s) = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Content
txt Text
s]
toXml (Span _ ils :: [Inline]
ils) = (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ils
toXml (Emph ss :: [Inline]
ss) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> StateT FbRenderState m Content -> FBM m [Content]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> [Inline] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [Inline] -> FBM m Content
wrap "emphasis" [Inline]
ss
toXml (Strong ss :: [Inline]
ss) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> StateT FbRenderState m Content -> FBM m [Content]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> [Inline] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [Inline] -> FBM m Content
wrap "strong" [Inline]
ss
toXml (Strikeout ss :: [Inline]
ss) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> StateT FbRenderState m Content -> FBM m [Content]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> [Inline] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [Inline] -> FBM m Content
wrap "strikethrough" [Inline]
ss
toXml (Superscript ss :: [Inline]
ss) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> StateT FbRenderState m Content -> FBM m [Content]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> [Inline] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [Inline] -> FBM m Content
wrap "sup" [Inline]
ss
toXml (Subscript ss :: [Inline]
ss) = Content -> [Content]
forall a. a -> [a]
list (Content -> [Content])
-> StateT FbRenderState m Content -> FBM m [Content]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> [Inline] -> StateT FbRenderState m Content
forall (m :: * -> *).
PandocMonad m =>
String -> [Inline] -> FBM m Content
wrap "sub" [Inline]
ss
toXml (SmallCaps ss :: [Inline]
ss) = (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml ([Inline] -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ [Inline] -> [Inline]
forall a. Walkable Inline a => a -> a
capitalize [Inline]
ss
toXml (Quoted SingleQuote ss :: [Inline]
ss) = do
[Content]
inner <- (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ss
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content]) -> [Content] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ [Text -> Content
txt "‘"] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
inner [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Text -> Content
txt "’"]
toXml (Quoted DoubleQuote ss :: [Inline]
ss) = do
[Content]
inner <- (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ss
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content]) -> [Content] -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ [Text -> Content
txt "“"] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
inner [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Text -> Content
txt "”"]
toXml (Cite _ ss :: [Inline]
ss) = (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
ss
toXml (Code _ s :: Text
s) = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> String -> Content
forall t. Node t => String -> t -> Content
el "code" (String -> Content) -> String -> Content
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s]
toXml Space = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Content
txt " "]
toXml SoftBreak = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Content
txt "\n"]
toXml LineBreak = [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Content
txt "\n"]
toXml (Math _ formula :: Text
formula) = ImageMode -> Text -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
ImageMode -> Text -> FBM m [Content]
insertMath ImageMode
InlineImage Text
formula
toXml il :: Inline
il@(RawInline _ _) = do
LogMessage -> StateT FbRenderState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FbRenderState m ())
-> LogMessage -> StateT FbRenderState m ()
forall a b. (a -> b) -> a -> b
$ Inline -> LogMessage
InlineNotRendered Inline
il
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
toXml (Link _ text :: [Inline]
text (url :: Text
url,_)) = do
[Content]
ln_text <- (Inline -> FBM m [Content]) -> [Inline] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
text
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> ([Attr], [Content]) -> Content
forall t. Node t => String -> t -> Content
el "a" ( [ (String, String) -> Text -> Attr
attr ("l","href") Text
url ], [Content]
ln_text) ]
toXml img :: Inline
img@Image{} = ImageMode -> Inline -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
ImageMode -> Inline -> FBM m [Content]
insertImage ImageMode
InlineImage Inline
img
toXml (Note bs :: [Block]
bs) = do
[(Int, Text, [Content])]
fns <- FbRenderState -> [(Int, Text, [Content])]
footnotes (FbRenderState -> [(Int, Text, [Content])])
-> StateT FbRenderState m FbRenderState
-> StateT FbRenderState m [(Int, Text, [Content])]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` StateT FbRenderState m FbRenderState
forall s (m :: * -> *). MonadState s m => m s
get
let n :: Int
n = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Int, Text, [Content])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Text, [Content])]
fns
let fn_id :: Text
fn_id = Int -> Text
footnoteID Int
n
[Content]
fn_desc <- (Block -> FBM m [Content]) -> [Block] -> FBM m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Block -> FBM m [Content]
forall (m :: * -> *). PandocMonad m => Block -> FBM m [Content]
blockToXml [Block]
bs
(FbRenderState -> FbRenderState) -> StateT FbRenderState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: FbRenderState
s -> FbRenderState
s { footnotes :: [(Int, Text, [Content])]
footnotes = (Int
n, Text
fn_id, [Content]
fn_desc) (Int, Text, [Content])
-> [(Int, Text, [Content])] -> [(Int, Text, [Content])]
forall a. a -> [a] -> [a]
: [(Int, Text, [Content])]
fns })
let fn_ref :: Content
fn_ref = Text -> Content
txt (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ "[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content])
-> (Content -> [Content]) -> Content -> FBM m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> [Content]
forall a. a -> [a]
list (Content -> FBM m [Content]) -> Content -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$ String -> ([Attr], Content) -> Content
forall t. Node t => String -> t -> Content
el "a" ( [ (String, String) -> Text -> Attr
attr ("l","href") ("#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fn_id)
, String -> Text -> Attr
uattr "type" "note" ]
, Content
fn_ref )
insertMath :: PandocMonad m => ImageMode -> Text -> FBM m [Content]
insertMath :: ImageMode -> Text -> FBM m [Content]
insertMath immode :: ImageMode
immode formula :: Text
formula = do
HTMLMathMethod
htmlMath <- (FbRenderState -> HTMLMathMethod)
-> StateT FbRenderState m FbRenderState
-> StateT FbRenderState m HTMLMathMethod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WriterOptions -> HTMLMathMethod
writerHTMLMathMethod (WriterOptions -> HTMLMathMethod)
-> (FbRenderState -> WriterOptions)
-> FbRenderState
-> HTMLMathMethod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FbRenderState -> WriterOptions
writerOptions) StateT FbRenderState m FbRenderState
forall s (m :: * -> *). MonadState s m => m s
get
case HTMLMathMethod
htmlMath of
WebTeX url :: Text
url -> do
let alt :: [Inline]
alt = [Attr -> Text -> Inline
Code Attr
nullAttr Text
formula]
let imgurl :: Text
imgurl = Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ShowS
urlEncode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
formula)
let img :: Inline
img = Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
nullAttr [Inline]
alt (Text
imgurl, "")
ImageMode -> Inline -> FBM m [Content]
forall (m :: * -> *).
PandocMonad m =>
ImageMode -> Inline -> FBM m [Content]
insertImage ImageMode
immode Inline
img
_ -> [Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> String -> Content
forall t. Node t => String -> t -> Content
el "code" (String -> Content) -> String -> Content
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
formula]
insertImage :: PandocMonad m => ImageMode -> Inline -> FBM m [Content]
insertImage :: ImageMode -> Inline -> FBM m [Content]
insertImage immode :: ImageMode
immode (Image _ alt :: [Inline]
alt (url :: Text
url,ttl :: Text
ttl)) = do
[(Text, Text)]
images <- FbRenderState -> [(Text, Text)]
imagesToFetch (FbRenderState -> [(Text, Text)])
-> StateT FbRenderState m FbRenderState
-> StateT FbRenderState m [(Text, Text)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` StateT FbRenderState m FbRenderState
forall s (m :: * -> *). MonadState s m => m s
get
let n :: Int
n = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Text, Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
images
let fname :: Text
fname = "image" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n
(FbRenderState -> FbRenderState) -> StateT FbRenderState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: FbRenderState
s -> FbRenderState
s { imagesToFetch :: [(Text, Text)]
imagesToFetch = (Text
fname, Text
url) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
images })
let ttlattr :: [Attr]
ttlattr = case (ImageMode
immode, Text -> Bool
T.null Text
ttl) of
(NormalImage, False) -> [ String -> Text -> Attr
uattr "title" Text
ttl ]
_ -> []
[Content] -> FBM m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> FBM m [Content])
-> (Content -> [Content]) -> Content -> FBM m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> [Content]
forall a. a -> [a]
list (Content -> FBM m [Content]) -> Content -> FBM m [Content]
forall a b. (a -> b) -> a -> b
$
String -> [Attr] -> Content
forall t. Node t => String -> t -> Content
el "image" ([Attr] -> Content) -> [Attr] -> Content
forall a b. (a -> b) -> a -> b
$
[ (String, String) -> Text -> Attr
attr ("l","href") ("#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname)
, (String, String) -> Text -> Attr
attr ("l","type") (ImageMode -> Text
forall a. Show a => a -> Text
tshow ImageMode
immode)
, String -> Text -> Attr
uattr "alt" (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
alt) ]
[Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ [Attr]
ttlattr
insertImage _ _ = String -> FBM m [Content]
forall a. HasCallStack => String -> a
error "unexpected inline instead of image"
replaceImagesWithAlt :: [Text] -> Content -> Content
replaceImagesWithAlt :: [Text] -> Content -> Content
replaceImagesWithAlt missingHrefs :: [Text]
missingHrefs body :: Content
body =
let cur :: Cursor
cur = Content -> Cursor
XC.fromContent Content
body
cur' :: Cursor
cur' = Cursor -> Cursor
replaceAll Cursor
cur
in Cursor -> Content
XC.toTree (Cursor -> Content) -> (Cursor -> Cursor) -> Cursor -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Cursor
XC.root (Cursor -> Content) -> Cursor -> Content
forall a b. (a -> b) -> a -> b
$ Cursor
cur'
where
replaceAll :: XC.Cursor -> XC.Cursor
replaceAll :: Cursor -> Cursor
replaceAll c :: Cursor
c =
let n :: Content
n = Cursor -> Content
XC.current Cursor
c
c' :: Cursor
c' = if Content -> Bool
isImage Content
n Bool -> Bool -> Bool
&& Content -> Bool
isMissing Content
n
then (Content -> Content) -> Cursor -> Cursor
XC.modifyContent Content -> Content
replaceNode Cursor
c
else Cursor
c
in case Cursor -> Maybe Cursor
XC.nextDF Cursor
c' of
(Just cnext :: Cursor
cnext) -> Cursor -> Cursor
replaceAll Cursor
cnext
Nothing -> Cursor
c'
isImage :: Content -> Bool
isImage :: Content -> Bool
isImage (Elem e :: Element
e) = Element -> QName
elName Element
e QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> QName
uname "image"
isImage _ = Bool
False
isMissing :: Content -> Bool
isMissing (Elem img :: Element
img@Element{}) =
let imgAttrs :: [Attr]
imgAttrs = Element -> [Attr]
elAttribs Element
img
badAttrs :: [Attr]
badAttrs = (Text -> Attr) -> [Text] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map ((String, String) -> Text -> Attr
attr ("l","href")) [Text]
missingHrefs
in (Attr -> Bool) -> [Attr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attr -> [Attr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attr]
imgAttrs) [Attr]
badAttrs
isMissing _ = Bool
False
replaceNode :: Content -> Content
replaceNode :: Content -> Content
replaceNode n :: Content
n@(Elem img :: Element
img@Element{}) =
let attrs :: [Attr]
attrs = Element -> [Attr]
elAttribs Element
img
alt :: Maybe String
alt = [Attr] -> QName -> Maybe String
getAttrVal [Attr]
attrs (String -> QName
uname "alt")
imtype :: Maybe String
imtype = [Attr] -> QName -> Maybe String
getAttrVal [Attr]
attrs (String -> String -> QName
qname "l" "type")
in case (Maybe String
alt, Maybe String
imtype) of
(Just alt' :: String
alt', Just imtype' :: String
imtype') ->
if String
imtype' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ImageMode -> String
forall a. Show a => a -> String
show ImageMode
NormalImage
then String -> String -> Content
forall t. Node t => String -> t -> Content
el "p" String
alt'
else Text -> Content
txt (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
alt'
(Just alt' :: String
alt', Nothing) -> Text -> Content
txt (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
alt'
_ -> Content
n
replaceNode n :: Content
n = Content
n
getAttrVal :: [X.Attr] -> QName -> Maybe String
getAttrVal :: [Attr] -> QName -> Maybe String
getAttrVal attrs :: [Attr]
attrs name :: QName
name =
case (Attr -> Bool) -> [Attr] -> [Attr]
forall a. (a -> Bool) -> [a] -> [a]
filter ((QName
name QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==) (QName -> Bool) -> (Attr -> QName) -> Attr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> QName
attrKey) [Attr]
attrs of
(a :: Attr
a:_) -> String -> Maybe String
forall a. a -> Maybe a
Just (Attr -> String
attrVal Attr
a)
_ -> Maybe String
forall a. Maybe a
Nothing
wrap :: PandocMonad m => String -> [Inline] -> FBM m Content
wrap :: String -> [Inline] -> FBM m Content
wrap tagname :: String
tagname inlines :: [Inline]
inlines = String -> [Content] -> Content
forall t. Node t => String -> t -> Content
el String
tagname ([Content] -> Content)
-> StateT FbRenderState m [Content] -> FBM m Content
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Inline -> StateT FbRenderState m [Content])
-> [Inline] -> StateT FbRenderState m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
cMapM Inline -> StateT FbRenderState m [Content]
forall (m :: * -> *). PandocMonad m => Inline -> FBM m [Content]
toXml [Inline]
inlines
list :: a -> [a]
list :: a -> [a]
list = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])
plain :: Inline -> String
plain :: Inline -> String
plain (Str s :: Text
s) = Text -> String
T.unpack Text
s
plain (Emph ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Span _ ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Strong ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Strikeout ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Superscript ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Subscript ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (SmallCaps ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Quoted _ ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Cite _ ss :: [Inline]
ss) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
ss
plain (Code _ s :: Text
s) = Text -> String
T.unpack Text
s
plain Space = " "
plain SoftBreak = " "
plain LineBreak = "\n"
plain (Math _ s :: Text
s) = Text -> String
T.unpack Text
s
plain (RawInline _ _) = ""
plain (Link _ text :: [Inline]
text (url :: Text
url,_)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Inline -> String) -> [Inline] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> String
plain [Inline]
text [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [" <", Text -> String
T.unpack Text
url, ">"])
plain (Image _ alt :: [Inline]
alt _) = (Inline -> String) -> [Inline] -> String
forall a b. (a -> [b]) -> [a] -> [b]
cMap Inline -> String
plain [Inline]
alt
plain (Note _) = ""
el :: (Node t)
=> String
-> t
-> Content
el :: String -> t -> Content
el name :: String
name cs :: t
cs = Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ String -> t -> Element
forall t. Node t => String -> t -> Element
unode String
name t
cs
spaceBeforeAfter :: [Content] -> [Content]
spaceBeforeAfter :: [Content] -> [Content]
spaceBeforeAfter cs :: [Content]
cs =
let emptyline :: Content
emptyline = String -> () -> Content
forall t. Node t => String -> t -> Content
el "empty-line" ()
in [Content
emptyline] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
cs [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content
emptyline]
txt :: Text -> Content
txt :: Text -> Content
txt s :: Text
s = CData -> Content
Text (CData -> Content) -> CData -> Content
forall a b. (a -> b) -> a -> b
$ CDataKind -> String -> Maybe Line -> CData
CData CDataKind
CDataText (Text -> String
T.unpack Text
s) Maybe Line
forall a. Maybe a
Nothing
uattr :: String -> Text -> Text.XML.Light.Attr
uattr :: String -> Text -> Attr
uattr name :: String
name = QName -> String -> Attr
Attr (String -> QName
uname String
name) (String -> Attr) -> (Text -> String) -> Text -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
attr :: (String, String) -> Text -> Text.XML.Light.Attr
attr :: (String, String) -> Text -> Attr
attr (ns :: String
ns, name :: String
name) = QName -> String -> Attr
Attr (String -> String -> QName
qname String
ns String
name) (String -> Attr) -> (Text -> String) -> Text -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
uname :: String -> QName
uname :: String -> QName
uname name :: String
name = String -> Maybe String -> Maybe String -> QName
QName String
name Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
qname :: String -> String -> QName
qname :: String -> String -> QName
qname ns :: String
ns name :: String
name = String -> Maybe String -> Maybe String -> QName
QName String
name Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
ns)
cMap :: (a -> [b]) -> [a] -> [b]
cMap :: (a -> [b]) -> [a] -> [b]
cMap = (a -> [b]) -> [a] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
cMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
cMapM :: (a -> m [b]) -> [a] -> m [b]
cMapM f :: a -> m [b]
f xs :: [a]
xs = [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f [a]
xs