{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.FB2
   Copyright   : Copyright (C) 2018-2020 Alexander Krotov
   License     : GNU GPL, version 2 or above

   Maintainer  : Alexander Krotov <ilabdsf@gmail.com>
   Stability   : alpha
   Portability : portable

Conversion of FB2 to 'Pandoc' document.
-}

{-

TODO:
 - Tables
 - Named styles
 - Parse ID attribute for all elements that have it

-}

module Text.Pandoc.Readers.FB2 ( readFB2 ) where
import Control.Monad.Except (throwError)
import Control.Monad.State.Strict
import Data.ByteString.Lazy.Char8 ( pack )
import Data.ByteString.Base64.Lazy
import Data.Functor
import Data.List (intersperse)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Default
import Data.Maybe
import Text.HTML.TagSoup.Entity (lookupEntity)
import Text.Pandoc.Builder
import Text.Pandoc.Class.PandocMonad (PandocMonad, insertMedia, report)
import Text.Pandoc.Error
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Shared (crFilter)
import Text.XML.Light

type FB2 m = StateT FB2State m

data FB2State = FB2State{ FB2State -> Int
fb2SectionLevel :: Int
                        , FB2State -> Meta
fb2Meta :: Meta
                        , FB2State -> [Text]
fb2Authors :: [Text]
                        , FB2State -> Map Text Blocks
fb2Notes :: M.Map Text Blocks
                        } deriving Int -> FB2State -> ShowS
[FB2State] -> ShowS
FB2State -> String
(Int -> FB2State -> ShowS)
-> (FB2State -> String) -> ([FB2State] -> ShowS) -> Show FB2State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FB2State] -> ShowS
$cshowList :: [FB2State] -> ShowS
show :: FB2State -> String
$cshow :: FB2State -> String
showsPrec :: Int -> FB2State -> ShowS
$cshowsPrec :: Int -> FB2State -> ShowS
Show

instance Default FB2State where
  def :: FB2State
def = FB2State :: Int -> Meta -> [Text] -> Map Text Blocks -> FB2State
FB2State{ fb2SectionLevel :: Int
fb2SectionLevel = 1
                , fb2Meta :: Meta
fb2Meta = Meta
forall a. Monoid a => a
mempty
                , fb2Authors :: [Text]
fb2Authors = []
                , fb2Notes :: Map Text Blocks
fb2Notes = Map Text Blocks
forall k a. Map k a
M.empty
                }

instance HasMeta FB2State where
  setMeta :: Text -> b -> FB2State -> FB2State
setMeta field :: Text
field v :: b
v s :: FB2State
s = FB2State
s {fb2Meta :: Meta
fb2Meta = Text -> b -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta Text
field b
v (FB2State -> Meta
fb2Meta FB2State
s)}
  deleteMeta :: Text -> FB2State -> FB2State
deleteMeta field :: Text
field s :: FB2State
s = FB2State
s {fb2Meta :: Meta
fb2Meta = Text -> Meta -> Meta
forall a. HasMeta a => Text -> a -> a
deleteMeta Text
field (FB2State -> Meta
fb2Meta FB2State
s)}

readFB2 :: PandocMonad m => ReaderOptions -> Text -> m Pandoc
readFB2 :: ReaderOptions -> Text -> m Pandoc
readFB2 _ inp :: Text
inp =
  case Text -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc (Text -> Maybe Element) -> Text -> Maybe Element
forall a b. (a -> b) -> a -> b
$ Text -> Text
crFilter Text
inp of
    Nothing -> PandocError -> m Pandoc
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Pandoc) -> PandocError -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError "Not an XML document"
    Just e :: Element
e ->  do
      (bs :: Blocks
bs, st :: FB2State
st) <- StateT FB2State m Blocks -> FB2State -> m (Blocks, FB2State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Element -> StateT FB2State m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseRootElement Element
e) FB2State
forall a. Default a => a
def
      let authors :: Meta -> Meta
authors = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ FB2State -> [Text]
fb2Authors FB2State
st
                    then Meta -> Meta
forall a. a -> a
id
                    else Text -> [Inlines] -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta "author" ((Text -> Inlines) -> [Text] -> [Inlines]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Inlines
text ([Text] -> [Inlines]) -> [Text] -> [Inlines]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ FB2State -> [Text]
fb2Authors FB2State
st)
      Pandoc -> m Pandoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pandoc -> m Pandoc) -> Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Meta -> [Block] -> Pandoc
Pandoc (Meta -> Meta
authors (Meta -> Meta) -> Meta -> Meta
forall a b. (a -> b) -> a -> b
$ FB2State -> Meta
fb2Meta FB2State
st) ([Block] -> Pandoc) -> [Block] -> Pandoc
forall a b. (a -> b) -> a -> b
$ Blocks -> [Block]
forall a. Many a -> [a]
toList Blocks
bs

-- * Utility functions

trim :: Text -> Text
trim :: Text -> Text
trim = Text -> Text
T.strip

removeHash :: Text -> Text
removeHash :: Text -> Text
removeHash t :: Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
  Just ('#', xs :: Text
xs) -> Text
xs
  _              -> Text
t

convertEntity :: String -> Text
convertEntity :: String -> Text
convertEntity e :: String
e = Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Text
T.toUpper (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
e) String -> Text
T.pack (Maybe String -> Text) -> Maybe String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
lookupEntity String
e

parseInline :: PandocMonad m => Content -> FB2 m Inlines
parseInline :: Content -> FB2 m Inlines
parseInline (Elem e :: Element
e) =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "strong" -> Inlines -> Inlines
strong (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "emphasis" -> Inlines -> Inlines
emph (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "style" -> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseNamedStyle Element
e
    "a" -> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseLinkType Element
e
    "strikethrough" -> Inlines -> Inlines
strikeout (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "sub" -> Inlines -> Inlines
subscript (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "sup" -> Inlines -> Inlines
superscript (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "code" -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
code (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "image" -> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseInlineImageElement Element
e
    name :: Text
name -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement Text
name
      Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inlines
forall a. Monoid a => a
mempty
parseInline (Text x :: CData
x) = Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CData -> String
cdData CData
x
parseInline (CRef r :: String
r) = Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
str (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
convertEntity String
r

parseSubtitle :: PandocMonad m => Element -> FB2 m Blocks
parseSubtitle :: Element -> FB2 m Blocks
parseSubtitle e :: Element
e = Attr -> Int -> Inlines -> Blocks
headerWith ("", ["unnumbered"], []) (Int -> Inlines -> Blocks)
-> StateT FB2State m Int -> StateT FB2State m (Inlines -> Blocks)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FB2State -> Int) -> StateT FB2State m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FB2State -> Int
fb2SectionLevel StateT FB2State m (Inlines -> Blocks)
-> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e

-- * Root element parser

parseRootElement :: PandocMonad m => Element -> FB2 m Blocks
parseRootElement :: Element -> FB2 m Blocks
parseRootElement e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "FictionBook" -> do
      -- Parse notes before parsing the rest of the content.
      case (Element -> Bool) -> Element -> Maybe Element
filterChild Element -> Bool
isNotesBody Element
e of
        Nothing -> () -> StateT FB2State m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just notesBody :: Element
notesBody -> Element -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseNotesBody Element
notesBody
      -- Parse metadata and content
      [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseFictionBookChild (Element -> [Element]
elChildren Element
e)
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "root") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse notes
parseNotesBody :: PandocMonad m => Element -> FB2 m ()
parseNotesBody :: Element -> FB2 m ()
parseNotesBody e :: Element
e = ()
forall a. Monoid a => a
mempty () -> StateT FB2State m [()] -> FB2 m ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Element -> FB2 m ()) -> [Element] -> StateT FB2State m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseNotesBodyChild (Element -> [Element]
elChildren Element
e)

-- | Parse a child of @\<body name="notes">@ element.
parseNotesBodyChild :: PandocMonad m => Element -> FB2 m ()
parseNotesBodyChild :: Element -> FB2 m ()
parseNotesBodyChild e :: Element
e =
  case QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "section" -> Element -> FB2 m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseNote Element
e
    _ -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

isNotesBody :: Element -> Bool
isNotesBody :: Element -> Bool
isNotesBody e :: Element
e =
  QName -> String
qName (Element -> QName
elName Element
e) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "body" Bool -> Bool -> Bool
&&
  QName -> Element -> Maybe String
findAttr (String -> QName
unqual "name") Element
e Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "notes"

parseNote :: PandocMonad m => Element -> FB2 m ()
parseNote :: Element -> FB2 m ()
parseNote e :: Element
e =
  case QName -> Element -> Maybe String
findAttr (String -> QName
unqual "id") Element
e of
    Nothing -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just sectionId :: String
sectionId -> do
      Blocks
content <- [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks)
-> StateT FB2State m [Blocks] -> StateT FB2State m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> StateT FB2State m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> StateT FB2State m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSectionChild ([Element] -> [Element]
dropTitle ([Element] -> [Element]) -> [Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
e)
      Map Text Blocks
oldNotes <- (FB2State -> Map Text Blocks)
-> StateT FB2State m (Map Text Blocks)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FB2State -> Map Text Blocks
fb2Notes
      (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FB2State -> FB2State) -> FB2 m ())
-> (FB2State -> FB2State) -> FB2 m ()
forall a b. (a -> b) -> a -> b
$ \s :: FB2State
s -> FB2State
s { fb2Notes :: Map Text Blocks
fb2Notes = Text -> Blocks -> Map Text Blocks -> Map Text Blocks
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ("#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
sectionId) Blocks
content Map Text Blocks
oldNotes }
      () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    isTitle :: Element -> Bool
isTitle x :: Element
x = QName -> String
qName (Element -> QName
elName Element
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "title"
    dropTitle :: [Element] -> [Element]
dropTitle (x :: Element
x:xs :: [Element]
xs) = if Element -> Bool
isTitle Element
x
                         then [Element]
xs -- Drop note section <title> if present
                         else Element
xElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[Element]
xs
    dropTitle [] = []

-- | Parse a child of @\<FictionBook>@ element.
parseFictionBookChild :: PandocMonad m => Element -> FB2 m Blocks
parseFictionBookChild :: Element -> FB2 m Blocks
parseFictionBookChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "stylesheet" -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
forall a. Monoid a => a
mempty -- stylesheet is ignored
    "description" -> Blocks
forall a. Monoid a => a
mempty Blocks -> StateT FB2State m () -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Element -> StateT FB2State m ())
-> [Element] -> StateT FB2State m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Element -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseDescriptionChild (Element -> [Element]
elChildren Element
e)
    "body" -> if Element -> Bool
isNotesBody Element
e
                then Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
forall a. Monoid a => a
mempty
                else [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseBodyChild (Element -> [Element]
elChildren Element
e)
    "binary" -> Blocks
forall a. Monoid a => a
mempty Blocks -> StateT FB2State m () -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Element -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseBinaryElement Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "FictionBook") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse a child of @\<description>@ element.
parseDescriptionChild :: PandocMonad m => Element -> FB2 m ()
parseDescriptionChild :: Element -> FB2 m ()
parseDescriptionChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "title-info" -> (Element -> FB2 m ()) -> [Element] -> FB2 m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Element -> FB2 m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseTitleInfoChild (Element -> [Element]
elChildren Element
e)
    "src-title-info" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- ignore
    "document-info" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "publish-info" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "custom-info" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "output" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    name :: Text
name -> do
      LogMessage -> FB2 m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> FB2 m ()) -> LogMessage -> FB2 m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " in description"
      () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall a. Monoid a => a
mempty

-- | Parse a child of @\<body>@ element.
parseBodyChild :: PandocMonad m => Element -> FB2 m Blocks
parseBodyChild :: Element -> FB2 m Blocks
parseBodyChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "image" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseImageElement Element
e
    "title" -> Int -> Inlines -> Blocks
header (Int -> Inlines -> Blocks)
-> StateT FB2State m Int -> StateT FB2State m (Inlines -> Blocks)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FB2State -> Int) -> StateT FB2State m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FB2State -> Int
fb2SectionLevel StateT FB2State m (Inlines -> Blocks)
-> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Content] -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => [Content] -> FB2 m Inlines
parseTitleType (Element -> [Content]
elContent Element
e)
    "epigraph" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseEpigraph Element
e
    "section" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSection Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "body") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse a @\<binary>@ element.
parseBinaryElement :: PandocMonad m => Element -> FB2 m ()
parseBinaryElement :: Element -> FB2 m ()
parseBinaryElement e :: Element
e =
  case (QName -> Element -> Maybe String
findAttr (String -> QName
unqual "id") Element
e, QName -> Element -> Maybe String
findAttr (String -> QName
unqual "content-type") Element
e) of
    (Nothing, _) -> LogMessage -> FB2 m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> FB2 m ()) -> LogMessage -> FB2 m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement "binary without id attribute"
    (Just _, Nothing) ->
      LogMessage -> FB2 m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> FB2 m ()) -> LogMessage -> FB2 m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement "binary without content-type attribute"
    (Just filename :: String
filename, contentType :: Maybe String
contentType) -> String -> Maybe Text -> ByteString -> FB2 m ()
forall (m :: * -> *).
PandocMonad m =>
String -> Maybe Text -> ByteString -> m ()
insertMedia String
filename (String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
contentType) (ByteString -> ByteString
decodeLenient (String -> ByteString
pack (Element -> String
strContent Element
e)))

-- * Type parsers

-- | Parse @authorType@
parseAuthor :: PandocMonad m => Element -> FB2 m Text
parseAuthor :: Element -> FB2 m Text
parseAuthor e :: Element
e = [Text] -> Text
T.unwords ([Text] -> Text)
-> ([Maybe Text] -> [Text]) -> [Maybe Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> Text)
-> StateT FB2State m [Maybe Text] -> FB2 m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> StateT FB2State m (Maybe Text))
-> [Element] -> StateT FB2State m [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> StateT FB2State m (Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Element -> FB2 m (Maybe Text)
parseAuthorChild (Element -> [Element]
elChildren Element
e)

parseAuthorChild :: PandocMonad m => Element -> FB2 m (Maybe Text)
parseAuthorChild :: Element -> FB2 m (Maybe Text)
parseAuthorChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "first-name" -> Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> FB2 m (Maybe Text))
-> Maybe Text -> FB2 m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "middle-name" -> Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> FB2 m (Maybe Text))
-> Maybe Text -> FB2 m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "last-name" -> Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> FB2 m (Maybe Text))
-> Maybe Text -> FB2 m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "nickname" -> Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> FB2 m (Maybe Text))
-> Maybe Text -> FB2 m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "home-page" -> Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> FB2 m (Maybe Text))
-> Maybe Text -> FB2 m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "email" -> Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> FB2 m (Maybe Text))
-> Maybe Text -> FB2 m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    name :: Text
name -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " in author"
      Maybe Text -> FB2 m (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing

-- | Parse @titleType@
parseTitle :: PandocMonad m => Element -> FB2 m Blocks
parseTitle :: Element -> FB2 m Blocks
parseTitle e :: Element
e = Int -> Inlines -> Blocks
header (Int -> Inlines -> Blocks)
-> StateT FB2State m Int -> StateT FB2State m (Inlines -> Blocks)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FB2State -> Int) -> StateT FB2State m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FB2State -> Int
fb2SectionLevel StateT FB2State m (Inlines -> Blocks)
-> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Content] -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => [Content] -> FB2 m Inlines
parseTitleType (Element -> [Content]
elContent Element
e)

parseTitleType :: PandocMonad m => [Content] -> FB2 m Inlines
parseTitleType :: [Content] -> FB2 m Inlines
parseTitleType c :: [Content]
c = [Inlines] -> Inlines
forall a. Monoid a => [a] -> a
mconcat ([Inlines] -> Inlines)
-> ([Maybe Inlines] -> [Inlines]) -> [Maybe Inlines] -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> [Inlines] -> [Inlines]
forall a. a -> [a] -> [a]
intersperse Inlines
linebreak ([Inlines] -> [Inlines])
-> ([Maybe Inlines] -> [Inlines]) -> [Maybe Inlines] -> [Inlines]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Inlines] -> [Inlines]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Inlines] -> Inlines)
-> StateT FB2State m [Maybe Inlines] -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> StateT FB2State m (Maybe Inlines))
-> [Content] -> StateT FB2State m [Maybe Inlines]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> StateT FB2State m (Maybe Inlines)
forall (m :: * -> *).
PandocMonad m =>
Content -> FB2 m (Maybe Inlines)
parseTitleContent [Content]
c

parseTitleContent :: PandocMonad m => Content -> FB2 m (Maybe Inlines)
parseTitleContent :: Content -> FB2 m (Maybe Inlines)
parseTitleContent (Elem e :: Element
e) =
  case QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "p" -> Inlines -> Maybe Inlines
forall a. a -> Maybe a
Just (Inlines -> Maybe Inlines)
-> StateT FB2State m Inlines -> FB2 m (Maybe Inlines)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    "empty-line" -> Maybe Inlines -> FB2 m (Maybe Inlines)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Inlines -> FB2 m (Maybe Inlines))
-> Maybe Inlines -> FB2 m (Maybe Inlines)
forall a b. (a -> b) -> a -> b
$ Inlines -> Maybe Inlines
forall a. a -> Maybe a
Just Inlines
forall a. Monoid a => a
mempty
    _ -> Maybe Inlines -> FB2 m (Maybe Inlines)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inlines
forall a. Monoid a => a
mempty
parseTitleContent _ = Maybe Inlines -> FB2 m (Maybe Inlines)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inlines
forall a. Maybe a
Nothing

-- | Parse @imageType@
parseImageElement :: PandocMonad m => Element -> FB2 m Blocks
parseImageElement :: Element -> FB2 m Blocks
parseImageElement e :: Element
e =
  case Maybe String
href of
    Just src :: String
src -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Blocks -> FB2 m Blocks) -> Blocks -> FB2 m Blocks
forall a b. (a -> b) -> a -> b
$ Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Text -> Inlines -> Inlines
imageWith (Text
imgId, [], []) (Text -> Text
removeHash (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
src) Text
title Inlines
alt
    Nothing -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement " image without href"
      Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
forall a. Monoid a => a
mempty
  where alt :: Inlines
alt = Inlines -> (String -> Inlines) -> Maybe String -> Inlines
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Inlines
forall a. Monoid a => a
mempty (Text -> Inlines
str (Text -> Inlines) -> (String -> Text) -> String -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Maybe String -> Inlines) -> Maybe String -> Inlines
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr (String -> QName
unqual "alt") Element
e
        title :: Text
title = Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" String -> Text
T.pack (Maybe String -> Text) -> Maybe String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr (String -> QName
unqual "title") Element
e
        imgId :: Text
imgId = Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" String -> Text
T.pack (Maybe String -> Text) -> Maybe String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr (String -> QName
unqual "id") Element
e
        href :: Maybe String
href = QName -> Element -> Maybe String
findAttr (String -> Maybe String -> Maybe String -> QName
QName "href" (String -> Maybe String
forall a. a -> Maybe a
Just "http://www.w3.org/1999/xlink") Maybe String
forall a. Maybe a
Nothing) Element
e

-- | Parse @pType@
parsePType :: PandocMonad m => Element -> FB2 m Inlines
parsePType :: Element -> FB2 m Inlines
parsePType = Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType -- TODO add support for optional "id" and "style" attributes

-- | Parse @citeType@
parseCite :: PandocMonad m => Element -> FB2 m Blocks
parseCite :: Element -> FB2 m Blocks
parseCite e :: Element
e = Blocks -> Blocks
blockQuote (Blocks -> Blocks) -> ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseCiteChild (Element -> [Element]
elChildren Element
e)

-- | Parse @citeType@ child
parseCiteChild :: PandocMonad m => Element -> FB2 m Blocks
parseCiteChild :: Element -> FB2 m Blocks
parseCiteChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "p" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    "poem" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parsePoem Element
e
    "empty-line" -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
horizontalRule
    "subtitle" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSubtitle Element
e
    "table" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseTable Element
e
    "text-author" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "cite") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse @poemType@
parsePoem :: PandocMonad m => Element -> FB2 m Blocks
parsePoem :: Element -> FB2 m Blocks
parsePoem e :: Element
e = [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parsePoemChild (Element -> [Element]
elChildren Element
e)

parsePoemChild :: PandocMonad m => Element -> FB2 m Blocks
parsePoemChild :: Element -> FB2 m Blocks
parsePoemChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "title" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseTitle Element
e
    "subtitle" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSubtitle Element
e
    "epigraph" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseEpigraph Element
e
    "stanza" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseStanza Element
e
    "text-author" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    "date" -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Blocks -> FB2 m Blocks) -> Blocks -> FB2 m Blocks
forall a b. (a -> b) -> a -> b
$ Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "poem") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

parseStanza :: PandocMonad m => Element -> FB2 m Blocks
parseStanza :: Element -> FB2 m Blocks
parseStanza e :: Element
e = [Block] -> Blocks
forall a. [a] -> Many a
fromList ([Block] -> Blocks) -> ([Blocks] -> [Block]) -> [Blocks] -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> [Block]
joinLineBlocks ([Block] -> [Block])
-> ([Blocks] -> [Block]) -> [Blocks] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> [Block]
forall a. Many a -> [a]
toList (Blocks -> [Block]) -> ([Blocks] -> Blocks) -> [Blocks] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseStanzaChild (Element -> [Element]
elChildren Element
e)

joinLineBlocks :: [Block] -> [Block]
joinLineBlocks :: [Block] -> [Block]
joinLineBlocks (LineBlock xs :: [[Inline]]
xs:LineBlock ys :: [[Inline]]
ys:zs :: [Block]
zs) = [Block] -> [Block]
joinLineBlocks ([[Inline]] -> Block
LineBlock ([[Inline]]
xs [[Inline]] -> [[Inline]] -> [[Inline]]
forall a. [a] -> [a] -> [a]
++ [[Inline]]
ys) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
zs)
joinLineBlocks (x :: Block
x:xs :: [Block]
xs) = Block
xBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block] -> [Block]
joinLineBlocks [Block]
xs
joinLineBlocks [] = []

parseStanzaChild :: PandocMonad m => Element -> FB2 m Blocks
parseStanzaChild :: Element -> FB2 m Blocks
parseStanzaChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "title" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseTitle Element
e
    "subtitle" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSubtitle Element
e
    "v" -> [Inlines] -> Blocks
lineBlock ([Inlines] -> Blocks)
-> (Inlines -> [Inlines]) -> Inlines -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inlines -> [Inlines] -> [Inlines]
forall a. a -> [a] -> [a]
:[]) (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "stanza") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse @epigraphType@
parseEpigraph :: PandocMonad m => Element -> FB2 m Blocks
parseEpigraph :: Element -> FB2 m Blocks
parseEpigraph e :: Element
e =
  Attr -> Blocks -> Blocks
divWith (Text
divId, ["epigraph"], []) (Blocks -> Blocks) -> ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseEpigraphChild (Element -> [Element]
elChildren Element
e)
  where divId :: Text
divId = Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" String -> Text
T.pack (Maybe String -> Text) -> Maybe String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr (String -> QName
unqual "id") Element
e

parseEpigraphChild :: PandocMonad m => Element -> FB2 m Blocks
parseEpigraphChild :: Element -> FB2 m Blocks
parseEpigraphChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "p" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    "poem" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parsePoem Element
e
    "cite" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseCite Element
e
    "empty-line" -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
horizontalRule
    "text-author" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "epigraph") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse @annotationType@
parseAnnotation :: PandocMonad m => Element -> FB2 m Blocks
parseAnnotation :: Element -> FB2 m Blocks
parseAnnotation e :: Element
e = [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseAnnotationChild (Element -> [Element]
elChildren Element
e)

parseAnnotationChild :: PandocMonad m => Element -> FB2 m Blocks
parseAnnotationChild :: Element -> FB2 m Blocks
parseAnnotationChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "p" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    "poem" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parsePoem Element
e
    "cite" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseCite Element
e
    "subtitle" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSubtitle Element
e
    "table" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseTable Element
e
    "empty-line" -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
horizontalRule
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "annotation") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | Parse @sectionType@
parseSection :: PandocMonad m => Element -> FB2 m Blocks
parseSection :: Element -> FB2 m Blocks
parseSection e :: Element
e = do
  Int
n <- (FB2State -> Int) -> StateT FB2State m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FB2State -> Int
fb2SectionLevel
  (FB2State -> FB2State) -> StateT FB2State m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FB2State -> FB2State) -> StateT FB2State m ())
-> (FB2State -> FB2State) -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ \st :: FB2State
st -> FB2State
st{ fb2SectionLevel :: Int
fb2SectionLevel = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
  let sectionId :: Text
sectionId = Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" String -> Text
T.pack (Maybe String -> Text) -> Maybe String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr (String -> QName
unqual "id") Element
e
  Blocks
bs <- Attr -> Blocks -> Blocks
divWith (Text
sectionId, ["section"], []) (Blocks -> Blocks) -> ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks) -> StateT FB2State m [Blocks] -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> FB2 m Blocks)
-> [Element] -> StateT FB2State m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSectionChild (Element -> [Element]
elChildren Element
e)
  (FB2State -> FB2State) -> StateT FB2State m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FB2State -> FB2State) -> StateT FB2State m ())
-> (FB2State -> FB2State) -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ \st :: FB2State
st -> FB2State
st{ fb2SectionLevel :: Int
fb2SectionLevel = Int
n }
  Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
bs

parseSectionChild :: PandocMonad m => Element -> FB2 m Blocks
parseSectionChild :: Element -> FB2 m Blocks
parseSectionChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
e of
    "title" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseBodyChild Element
e
    "epigraph" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseEpigraph Element
e
    "image" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseImageElement Element
e
    "annotation" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseAnnotation Element
e
    "poem" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parsePoem Element
e
    "cite" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseCite Element
e
    "empty-line" -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
horizontalRule
    "table" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseTable Element
e
    "subtitle" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSubtitle Element
e
    "p" -> Inlines -> Blocks
para (Inlines -> Blocks) -> StateT FB2State m Inlines -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> StateT FB2State m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parsePType Element
e
    "section" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseSection Element
e
    name :: Text
name -> LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (Text -> Text -> LogMessage
UnexpectedXmlElement Text
name "section") StateT FB2State m () -> Blocks -> FB2 m Blocks
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Blocks
forall a. Monoid a => a
mempty

-- | parse @styleType@
parseStyleType :: PandocMonad m => Element -> FB2 m Inlines
parseStyleType :: Element -> FB2 m Inlines
parseStyleType e :: Element
e = [Inlines] -> Inlines
forall a. Monoid a => [a] -> a
mconcat ([Inlines] -> Inlines)
-> StateT FB2State m [Inlines] -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> FB2 m Inlines)
-> [Content] -> StateT FB2State m [Inlines]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Content -> FB2 m Inlines
parseInline (Element -> [Content]
elContent Element
e)

-- | Parse @namedStyleType@
parseNamedStyle :: PandocMonad m => Element -> FB2 m Inlines
parseNamedStyle :: Element -> FB2 m Inlines
parseNamedStyle e :: Element
e = do
  Inlines
content <- [Inlines] -> Inlines
forall a. Monoid a => [a] -> a
mconcat ([Inlines] -> Inlines)
-> StateT FB2State m [Inlines] -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> FB2 m Inlines)
-> [Content] -> StateT FB2State m [Inlines]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Content -> FB2 m Inlines
parseNamedStyleChild (Element -> [Content]
elContent Element
e)
  let lang :: [(Text, Text)]
lang = Maybe (Text, Text) -> [(Text, Text)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Text, Text) -> [(Text, Text)])
-> Maybe (Text, Text) -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ ("lang",) (Text -> (Text, Text))
-> (String -> Text) -> String -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> (Text, Text)) -> Maybe String -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> Element -> Maybe String
findAttr (String -> Maybe String -> Maybe String -> QName
QName "lang" Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just "xml")) Element
e
  case QName -> Element -> Maybe String
findAttr (String -> QName
unqual "name") Element
e of
    Just name :: String
name -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Attr -> Inlines -> Inlines
spanWith ("", [String -> Text
T.pack String
name], [(Text, Text)]
lang) Inlines
content
    Nothing -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement "link without required name"
      Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inlines
forall a. Monoid a => a
mempty

parseNamedStyleChild :: PandocMonad m => Content -> FB2 m Inlines
parseNamedStyleChild :: Content -> FB2 m Inlines
parseNamedStyleChild (Elem e :: Element
e) =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (Element -> QName
elName Element
e) of
    "strong" -> Inlines -> Inlines
strong (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "emphasis" -> Inlines -> Inlines
emph (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "style" -> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseNamedStyle Element
e
    "a" -> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseLinkType Element
e
    "strikethrough" -> Inlines -> Inlines
strikeout (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "sub" -> Inlines -> Inlines
subscript (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "sup" -> Inlines -> Inlines
superscript (Inlines -> Inlines) -> FB2 m Inlines -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseStyleType Element
e
    "code" -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
code (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
    "image" -> Element -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Inlines
parseInlineImageElement Element
e
    name :: Text
name -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " in style"
      Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inlines
forall a. Monoid a => a
mempty
parseNamedStyleChild x :: Content
x = Content -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Content -> FB2 m Inlines
parseInline Content
x

-- | Parse @linkType@
parseLinkType :: PandocMonad m => Element -> FB2 m Inlines
parseLinkType :: Element -> FB2 m Inlines
parseLinkType e :: Element
e = do
  Inlines
content <- [Inlines] -> Inlines
forall a. Monoid a => [a] -> a
mconcat ([Inlines] -> Inlines)
-> StateT FB2State m [Inlines] -> FB2 m Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> FB2 m Inlines)
-> [Content] -> StateT FB2State m [Inlines]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Content -> FB2 m Inlines
parseStyleLinkType (Element -> [Content]
elContent Element
e)
  Map Text Blocks
notes <- (FB2State -> Map Text Blocks)
-> StateT FB2State m (Map Text Blocks)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FB2State -> Map Text Blocks
fb2Notes
  case String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> Element -> Maybe String
findAttr (String -> Maybe String -> Maybe String -> QName
QName "href" (String -> Maybe String
forall a. a -> Maybe a
Just "http://www.w3.org/1999/xlink") Maybe String
forall a. Maybe a
Nothing) Element
e of
    Just href :: Text
href -> case QName -> Element -> Maybe String
findAttr (String -> Maybe String -> Maybe String -> QName
QName "type" Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing) Element
e of
                   Just "note" -> case Text -> Map Text Blocks -> Maybe Blocks
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
href Map Text Blocks
notes of
                                    Nothing -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Inlines -> Inlines
link Text
href "" Inlines
content
                                    Just contents :: Blocks
contents -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Blocks -> Inlines
note Blocks
contents
                   _ -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Inlines -> Inlines
link Text
href "" Inlines
content
    Nothing -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement "link without required href"
      Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inlines
forall a. Monoid a => a
mempty

-- | Parse @styleLinkType@
parseStyleLinkType :: PandocMonad m => Content -> FB2 m Inlines
parseStyleLinkType :: Content -> FB2 m Inlines
parseStyleLinkType x :: Content
x@(Elem e :: Element
e) =
  case QName -> String
qName (Element -> QName
elName Element
e) of
    "a" -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement "nested link"
      Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inlines
forall a. Monoid a => a
mempty
    _ -> Content -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Content -> FB2 m Inlines
parseInline Content
x
parseStyleLinkType x :: Content
x = Content -> FB2 m Inlines
forall (m :: * -> *). PandocMonad m => Content -> FB2 m Inlines
parseInline Content
x

-- | Parse @tableType@
parseTable :: PandocMonad m => Element -> FB2 m Blocks
parseTable :: Element -> FB2 m Blocks
parseTable _ = Blocks -> FB2 m Blocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocks
forall a. Monoid a => a
mempty -- TODO: tables are not supported yet

-- | Parse @title-infoType@
parseTitleInfoChild :: PandocMonad m => Element -> FB2 m ()
parseTitleInfoChild :: Element -> FB2 m ()
parseTitleInfoChild e :: Element
e =
  case String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ QName -> String
qName (Element -> QName
elName Element
e) of
    "genre" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "author" -> Element -> FB2 m Text
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Text
parseAuthor Element
e FB2 m Text -> (Text -> FB2 m ()) -> FB2 m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \author :: Text
author -> (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\st :: FB2State
st -> FB2State
st {fb2Authors :: [Text]
fb2Authors = Text
authorText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:FB2State -> [Text]
fb2Authors FB2State
st})
    "book-title" -> (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text -> Inlines -> FB2State -> FB2State
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta "title" (Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e))
    "annotation" -> Element -> FB2 m Blocks
forall (m :: * -> *). PandocMonad m => Element -> FB2 m Blocks
parseAnnotation Element
e FB2 m Blocks -> (Blocks -> FB2 m ()) -> FB2 m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FB2State -> FB2State) -> FB2 m ())
-> (Blocks -> FB2State -> FB2State) -> Blocks -> FB2 m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Blocks -> FB2State -> FB2State
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta "abstract"
    "keywords" -> (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text -> [MetaValue] -> FB2State -> FB2State
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta "keywords" ((Text -> MetaValue) -> [Text] -> [MetaValue]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> MetaValue
MetaString (Text -> MetaValue) -> (Text -> Text) -> Text -> MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
trim) ([Text] -> [MetaValue]) -> [Text] -> [MetaValue]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn ","
                                                                      (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
                                                                      (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e))
    "date" -> (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text -> Inlines -> FB2State -> FB2State
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta "date" (Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e))
    "coverpage" -> Element -> FB2 m ()
forall (m :: * -> *). PandocMonad m => Element -> FB2 m ()
parseCoverPage Element
e
    "lang" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "src-lang" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "translator" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    "sequence" -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    name :: Text
name -> LogMessage -> FB2 m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> FB2 m ()) -> LogMessage -> FB2 m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " in title-info"

parseCoverPage :: PandocMonad m => Element -> FB2 m ()
parseCoverPage :: Element -> FB2 m ()
parseCoverPage e :: Element
e =
  case QName -> Element -> Maybe Element
findChild (String -> Maybe String -> Maybe String -> QName
QName "image" (String -> Maybe String
forall a. a -> Maybe a
Just "http://www.gribuser.ru/xml/fictionbook/2.0") Maybe String
forall a. Maybe a
Nothing) Element
e of
    Just img :: Element
img -> case Maybe Text
href of
                  Just src :: Text
src -> (FB2State -> FB2State) -> FB2 m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text -> MetaValue -> FB2State -> FB2State
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta "cover-image" (Text -> MetaValue
MetaString (Text -> MetaValue) -> Text -> MetaValue
forall a b. (a -> b) -> a -> b
$ Text -> Text
removeHash Text
src))
                  Nothing -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                where href :: Maybe Text
href = String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> Element -> Maybe String
findAttr (String -> Maybe String -> Maybe String -> QName
QName "href" (String -> Maybe String
forall a. a -> Maybe a
Just "http://www.w3.org/1999/xlink") Maybe String
forall a. Maybe a
Nothing) Element
img
    Nothing -> () -> FB2 m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Parse @inlineImageType@ element
parseInlineImageElement :: PandocMonad m
                        => Element
                        -> FB2 m Inlines
parseInlineImageElement :: Element -> FB2 m Inlines
parseInlineImageElement e :: Element
e =
  case Maybe Text
href of
    Just src :: Text
src -> Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inlines -> FB2 m Inlines) -> Inlines -> FB2 m Inlines
forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Text -> Inlines -> Inlines
imageWith ("", [], []) (Text -> Text
removeHash Text
src) "" Inlines
alt
    Nothing -> do
      LogMessage -> StateT FB2State m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT FB2State m ())
-> LogMessage -> StateT FB2State m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredElement "inline image without href"
      Inlines -> FB2 m Inlines
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inlines
forall a. Monoid a => a
mempty
  where alt :: Inlines
alt = Inlines -> (String -> Inlines) -> Maybe String -> Inlines
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Inlines
forall a. Monoid a => a
mempty (Text -> Inlines
str (Text -> Inlines) -> (String -> Text) -> String -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Maybe String -> Inlines) -> Maybe String -> Inlines
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr (String -> QName
unqual "alt") Element
e
        href :: Maybe Text
href = String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> Element -> Maybe String
findAttr (String -> Maybe String -> Maybe String -> QName
QName "href" (String -> Maybe String
forall a. a -> Maybe a
Just "http://www.w3.org/1999/xlink") Maybe String
forall a. Maybe a
Nothing) Element
e