{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings   #-}
{- |
   Module      : Text.Pandoc.Writers.ODT
   Copyright   : Copyright (C) 2008-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to ODT.
-}
module Text.Pandoc.Writers.ODT ( writeODT, writeFODT ) where
import Codec.Archive.Zip
import Control.Monad.Except (catchError, throwError)
import Control.Monad.State.Strict (StateT, evalStateT, gets, modify, lift)
import Control.Monad (MonadPlus(mplus))
import Data.ByteString.Base64 (encode)
import qualified Data.ByteString.Lazy as B
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe, maybeToList)
import Data.Generics (everywhere', mkT)
import Data.List (isPrefixOf, partition)
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time
import System.FilePath (takeDirectory, takeExtension, (<.>), (</>), isAbsolute)
import Text.Collate.Lang (Lang (..), renderLang)
import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang)
import qualified Text.Pandoc.Class.PandocMonad as P
import Text.Pandoc.Data (readDataFile)
import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError(..))
import Text.Pandoc.ImageSize
import Text.Pandoc.Logging
import Text.Pandoc.MIME (extensionFromMimeType, getMimeType)
import Text.Pandoc.Options (WrapOption (..), WriterOptions (..),
                            HighlightMethod(Skylighting, DefaultHighlighting))
import Text.Pandoc.Highlighting (defaultStyle)
import Text.DocLayout
import Text.Pandoc.Shared (stringify, stringifyInlines, tshow)
import Text.Pandoc.Templates (compileDefaultTemplate)
import Text.Pandoc.Version (pandocVersionText)
import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks,
                                   fixDisplayMath, getLang,
                                   ensureValidXmlIdentifiers)
import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toText, toTextLazy)
import Text.Pandoc.Walk
import Text.Pandoc.Writers.OpenDocument (writeOpenDocument)
import Text.Pandoc.XML
import Text.Pandoc.XML.Light
import qualified Text.Pandoc.XML.Light as XML
import Text.TeXMath
import qualified Text.XML.Light as XL
import Network.URI (parseRelativeReference, URI(uriPath), isURI)
import Skylighting

-- | ODF can be written either as a zip archive of several XML files or
-- as a single flat XML file.
data ODTVariant = Zipped | Flat deriving (ODTVariant -> ODTVariant -> Bool
(ODTVariant -> ODTVariant -> Bool)
-> (ODTVariant -> ODTVariant -> Bool) -> Eq ODTVariant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ODTVariant -> ODTVariant -> Bool
== :: ODTVariant -> ODTVariant -> Bool
$c/= :: ODTVariant -> ODTVariant -> Bool
/= :: ODTVariant -> ODTVariant -> Bool
Eq, Int -> ODTVariant -> ShowS
[ODTVariant] -> ShowS
ODTVariant -> String
(Int -> ODTVariant -> ShowS)
-> (ODTVariant -> String)
-> ([ODTVariant] -> ShowS)
-> Show ODTVariant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ODTVariant -> ShowS
showsPrec :: Int -> ODTVariant -> ShowS
$cshow :: ODTVariant -> String
show :: ODTVariant -> String
$cshowList :: [ODTVariant] -> ShowS
showList :: [ODTVariant] -> ShowS
Show)

data ODTState = ODTState { ODTState -> [Entry]
stEntries :: [Entry]
                         , ODTState -> ODTVariant
stVariant :: ODTVariant
                         }

type O m = StateT ODTState m

-- | Produce an ODT file from a Pandoc document.
writeODT :: PandocMonad m
         => WriterOptions  -- ^ Writer options
         -> Pandoc         -- ^ Document to convert
         -> m B.ByteString
writeODT :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m ByteString
writeODT  WriterOptions
opts Pandoc
doc =
  let initState :: ODTState
initState = ODTState{ stEntries :: [Entry]
stEntries = []
                          , stVariant :: ODTVariant
stVariant = ODTVariant
Zipped
                          }
      doc' :: Pandoc
doc' = Pandoc -> Pandoc
fixInternalLinks (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> Pandoc
ensureValidXmlIdentifiers (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$ Pandoc
doc
  in
    Archive -> ByteString
fromArchive (Archive -> ByteString) -> m Archive -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ODTState m Archive -> ODTState -> m Archive
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterOptions -> Pandoc -> StateT ODTState m Archive
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> O m Archive
pandocToODT WriterOptions
opts Pandoc
doc') ODTState
initState

-- | ODT internal links are evaluated relative to an imaginary folder
-- structure that mirrors the zip structure.  The result is that relative
-- links in the document need to start with `..`.  See #3524.
-- This does not apply to flat ODF, which is a single file.
fixInternalLinks :: Pandoc -> Pandoc
fixInternalLinks :: Pandoc -> Pandoc
fixInternalLinks = (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
go
 where
  go :: Inline -> Inline
go (Link Attr
attr [Inline]
ils (Text
src,Text
tit)) =
    Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
ils (Text -> Text
fixRel Text
src,Text
tit)
  go Inline
x = Inline
x
  fixRel :: Text -> Text
fixRel Text
uri =
    case String -> Maybe URI
parseRelativeReference (Text -> String
T.unpack Text
uri) of
      Just URI
u
        | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriPath URI
u)) -> URI -> Text
forall a. Show a => a -> Text
tshow (URI -> Text) -> URI -> Text
forall a b. (a -> b) -> a -> b
$ URI
u{ uriPath = "../" <> uriPath u }
      Maybe URI
_ -> Text
uri

-- | Produce a flat OpenDocument text file (@.fodt@) from a Pandoc
-- document.  This is the same content as an ODT, but as a single XML
-- file instead of a zip archive.
writeFODT :: PandocMonad m
          => WriterOptions  -- ^ Writer options
          -> Pandoc         -- ^ Document to convert
          -> m T.Text
writeFODT :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeFODT WriterOptions
opts Pandoc
doc = do
  let initState :: ODTState
initState = ODTState{ stEntries :: [Entry]
stEntries = []
                          , stVariant :: ODTVariant
stVariant = ODTVariant
Flat
                          }
      -- note: no fixInternalLinks, since a flat file has no zip
      -- structure for relative references to be resolved against
      doc' :: Pandoc
doc' = Pandoc -> Pandoc
ensureValidXmlIdentifiers Pandoc
doc
  StateT ODTState m Archive -> ODTState -> m Archive
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterOptions -> Pandoc -> StateT ODTState m Archive
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> O m Archive
pandocToODT WriterOptions
opts Pandoc
doc') ODTState
initState m Archive -> (Archive -> m Text) -> m Text
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> m Text
forall (m :: * -> *). PandocMonad m => Archive -> m Text
flattenODT

officeNS :: T.Text
officeNS :: Text
officeNS = Text
"urn:oasis:names:tc:opendocument:xmlns:office:1.0"

officeQName :: T.Text -> QName
officeQName :: Text -> QName
officeQName Text
n = Text -> Maybe Text -> Maybe Text -> QName
QName Text
n (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
officeNS) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"office")

-- | The top-level child of an ODF part, e.g. @office:body@ of
-- @content.xml@.  Only the local name is matched if the document gives
-- no namespace URI.
officeChild :: T.Text -> Element -> Maybe Element
officeChild :: Text -> Element -> Maybe Element
officeChild Text
name Element
el = [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe
  [ Element
e | Elem Element
e <- Element -> [Content]
elContent Element
el
      , QName -> Text
qName (Element -> QName
elName Element
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
      , Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
officeNS) (QName -> Maybe Text
qURI (Element -> QName
elName Element
e)) ]

-- | Convert an ODT archive into the equivalent flat OpenDocument file.
--
-- A flat ODF file is a single @office:document@ element whose children
-- are exactly the top-level elements that are otherwise distributed over
-- @content.xml@, @styles.xml@, @meta.xml@ and @settings.xml@, in this
-- order:
--
-- > office:meta? office:settings? office:scripts? office:font-face-decls?
-- > office:styles? office:automatic-styles? office:master-styles? office:body
--
-- Anything that would be a separate archive entry -- images and
-- formulas -- is embedded inline instead.
flattenODT :: forall m . PandocMonad m => Archive -> m T.Text
flattenODT :: forall (m :: * -> *). PandocMonad m => Archive -> m Text
flattenODT Archive
archive = do
  contentRoot <- String -> m Element
getRoot String
"content.xml"
  stylesRoot  <- getRoot "styles.xml"
  metaRoot    <- getRoot "meta.xml"
  -- the bundled reference.odt has no settings.xml, but a reference doc
  -- written by LibreOffice does
  settingsRoot <- traverse parseEntry (findEntryByPath "settings.xml" archive)
  let roots = [Element
contentRoot, Element
stylesRoot, Element
metaRoot] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ Maybe Element -> [Element]
forall a. Maybe a -> [a]
maybeToList Maybe Element
settingsRoot
  -- only one of each of these is allowed in a document, so the ones
  -- from content.xml and styles.xml must be combined
  let (fontFaceDecls, _) = mergeParts (officeChild "font-face-decls" contentRoot)
                                      (officeChild "font-face-decls" stylesRoot)
  let (automaticStyles, dropped) =
        mergeParts (officeChild "automatic-styles" contentRoot)
                   (officeChild "automatic-styles" stylesRoot)
  mapM_ (\Element
e -> LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
UnusualConversion (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$
                 Text
"flat OpenDocument output: dropping the automatic style "
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text, Text) -> Text
forall a b. (a, b) -> b
snd (Element -> (Text, Text)
partKey Element
e) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from styles.xml, because content.xml "
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"defines a style of the same name")
        dropped
  let children = [Maybe Element] -> [Element]
forall a. [Maybe a] -> [a]
catMaybes
        [ Text -> Element -> Maybe Element
officeChild Text
"meta" Element
metaRoot
        , Maybe Element
settingsRoot Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Element -> Maybe Element
officeChild Text
"settings"
        , [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe ([Element] -> Maybe Element) -> [Element] -> Maybe Element
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe Element) -> [Element] -> [Element]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Element -> Maybe Element
officeChild Text
"scripts") [Element]
roots
        , Maybe Element
fontFaceDecls
        , Text -> Element -> Maybe Element
officeChild Text
"styles" Element
stylesRoot
        , Maybe Element
automaticStyles
        , Text -> Element -> Maybe Element
officeChild Text
"master-styles" Element
stylesRoot
        , Text -> Element -> Maybe Element
officeChild Text
"body" Element
contentRoot
        ]
  let root = QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (Text -> QName
officeQName Text
"document")
               ( QName -> Text -> Attr
Attr (Text -> QName
officeQName Text
"mimetype")
                      Text
"application/vnd.oasis.opendocument.text"
               Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: QName -> Text -> Attr
Attr (Text -> QName
officeQName Text
"version") Text
"1.3"
               Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Element] -> [Attr]
nsDecls [Element]
roots )
               ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map (Element -> Content
Elem (Element -> Content) -> (Element -> Element) -> Element -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archive -> Element -> Element
embedArchiveRefs Archive
archive) [Element]
children)
               Maybe Line
forall a. Maybe a
Nothing
  -- note: not prettyConfigPP, which would inject whitespace into text
  -- content and thereby change the document
  return $ showTopElement root
 where
  parseEntry :: Entry -> m Element
  parseEntry :: Entry -> m Element
parseEntry Entry
e =
    case Text -> Either Text Element
parseXMLElement (ByteString -> Text
toTextLazy (Entry -> ByteString
fromEntry Entry
e)) of
      Left Text
msg -> PandocError -> m Element
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Element) -> PandocError -> m Element
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocXMLError (String -> Text
T.pack (Entry -> String
eRelativePath Entry
e)) Text
msg
      Right Element
el -> Element -> m Element
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Element
el
  getRoot :: FilePath -> m Element
  getRoot :: String -> m Element
getRoot String
path =
    case String -> Archive -> Maybe Entry
findEntryByPath String
path Archive
archive of
      Maybe Entry
Nothing -> PandocError -> m Element
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Element) -> PandocError -> m Element
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
                   Text
"Could not find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in the ODT archive"
      Just Entry
e  -> Entry -> m Element
parseEntry Entry
e

-- | The union of the namespace declarations on the given elements.
-- Declarations survive parsing as ordinary attributes with the prefix
-- @xmlns@, and are not synthesised on output, so they must be carried
-- over to the flat file's root by hand.  Declarations on nested elements
-- are copied along with those elements.
nsDecls :: [Element] -> [XML.Attr]
nsDecls :: [Element] -> [Attr]
nsDecls [Element]
els = Map (Maybe Text, Text) Attr -> [Attr]
forall k a. Map k a -> [a]
Map.elems (Map (Maybe Text, Text) Attr -> [Attr])
-> Map (Maybe Text, Text) Attr -> [Attr]
forall a b. (a -> b) -> a -> b
$ (Attr -> Attr -> Attr)
-> [((Maybe Text, Text), Attr)] -> Map (Maybe Text, Text) Attr
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\Attr
_new Attr
old -> Attr
old)
  [ ((QName -> Maybe Text
qPrefix (Attr -> QName
attrKey Attr
a), QName -> Text
qName (Attr -> QName
attrKey Attr
a)), Attr
a)
  | Element
el <- [Element]
els
  , Attr
a <- Element -> [Attr]
elAttribs Element
el
  , QName -> Bool
isNSDecl (Attr -> QName
attrKey Attr
a) ]
 where
  isNSDecl :: QName -> Bool
isNSDecl QName
qn = QName -> Maybe Text
qPrefix QName
qn Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xmlns"
                Bool -> Bool -> Bool
|| (QName -> Maybe Text
qPrefix QName
qn Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& QName -> Text
qName QName
qn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"xmlns")

-- | Combine two @office:font-face-decls@ or @office:automatic-styles@
-- elements, preferring the first.  Returns the merged element and the
-- declarations of the second that were dropped as duplicates.
mergeParts :: Maybe Element -> Maybe Element -> (Maybe Element, [Element])
mergeParts :: Maybe Element -> Maybe Element -> (Maybe Element, [Element])
mergeParts Maybe Element
Nothing  Maybe Element
mbSecond = (Maybe Element
mbSecond, [])
mergeParts Maybe Element
mbFirst  Maybe Element
Nothing  = (Maybe Element
mbFirst, [])
mergeParts (Just Element
first) (Just Element
second) =
  (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
first{ elContent = elContent first ++ map Elem kept }, [Element]
dropped)
 where
  keys :: [(Text, Text)]
keys = (Element -> (Text, Text)) -> [Element] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Element -> (Text, Text)
partKey [ Element
e | Elem Element
e <- Element -> [Content]
elContent Element
first ]
  ([Element]
dropped, [Element]
kept) = (Element -> Bool) -> [Element] -> ([Element], [Element])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (((Text, Text) -> [(Text, Text)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Text, Text)]
keys) ((Text, Text) -> Bool)
-> (Element -> (Text, Text)) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> (Text, Text)
partKey)
                              [ Element
e | Elem Element
e <- Element -> [Content]
elContent Element
second ]

-- | Identify a font face or automatic style by its element name and
-- @style:name@.
partKey :: Element -> (T.Text, T.Text)
partKey :: Element -> (Text, Text)
partKey Element
e = (QName -> Text
qName (Element -> QName
elName Element
e), Element -> Text
partStyleName Element
e)

partStyleName :: Element -> T.Text
partStyleName :: Element -> Text
partStyleName Element
e = [Text] -> Text
T.concat [ Attr -> Text
attrVal Attr
a
                           | Attr
a <- Element -> [Attr]
elAttribs Element
e
                           , QName -> Text
qName (Attr -> QName
attrKey Attr
a) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"name"
                           , QName -> Maybe Text
qPrefix (Attr -> QName
attrKey Attr
a) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"style" ]

-- | Replace references to other entries of the ODT archive by the
-- entries' contents, which is the only way a flat file can carry them:
-- images become base64 in an @office:binary-data@ child, formulas
-- become MathML inside the @draw:object@.
--
-- Note that this is applied to every copied part, not just the body, so
-- that images used by a reference document's headers, footers and master
-- styles are embedded too.  References that do not resolve to an archive
-- entry are left alone; in particular, this is what makes
-- @--link-images@ work, since it writes no @Pictures/@ entry.
embedArchiveRefs :: Archive -> Element -> Element
embedArchiveRefs :: Archive -> Element -> Element
embedArchiveRefs Archive
archive = Element -> Element
go
 where
  go :: Element -> Element
go Element
el =
    case QName -> Text
qName (Element -> QName
elName Element
el) of
      Text
"image"
        | Just Entry
entry <- (String -> Archive -> Maybe Entry)
-> Archive -> String -> Maybe Entry
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Archive -> Maybe Entry
findEntryByPath Archive
archive (String -> Maybe Entry) -> (Text -> String) -> Text -> Maybe Entry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe Entry) -> Maybe Text -> Maybe Entry
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Element -> Maybe Text
xlinkHref Element
el
        -> Entry -> Element -> Element
embedImage Entry
entry Element
el
      Text
"object"
        | Just String
path <- Text -> Maybe String
formulaPath (Text -> Maybe String) -> Maybe Text -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Element -> Maybe Text
xlinkHref Element
el
        , Just Entry
entry <- String -> Archive -> Maybe Entry
findEntryByPath String
path Archive
archive
        , Right Element
mathml <- Text -> Either Text Element
parseXMLElement (ByteString -> Text
toTextLazy (Entry -> ByteString
fromEntry Entry
entry))
        -> (Element -> Element
dropXlinkAttrs Element
el){ elContent = [Elem mathml] }
      Text
_ -> Element
el{ elContent = map goContent (elContent el) }
  goContent :: Content -> Content
goContent (Elem Element
e) = Element -> Content
Elem (Element -> Element
go Element
e)
  goContent Content
c = Content
c

  embedImage :: Entry -> Element -> Element
embedImage Entry
entry Element
el =
    case Element -> Element
dropXlinkAttrs Element
el of
      Element
el' -> Element
el'{ elAttribs = mimeAttrs ++ elAttribs el'
                , elContent = elContent el' ++ [Elem binaryData] }
   where
    mimeAttrs :: [Attr]
mimeAttrs = [ QName -> Text -> Attr
Attr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"mime-type" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"draw")) Text
m
                | Just Text
m <- [String -> Maybe Text
getMimeType (Entry -> String
eRelativePath Entry
entry)] ]
    binaryData :: Element
binaryData = QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (Text -> QName
officeQName Text
"binary-data") []
                   [CData -> Content
XML.Text (CDataKind -> Text -> Maybe Line -> CData
CData CDataKind
CDataText (ByteString -> Text
base64 (Entry -> ByteString
fromEntry Entry
entry)) Maybe Line
forall a. Maybe a
Nothing)]
                   Maybe Line
forall a. Maybe a
Nothing

  base64 :: ByteString -> Text
base64 = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> (ByteString -> [Text]) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [Text]
T.chunksOf Int
76 (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
toText (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.toStrict

  -- the formula's MathML lives in content.xml of the directory the
  -- reference names
  formulaPath :: Text -> Maybe String
formulaPath Text
href =
    case Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
href (Text -> Text -> Maybe Text
T.stripPrefix Text
"./" Text
href) of
      Text
"" -> Maybe String
forall a. Maybe a
Nothing
      Text
h  -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
              (if Text
"/" Text -> Text -> Bool
`T.isSuffixOf` Text
h then Text
h else Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"content.xml"

xlinkHref :: Element -> Maybe T.Text
xlinkHref :: Element -> Maybe Text
xlinkHref Element
el = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [ Attr -> Text
attrVal Attr
a
                           | Attr
a <- Element -> [Attr]
elAttribs Element
el
                           , QName -> Text
qName (Attr -> QName
attrKey Attr
a) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"href"
                           , QName -> Maybe Text
qPrefix (Attr -> QName
attrKey Attr
a) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xlink" ]

-- | Drop the attributes with which the ODT writer refers to an archive
-- entry; the content is about to be embedded instead.
dropXlinkAttrs :: Element -> Element
dropXlinkAttrs :: Element -> Element
dropXlinkAttrs Element
el = Element
el{ elAttribs = filter (not . isRef . attrKey) (elAttribs el) }
 where
  isRef :: QName -> Bool
isRef QName
qn = QName -> Maybe Text
qPrefix QName
qn Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xlink"
             Bool -> Bool -> Bool
&& QName -> Text
qName QName
qn Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"href", Text
"type", Text
"show", Text
"actuate"]

-- | Produce an ODT archive from a Pandoc document.
pandocToODT :: PandocMonad m
            => WriterOptions  -- ^ Writer options
            -> Pandoc         -- ^ Document to convert
            -> O m Archive
pandocToODT :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> O m Archive
pandocToODT WriterOptions
opts doc :: Pandoc
doc@(Pandoc Meta
meta [Block]
_) = do
  let title :: [Inline]
title = Meta -> [Inline]
docTitle Meta
meta
  let authors :: [[Inline]]
authors = Meta -> [[Inline]]
docAuthors Meta
meta
  utctime <- StateT ODTState m UTCTime
forall (m :: * -> *). PandocMonad m => m UTCTime
P.getTimestamp
  lang <- toLang (getLang opts meta)
  refArchive <-
       case writerReferenceDoc opts of
             Just String
f -> do
               arch <- m (Either String Archive)
-> StateT ODTState m (Either String Archive)
forall (m :: * -> *) a. Monad m => m a -> StateT ODTState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either String Archive)
 -> StateT ODTState m (Either String Archive))
-> m (Either String Archive)
-> StateT ODTState m (Either String Archive)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Archive
toArchiveOrFail (ByteString -> Either String Archive)
-> ((ByteString, Maybe Text) -> ByteString)
-> (ByteString, Maybe Text)
-> Either String Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.fromStrict (ByteString -> ByteString)
-> ((ByteString, Maybe Text) -> ByteString)
-> (ByteString, Maybe Text)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe Text) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, Maybe Text) -> Either String Archive)
-> m (ByteString, Maybe Text) -> m (Either String Archive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                (Text -> m (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem (String -> Text
T.pack String
f))
               case arch of
                 Left String
err -> PandocError -> StateT ODTState m Archive
forall a. PandocError -> StateT ODTState m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> StateT ODTState m Archive)
-> PandocError -> StateT ODTState m Archive
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
                   Text
"Could not parse reference-doc " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                     String -> Text
forall a. Show a => a -> Text
tshow String
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
                 Right Archive
x -> Archive -> StateT ODTState m Archive
forall a. a -> StateT ODTState m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Archive
x
             Maybe String
Nothing -> do
               arch <- m (Either String Archive)
-> StateT ODTState m (Either String Archive)
forall (m :: * -> *) a. Monad m => m a -> StateT ODTState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either String Archive)
 -> StateT ODTState m (Either String Archive))
-> m (Either String Archive)
-> StateT ODTState m (Either String Archive)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Archive
toArchiveOrFail (ByteString -> Either String Archive)
-> (ByteString -> ByteString)
-> ByteString
-> Either String Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.fromStrict (ByteString -> Either String Archive)
-> m ByteString -> m (Either String Archive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                String -> m ByteString
forall (m :: * -> *). PandocMonad m => String -> m ByteString
readDataFile String
"reference.odt"
               case arch of
                 Left String
err -> PandocError -> StateT ODTState m Archive
forall a. PandocError -> StateT ODTState m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> StateT ODTState m Archive)
-> PandocError -> StateT ODTState m Archive
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
                   Text
"Could not parse reference.odt: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
                 Right Archive
x -> Archive -> StateT ODTState m Archive
forall a. a -> StateT ODTState m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Archive
x
  -- handle formulas and pictures
  -- picEntriesRef <- P.newIORef ([] :: [Entry])
  let refTextWidth = WriterOptions -> Archive -> Maybe Double
referenceTextWidthPt WriterOptions
opts Archive
refArchive
  doc' <- walkM (transformPicMath opts refTextWidth) $ walk fixDisplayMath doc
  tpl <- maybe (lift $ compileDefaultTemplate "opendocument") pure
           (writerTemplate opts)
  newContents <- lift $ writeOpenDocument
                   opts{ writerWrapText = WrapNone, writerTemplate = Just tpl } doc'
  epochtime <- floor `fmap` lift P.getPOSIXTime
  let contentEntry = String -> Line -> ByteString -> Entry
toEntry String
"content.xml" Line
epochtime
                     (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
fromTextLazy (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
newContents
  picEntries <- gets stEntries
  let archive = (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
refArchive
                ([Entry] -> Archive) -> [Entry] -> Archive
forall a b. (a -> b) -> a -> b
$ Entry
contentEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: [Entry]
picEntries
  -- construct META-INF/manifest.xml based on archive
  let toFileEntry String
fp = case String -> Maybe Text
getMimeType String
fp of
                        Maybe Text
Nothing  -> Doc a
forall a. Doc a
empty
                        Just Text
m   -> Text -> [(Text, Text)] -> Doc a
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"manifest:file-entry"
                                     [(Text
"manifest:media-type", Text
m)
                                     ,(Text
"manifest:full-path", String -> Text
T.pack String
fp)
                                     ]
  let files = [ String
ent | String
ent <- Archive -> [String]
filesInArchive Archive
archive,
                             Bool -> Bool
not (String
"META-INF" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
ent) ]
  let formulas = [ ShowS
takeDirectory String
ent String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" | String
ent <- Archive -> [String]
filesInArchive Archive
archive,
                      String
"Formula-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
ent, ShowS
takeExtension String
ent String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".xml" ]
  let manifestEntry = String -> Line -> ByteString -> Entry
toEntry String
"META-INF/manifest.xml" Line
epochtime
        (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromStringLazy (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Doc String -> String
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing
        (Doc String -> String) -> Doc String -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc String
forall a. HasChars a => String -> Doc a
text String
"<?xml version=\"1.0\" encoding=\"utf-8\"?>"
        Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
         Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"manifest:manifest"
            [(Text
"xmlns:manifest",Text
"urn:oasis:names:tc:opendocument:xmlns:manifest:1.0")
            ,(Text
"manifest:version",Text
"1.3")] ( Text -> [(Text, Text)] -> Doc String
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"manifest:file-entry"
                 [(Text
"manifest:media-type",Text
"application/vnd.oasis.opendocument.text")
                 ,(Text
"manifest:full-path",Text
"/")
                 ,(Text
"manifest:version", Text
"1.3")]
                Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$ [Doc String] -> Doc String
forall a. [Doc a] -> Doc a
vcat ( (String -> Doc String) -> [String] -> [Doc String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc String
forall a. HasChars a => String -> Doc a
toFileEntry [String]
files )
                Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$ [Doc String] -> Doc String
forall a. [Doc a] -> Doc a
vcat ( (String -> Doc String) -> [String] -> [Doc String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc String
forall a. HasChars a => String -> Doc a
toFileEntry [String]
formulas )
              )
  let archive' = Entry -> Archive -> Archive
addEntryToArchive Entry
manifestEntry Archive
archive
  -- create meta.xml
  let userDefinedMetaFields = [Text
k | Text
k <- Map Text MetaValue -> [Text]
forall k a. Map k a -> [k]
Map.keys (Meta -> Map Text MetaValue
unMeta Meta
meta)
                              , Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"title", Text
"lang", Text
"author"
                                           , Text
"description", Text
"subject", Text
"keywords"]]
  let escapedText = String -> Doc String
forall a. HasChars a => String -> Doc a
text (String -> Doc String) -> (Text -> String) -> Text -> Doc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeStringForXML
  let keywords = case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"keywords" Meta
meta of
                      Just (MetaList [MetaValue]
xs) -> (MetaValue -> Text) -> [MetaValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map MetaValue -> Text
forall a. Walkable Inline a => a -> Text
stringify [MetaValue]
xs
                      Maybe MetaValue
_                  -> []
  let userDefinedMeta =
        (Text -> Doc String) -> [Text] -> [Doc String]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
k -> Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"meta:user-defined"
              [ (Text
"meta:name", Text -> Text
escapeStringForXML Text
k)
              ,(Text
"meta:value-type", Text
"string")
              ] (Text -> Doc String
escapedText (Text -> Doc String) -> Text -> Doc String
forall a b. (a -> b) -> a -> b
$ Text -> Meta -> Text
lookupMetaString Text
k Meta
meta)) [Text]
userDefinedMetaFields
  let metaTag Text
metafield = Text -> Doc String -> Doc String
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
metafield (Doc String -> Doc String)
-> (Text -> Doc String) -> Text -> Doc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc String
escapedText
  let metaEntry = String -> Line -> ByteString -> Entry
toEntry String
"meta.xml" Line
epochtime
       (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromStringLazy (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Doc String -> String
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing
       (Doc String -> String) -> Doc String -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc String
forall a. HasChars a => String -> Doc a
text String
"<?xml version=\"1.0\" encoding=\"utf-8\"?>"
       Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
        Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"office:document-meta"
           [(Text
"xmlns:office",Text
"urn:oasis:names:tc:opendocument:xmlns:office:1.0")
           ,(Text
"xmlns:xlink",Text
"http://www.w3.org/1999/xlink")
           ,(Text
"xmlns:dc",Text
"http://purl.org/dc/elements/1.1/")
           ,(Text
"xmlns:meta",Text
"urn:oasis:names:tc:opendocument:xmlns:meta:1.0")
           ,(Text
"xmlns:ooo",Text
"http://openoffice.org/2004/office")
           ,(Text
"xmlns:grddl",Text
"http://www.w3.org/2003/g/data-view#")
           ,(Text
"office:version",Text
"1.3")] ( Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"office:meta" []
                 ( Text -> Text -> Doc String
metaTag Text
"meta:generator" (Text
"Pandoc/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pandocVersionText)
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   Text -> Text -> Doc String
metaTag Text
"dc:title" ([Inline] -> Text
forall (t :: * -> *). Foldable t => t Inline -> Text
stringifyInlines [Inline]
title)
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   Text -> Text -> Doc String
metaTag Text
"dc:description"
                          (Text -> [Text] -> Text
T.intercalate Text
"\n" ((Block -> Text) -> [Block] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Text
forall a. Walkable Inline a => a -> Text
stringify ([Block] -> [Text]) -> [Block] -> [Text]
forall a b. (a -> b) -> a -> b
$
                                         Text -> Meta -> [Block]
lookupMetaBlocks Text
"description" Meta
meta))
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   Text -> Text -> Doc String
metaTag Text
"dc:subject" (Text -> Meta -> Text
lookupMetaString Text
"subject" Meta
meta)
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   Text -> Text -> Doc String
metaTag Text
"meta:keyword" (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
keywords)
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   case Maybe Lang
lang of
                        Just Lang
l  -> Text -> Text -> Doc String
metaTag Text
"dc:language" (Lang -> Text
renderLang Lang
l)
                        Maybe Lang
Nothing -> Doc String
forall a. Doc a
empty
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   (\Text
d Text
a -> Text -> Text -> Doc String
metaTag Text
"meta:initial-creator" Text
a
                         Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$ Text -> Text -> Doc String
metaTag Text
"dc:creator" Text
a
                         Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$ Text -> Text -> Doc String
metaTag Text
"meta:creation-date" Text
d
                         Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$ Text -> Text -> Doc String
metaTag Text
"dc:date" Text
d
                   ) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%FT%XZ" UTCTime
utctime)
                     (Text -> [Text] -> Text
T.intercalate Text
"; " (([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall (t :: * -> *). Foldable t => t Inline -> Text
stringifyInlines [[Inline]]
authors))
                   Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
                   [Doc String] -> Doc String
forall a. [Doc a] -> Doc a
vcat [Doc String]
userDefinedMeta
                 )
             )
  -- make sure mimetype is first
  let mimetypeEntry = String -> Line -> ByteString -> Entry
toEntry String
"mimetype" Line
epochtime
                      (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromStringLazy String
"application/vnd.oasis.opendocument.text"
  archive'' <- updateStyle opts lang
                  $ addEntryToArchive mimetypeEntry
                  $ addEntryToArchive metaEntry archive'
  return archive''

updateStyle :: forall m . PandocMonad m
            => WriterOptions -> Maybe Lang -> Archive -> O m Archive
updateStyle :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe Lang -> Archive -> O m Archive
updateStyle WriterOptions
opts Maybe Lang
mbLang Archive
arch = do
  epochtime <- POSIXTime -> Line
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Line)
-> StateT ODTState m POSIXTime -> StateT ODTState m Line
forall a b. (a -> b) -> StateT ODTState m a -> StateT ODTState m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m POSIXTime -> StateT ODTState m POSIXTime
forall (m :: * -> *) a. Monad m => m a -> StateT ODTState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m POSIXTime
forall (m :: * -> *). PandocMonad m => m POSIXTime
P.getPOSIXTime
  let goEntry :: Entry -> O m Entry
      goEntry Entry
e
        | Entry -> String
eRelativePath Entry
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"styles.xml"
          = case Text -> Either Text Element
parseXMLElement (ByteString -> Text
toTextLazy (Entry -> ByteString
fromEntry Entry
e)) of
              Left Text
msg -> PandocError -> O m Entry
forall a. PandocError -> StateT ODTState m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> O m Entry) -> PandocError -> O m Entry
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocXMLError Text
"styles.xml" Text
msg
              Right Element
d -> Entry -> O m Entry
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> O m Entry) -> Entry -> O m Entry
forall a b. (a -> b) -> a -> b
$
                String -> Line -> ByteString -> Entry
toEntry String
"styles.xml" Line
epochtime
                ( Text -> ByteString
fromTextLazy
                (Text -> ByteString) -> (Element -> Text) -> Element -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
                (Text -> Text) -> (Element -> Text) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
showTopElement
                (Element -> Text) -> (Element -> Element) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Element)
-> (Lang -> Element -> Element) -> Maybe Lang -> Element -> Element
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Element -> Element
forall a. a -> a
id Lang -> Element -> Element
addLang Maybe Lang
mbLang
                (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName -> Bool) -> (Element -> Element) -> Element -> Element
transformElement (\QName
qn -> QName -> Text
qName QName
qn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"styles" Bool -> Bool -> Bool
&&
                                      QName -> Maybe Text
qPrefix QName
qn Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"office" )
                     (Element -> Element
addListItemStyles (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                      (case WriterOptions -> HighlightMethod
writerHighlightMethod WriterOptions
opts of
                        Skylighting Style
style -> Style -> Element -> Element
addHlStyles Style
style
                        HighlightMethod
DefaultHighlighting -> Style -> Element -> Element
addHlStyles Style
defaultStyle
                        HighlightMethod
_ -> Element -> Element
forall a. a -> a
id))
                (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Element
d )
        | Bool
otherwise = Entry -> O m Entry
forall a. a -> StateT ODTState m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entry
e
  entries <- mapM goEntry (zEntries arch)
  return arch{ zEntries = entries }

addHlStyles :: Style -> Element -> Element
addHlStyles :: Style -> Element -> Element
addHlStyles Style
sty Element
el =
  Element
el{ elContent = filter (not . isHlStyle) (elContent el) ++
                styleToOpenDocument sty }
 where
   isHlStyle :: Content -> Bool
isHlStyle (Elem Element
e) = Text
"Tok" Text -> Text -> Bool
`T.isSuffixOf` (QName -> Text
qName (Element -> QName
elName Element
e))
   isHlStyle Content
_ = Bool
False

-- | Ensure the office:styles element contains paragraph styles for
-- list items used by the OpenDocument writer.  This injects only the
-- styles that are missing, so a user-supplied reference.odt may
-- override any of them.
addListItemStyles :: Element -> Element
addListItemStyles :: Element -> Element
addListItemStyles Element
el =
  Element
el{ elContent = elContent el ++ map Elem missingStyles }
 where
   existing :: [Text]
existing = [ [Text] -> Text
T.concat [ Attr -> Text
attrVal Attr
a
                         | Attr
a <- Element -> [Attr]
elAttribs Element
e
                         , QName -> Text
qName (Attr -> QName
attrKey Attr
a) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"name"
                         , QName -> Maybe Text
qPrefix (Attr -> QName
attrKey Attr
a) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"style" ]
              | Elem Element
e <- Element -> [Content]
elContent Element
el
              , QName -> Text
qName (Element -> QName
elName Element
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"style"
              , QName -> Maybe Text
qPrefix (Element -> QName
elName Element
e) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"style" ]
   missingStyles :: [Element]
missingStyles =
     [ Element
s | Element
s <- [Element]
listItemStyleElements
         , Element -> Text
styleNameOf Element
s Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
existing ]
   styleNameOf :: Element -> Text
styleNameOf Element
e = [Text] -> Text
T.concat [ Attr -> Text
attrVal Attr
a
                            | Attr
a <- Element -> [Attr]
elAttribs Element
e
                            , QName -> Text
qName (Attr -> QName
attrKey Attr
a) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"name"
                            , QName -> Maybe Text
qPrefix (Attr -> QName
attrKey Attr
a) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"style" ]

listItemStyleElements :: [Element]
listItemStyleElements :: [Element]
listItemStyleElements =
  [ Text -> Text -> Maybe Element -> Element
mkParaStyle Text
"List_20_Bullet" Text
"List Bullet" Maybe Element
forall a. Maybe a
Nothing
  , Text -> Text -> Maybe Element -> Element
mkParaStyle Text
"List_20_Bullet_20_Tight" Text
"List Bullet Tight" (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
tightProps)
  , Text -> Text -> Maybe Element -> Element
mkParaStyle Text
"List_20_Number" Text
"List Number" Maybe Element
forall a. Maybe a
Nothing
  , Text -> Text -> Maybe Element -> Element
mkParaStyle Text
"List_20_Number_20_Tight" Text
"List Number Tight" (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
tightProps)
  ]
 where
   styleQN :: Text -> Text -> QName
styleQN Text
n Text
p = Text -> Maybe Text -> Maybe Text -> QName
QName Text
n Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
p)
   mkAttr :: Text -> Text -> Text -> Attr
mkAttr Text
p Text
n Text
v = QName -> Text -> Attr
Attr (Text -> Text -> QName
styleQN Text
n Text
p) Text
v
   tightProps :: Element
tightProps =
     QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (Text -> Text -> QName
styleQN Text
"paragraph-properties" Text
"style")
       [ Text -> Text -> Text -> Attr
mkAttr Text
"fo" Text
"margin-top" Text
"0in"
       , Text -> Text -> Text -> Attr
mkAttr Text
"fo" Text
"margin-bottom" Text
"0in"
       , Text -> Text -> Text -> Attr
mkAttr Text
"style" Text
"contextual-spacing" Text
"false"
       ] [] Maybe Line
forall a. Maybe a
Nothing
   mkParaStyle :: Text -> Text -> Maybe Element -> Element
mkParaStyle Text
name Text
display Maybe Element
mbProps =
     QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (Text -> Text -> QName
styleQN Text
"style" Text
"style")
       [ Text -> Text -> Text -> Attr
mkAttr Text
"style" Text
"name" Text
name
       , Text -> Text -> Text -> Attr
mkAttr Text
"style" Text
"display-name" Text
display
       , Text -> Text -> Text -> Attr
mkAttr Text
"style" Text
"family" Text
"paragraph"
       , Text -> Text -> Text -> Attr
mkAttr Text
"style" Text
"parent-style-name" Text
"List"
       , Text -> Text -> Text -> Attr
mkAttr Text
"style" Text
"class" Text
"list"
       ]
       ([Content] -> (Element -> [Content]) -> Maybe Element -> [Content]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Element
p -> [Element -> Content
Elem Element
p]) Maybe Element
mbProps)
       Maybe Line
forall a. Maybe a
Nothing

-- top-down search
transformElement :: (QName -> Bool)
                 -> (Element -> Element)
                 -> Element
                 -> Element
transformElement :: (QName -> Bool) -> (Element -> Element) -> Element -> Element
transformElement QName -> Bool
g Element -> Element
f Element
el
  | QName -> Bool
g (Element -> QName
elName Element
el)
    = Element -> Element
f Element
el
  | Bool
otherwise
    = Element
el{ elContent = map go (elContent el) }
 where
   go :: Content -> Content
go (Elem Element
e) = Element -> Content
Elem ((QName -> Bool) -> (Element -> Element) -> Element -> Element
transformElement QName -> Bool
g Element -> Element
f Element
e)
   go Content
x = Content
x

-- TODO FIXME avoid this generic traversal!
addLang :: Lang -> Element -> Element
addLang :: Lang -> Element -> Element
addLang Lang
lang = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere' ((Attr -> Attr) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Attr -> Attr
updateLangAttr)
    where updateLangAttr :: Attr -> Attr
updateLangAttr (Attr n :: QName
n@(QName Text
"language" Maybe Text
_ (Just Text
"fo")) Text
_)
                           = QName -> Text -> Attr
Attr QName
n (Lang -> Text
langLanguage Lang
lang)
          updateLangAttr (Attr n :: QName
n@(QName Text
"country" Maybe Text
_ (Just Text
"fo")) Text
_)
                           = QName -> Text -> Attr
Attr QName
n (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Lang -> Maybe Text
langRegion Lang
lang)
          updateLangAttr Attr
x = Attr
x

-- | transform both Image and Math elements
-- | Width of the text area in points, from the reference document's
-- page layout (page width minus horizontal margins).  This mirrors how
-- the docx writer derives its print width from the reference docx
-- section properties.
referenceTextWidthPt :: WriterOptions -> Archive -> Maybe Double
referenceTextWidthPt :: WriterOptions -> Archive -> Maybe Double
referenceTextWidthPt WriterOptions
opts Archive
archive = do
  entry <- String -> Archive -> Maybe Entry
findEntryByPath String
"styles.xml" Archive
archive
  styles <- either (const Nothing) Just $
    parseXMLElement $ toTextLazy $ fromEntry entry
  layout <- listToMaybe $ filterElementsName
    ((== "page-layout-properties") . qName) styles
  let dim Text
attrName = do
        v <- (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
attrName) (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
layout
        d <- lengthToDim v
        Just $ 72 * inInch opts d
  pageWidth <- dim "page-width"
  let margin = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Maybe Double -> Double)
-> (Text -> Maybe Double) -> Text -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Double
dim
  Just $ pageWidth - margin "margin-left" - margin "margin-right"

transformPicMath :: PandocMonad m
                 => WriterOptions -> Maybe Double -> Inline -> O m Inline
transformPicMath :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe Double -> Inline -> O m Inline
transformPicMath WriterOptions
opts Maybe Double
mbTextWidthPt (Image attr :: Attr
attr@(Text
id', [Text]
cls, [(Text, Text)]
_) [Inline]
lab (Text
src,Text
t)) =
  StateT ODTState m Inline
-> (PandocError -> StateT ODTState m Inline)
-> StateT ODTState m Inline
forall a.
StateT ODTState m a
-> (PandocError -> StateT ODTState m a) -> StateT ODTState m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
   (do (img, mbMimeType) <- Text -> StateT ODTState m (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem Text
src
       (ptX, ptY) <- case imageSize opts img of
                       Right ImageSize
s  -> (Double, Double) -> StateT ODTState m (Double, Double)
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Double, Double) -> StateT ODTState m (Double, Double))
-> (Double, Double) -> StateT ODTState m (Double, Double)
forall a b. (a -> b) -> a -> b
$ ImageSize -> (Double, Double)
sizeInPoints ImageSize
s
                       Left Text
msg -> do
                         LogMessage -> StateT ODTState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT ODTState m ())
-> LogMessage -> StateT ODTState m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotDetermineImageSize Text
src Text
msg
                         (Double, Double) -> StateT ODTState m (Double, Double)
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
100, Double
100)
       let textWidthPt = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
420 Maybe Double
mbTextWidthPt
       let dims =
             case (Direction -> Maybe Dimension
getDim Direction
Width, Direction -> Maybe Dimension
getDim Direction
Height) of
               -- Percent dimensions are not valid ODF lengths.  When both
               -- dimensions are given and the width is relative, resolve
               -- it against the reference document's text width (as the
               -- docx writer does) and let the height follow the image's
               -- aspect ratio.
               (Just (Percent Double
wp), Just Dimension
_) ->
                 let wIn :: Double
wIn = Double
wp Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
textWidthPt Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
72
                 in [ (Text
"width", Dimension -> Text
forall a. Show a => a -> Text
tshow (Double -> Dimension
Inch Double
wIn))
                    , (Text
"height", Dimension -> Text
forall a. Show a => a -> Text
tshow (Double -> Dimension
Inch (Double
wIn Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ratio))) ]
               (Just w :: Dimension
w@(Inch Double
i), Just (Percent Double
_)) ->
                 [(Text
"width", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
w), (Text
"height", Dimension -> Text
forall a. Show a => a -> Text
tshow (Double -> Dimension
Inch (Double
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ratio)))]
               (Just Dimension
w, Just Dimension
h)              -> [(Text
"width", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
w), (Text
"height", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
h)]
               (Just w :: Dimension
w@(Percent Double
_), Maybe Dimension
Nothing) -> [(Text
"rel-width", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
w),(Text
"rel-height", Text
"scale"),(Text
"width", Double -> Text
forall a. Show a => a -> Text
tshow Double
ptX Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"pt"),(Text
"height", Double -> Text
forall a. Show a => a -> Text
tshow Double
ptY Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"pt")]
               (Maybe Dimension
Nothing, Just h :: Dimension
h@(Percent Double
_)) -> [(Text
"rel-width", Text
"scale"),(Text
"rel-height", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
h),(Text
"width", Double -> Text
forall a. Show a => a -> Text
tshow Double
ptX Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"pt"),(Text
"height", Double -> Text
forall a. Show a => a -> Text
tshow Double
ptY Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"pt")]
               (Just w :: Dimension
w@(Inch Double
i), Maybe Dimension
Nothing)    -> [(Text
"width", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
w), (Text
"height", Double -> Text
forall a. Show a => a -> Text
tshow (Double
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ratio) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"in")]
               (Maybe Dimension
Nothing, Just h :: Dimension
h@(Inch Double
i))    -> [(Text
"width", Double -> Text
forall a. Show a => a -> Text
tshow (Double
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ratio) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"in"), (Text
"height", Dimension -> Text
forall a. Show a => a -> Text
tshow Dimension
h)]
               (Maybe Dimension, Maybe Dimension)
_                             -> [(Text
"width", Double -> Text
forall a. Show a => a -> Text
tshow Double
ptX Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"pt"), (Text
"height", Double -> Text
forall a. Show a => a -> Text
tshow Double
ptY Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"pt")]
             where
               ratio :: Double
ratio = Double
ptX Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ptY
               getDim :: Direction -> Maybe Dimension
getDim Direction
dir = case Direction -> Attr -> Maybe Dimension
dimension Direction
dir Attr
attr of
                              Just (Percent Double
i) -> Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Percent Double
i
                              Just Dimension
dim         -> Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Inch (Double -> Dimension) -> Double -> Dimension
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Dimension -> Double
inInch WriterOptions
opts Dimension
dim
                              Maybe Dimension
Nothing          -> Maybe Dimension
forall a. Maybe a
Nothing
       let  newattr = (Text
id', [Text]
cls, [(Text, Text)]
dims)
       src' <- if writerLinkImages opts
                  then
                    case T.unpack src of
                      String
s | String -> Bool
isURI String
s -> Text -> StateT ODTState m Text
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
src
                        | String -> Bool
isAbsolute String
s -> Text -> StateT ODTState m Text
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
src
                        | Bool
otherwise -> do
                            -- see fixInternalLinks: relative references
                            -- are resolved against the zip structure
                            variant <- (ODTState -> ODTVariant) -> StateT ODTState m ODTVariant
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ODTState -> ODTVariant
stVariant
                            case variant of
                              ODTVariant
Zipped -> Text -> StateT ODTState m Text
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> StateT ODTState m Text) -> Text -> StateT ODTState m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
</> String
s
                              ODTVariant
Flat   -> Text -> StateT ODTState m Text
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> StateT ODTState m Text) -> Text -> StateT ODTState m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
                  else do
                    entries <- gets stEntries
                    let extension = String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ShowS
takeExtension ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'?') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
src) Text -> String
T.unpack
                                        (Maybe Text
mbMimeType Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text
extensionFromMimeType)
                    let newsrc = String
"Pictures/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Entry] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Entry]
entries) String -> ShowS
<.> String
extension
                    let toLazy = [ByteString] -> ByteString
B.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[])
                    epochtime <- floor `fmap` lift P.getPOSIXTime
                    let entry = String -> Line -> ByteString -> Entry
toEntry String
newsrc Line
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toLazy ByteString
img
                    modify $ \ODTState
st -> ODTState
st{ stEntries = entry : entries }
                    return $ T.pack newsrc
       return $ Image newattr lab (src', t))
   (\PandocError
e -> do
       LogMessage -> StateT ODTState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT ODTState m ())
-> LogMessage -> StateT ODTState m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
src (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (PandocError -> String
forall a. Show a => a -> String
show PandocError
e)
       Inline -> StateT ODTState m Inline
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> StateT ODTState m Inline)
-> Inline -> StateT ODTState m Inline
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
Emph [Inline]
lab)

transformPicMath WriterOptions
_ Maybe Double
_ (Math MathType
t Text
math) = do
  entries <- (ODTState -> [Entry]) -> StateT ODTState m [Entry]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ODTState -> [Entry]
stEntries
  let dt = if MathType
t MathType -> MathType -> Bool
forall a. Eq a => a -> a -> Bool
== MathType
InlineMath then DisplayType
DisplayInline else DisplayType
DisplayBlock
  case readTeX math of
       Left  Text
_ -> Inline -> StateT ODTState m Inline
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> StateT ODTState m Inline)
-> Inline -> StateT ODTState m Inline
forall a b. (a -> b) -> a -> b
$ MathType -> Text -> Inline
Math MathType
t Text
math
       Right [Exp]
exps -> do
         let conf :: ConfigPP
conf = (QName -> Bool) -> ConfigPP -> ConfigPP
XL.useShortEmptyTags (Bool -> QName -> Bool
forall a b. a -> b -> a
const Bool
False) ConfigPP
XL.defaultConfigPP
         let starMath :: Text
starMath =
               DisplayType -> [Exp] -> Text
writeStarMath DisplayType
dt [Exp]
exps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
starMathCommentFromTeX Text
math
         let mathmlElement :: Element
mathmlElement =
               Text -> Element -> Element
addStarMathAnnotation Text
starMath (DisplayType -> [Exp] -> Element
writeMathML DisplayType
dt [Exp]
exps)
         let mathml :: String
mathml = ConfigPP -> Element -> String
XL.ppcTopElement ConfigPP
conf Element
mathmlElement
         epochtime <- POSIXTime -> Line
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Line)
-> StateT ODTState m POSIXTime -> StateT ODTState m Line
forall a b. (a -> b) -> StateT ODTState m a -> StateT ODTState m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m POSIXTime -> StateT ODTState m POSIXTime
forall (m :: * -> *) a. Monad m => m a -> StateT ODTState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m POSIXTime
forall (m :: * -> *). PandocMonad m => m POSIXTime
P.getPOSIXTime
         let dirname = String
"Formula-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Entry] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Entry]
entries) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/"
         let fname = String
dirname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"content.xml"
         let entry = String -> Line -> ByteString -> Entry
toEntry String
fname Line
epochtime (String -> ByteString
fromStringLazy String
mathml)
         let fname' = String
dirname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"settings.xml"
         let entry' = String -> Line -> ByteString -> Entry
toEntry String
fname' Line
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString
documentSettings (MathType
t MathType -> MathType -> Bool
forall a. Eq a => a -> a -> Bool
== MathType
InlineMath)
         modify $ \ODTState
st -> ODTState
st{ stEntries = entry' : (entry : entries) }
         return $ RawInline (Format "opendocument") $ render Nothing $
           inTags False "draw:frame" (if t == DisplayMath
                                      then [("draw:style-name","fr2")
                                           -- `draw:frame` does not support either
                                           -- `style:vertical-pos` or `style:vertical-rel`,
                                           -- therefore those attributes must go into the
                                           -- `style:style` element
                                           ,("text:anchor-type","paragraph")]
                                      else [("draw:style-name","fr1")
                                           ,("text:anchor-type","as-char")]) $
             selfClosingTag "draw:object" [("xlink:href", T.pack dirname)
                                        , ("xlink:type", "simple")
                                        , ("xlink:show", "embed")
                                        , ("xlink:actuate", "onLoad")]

transformPicMath WriterOptions
_ Maybe Double
_ Inline
x = Inline -> StateT ODTState m Inline
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
x

starMathCommentFromTeX :: T.Text -> T.Text
starMathCommentFromTeX :: Text -> Text
starMathCommentFromTeX Text
tex =
  case Text -> [Text]
T.lines Text
normalized of
    []       -> Text
"%% TeX:"
    (Text
l : [Text]
ls) ->
      Text -> [Text] -> Text
T.intercalate Text
"\n" ((Text
"%% TeX: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"%% " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
ls)
 where
  normalized :: Text
normalized = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\r\n" Text
"\n" (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\r" Text
"\n" Text
tex)

addStarMathAnnotation :: T.Text -> XL.Element -> XL.Element
addStarMathAnnotation :: Text -> Element -> Element
addStarMathAnnotation Text
starMath Element
e =
  case Element -> [Content]
XL.elContent Element
e of
    [XL.Elem Element
sem] | QName -> String
XL.qName (Element -> QName
XL.elName Element
sem) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"semantics" ->
      Element
e { XL.elContent = [XL.Elem (withAnnotation sem)] }
    [Content]
_ ->
      Element
e { XL.elContent = [XL.Elem (mkSemantics (XL.elContent e))] }
 where
  mkSemantics :: [Content] -> Element
mkSemantics [Content]
cs =
    QName -> [Attr] -> [Content] -> Maybe Line -> Element
XL.Element (String -> QName
mkMathQName String
"semantics") [] ([Content]
cs [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Element -> Content
XL.Elem Element
annotation]) Maybe Line
forall a. Maybe a
Nothing

  withAnnotation :: Element -> Element
withAnnotation Element
sem =
    Element
sem { XL.elContent =
            filter (not . isStarMathAnnotation) (XL.elContent sem)
            ++ [XL.Elem annotation] }

  annotation :: Element
annotation =
    QName -> [Attr] -> [Content] -> Maybe Line -> Element
XL.Element (String -> QName
mkMathQName String
"annotation")
      [QName -> String -> Attr
XL.Attr (String -> Maybe String -> Maybe String -> QName
XL.QName String
"encoding" Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing) String
"StarMath 5.0"]
      [CData -> Content
XL.Text (CDataKind -> String -> Maybe Line -> CData
XL.CData CDataKind
XL.CDataText (Text -> String
T.unpack Text
starMath) Maybe Line
forall a. Maybe a
Nothing)]
      Maybe Line
forall a. Maybe a
Nothing

  isStarMathAnnotation :: Content -> Bool
isStarMathAnnotation (XL.Elem Element
el) =
    QName -> String
XL.qName (Element -> QName
XL.elName Element
el) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"annotation" Bool -> Bool -> Bool
&&
    (Attr -> Bool) -> [Attr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Attr
a -> QName -> String
XL.qName (Attr -> QName
XL.attrKey Attr
a) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"encoding"
               Bool -> Bool -> Bool
&& Attr -> String
XL.attrVal Attr
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"StarMath 5.0")
        (Element -> [Attr]
XL.elAttribs Element
el)
  isStarMathAnnotation Content
_ = Bool
False

  mkMathQName :: String -> QName
mkMathQName String
n =
    String -> Maybe String -> Maybe String -> QName
XL.QName String
n (QName -> Maybe String
XL.qURI (QName -> Maybe String) -> QName -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element -> QName
XL.elName Element
e) (QName -> Maybe String
XL.qPrefix (QName -> Maybe String) -> QName -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element -> QName
XL.elName Element
e)

documentSettings :: Bool -> B.ByteString
documentSettings :: Bool -> ByteString
documentSettings Bool
isTextMode = String -> ByteString
fromStringLazy (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Doc String -> String
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing
    (Doc String -> String) -> Doc String -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc String
forall a. HasChars a => String -> Doc a
text String
"<?xml version=\"1.0\" encoding=\"utf-8\"?>"
    Doc String -> Doc String -> Doc String
forall a. Doc a -> Doc a -> Doc a
$$
    Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"office:document-settings"
      [(Text
"xmlns:office",Text
"urn:oasis:names:tc:opendocument:xmlns:office:1.0")
      ,(Text
"xmlns:xlink",Text
"http://www.w3.org/1999/xlink")
      ,(Text
"xmlns:config",Text
"urn:oasis:names:tc:opendocument:xmlns:config:1.0")
      ,(Text
"xmlns:ooo",Text
"http://openoffice.org/2004/office")
      ,(Text
"office:version",Text
"1.3")] (
       Text -> Doc String -> Doc String
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"office:settings" (Doc String -> Doc String) -> Doc String -> Doc String
forall a b. (a -> b) -> a -> b
$
         Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"config:config-item-set"
           [(Text
"config:name", Text
"ooo:configuration-settings")] (Doc String -> Doc String) -> Doc String -> Doc String
forall a b. (a -> b) -> a -> b
$
           Bool -> Text -> [(Text, Text)] -> Doc String -> Doc String
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"config:config-item" [(Text
"config:name", Text
"IsTextMode")
                                             ,(Text
"config:type", Text
"boolean")] (Doc String -> Doc String) -> Doc String -> Doc String
forall a b. (a -> b) -> a -> b
$
                                              String -> Doc String
forall a. HasChars a => String -> Doc a
text (String -> Doc String) -> String -> Doc String
forall a b. (a -> b) -> a -> b
$ if Bool
isTextMode then String
"true" else String
"false")

styleToOpenDocument :: Style -> [Content]
styleToOpenDocument :: Style -> [Content]
styleToOpenDocument Style
style = (TokenType -> Content) -> [TokenType] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map (Element -> Content
Elem (Element -> Content)
-> (TokenType -> Element) -> TokenType -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenType -> Element
toStyle) [TokenType]
alltoktypes
  where alltoktypes :: [TokenType]
alltoktypes = TokenType -> TokenType -> [TokenType]
forall a. Enum a => a -> a -> [a]
enumFromTo TokenType
KeywordTok TokenType
NormalTok
        styleName :: Text -> QName
styleName Text
x =
          case (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
x of
            (Text
b, Text
a) | Text -> Bool
T.null Text
a  -> Text -> Maybe Text -> Maybe Text -> QName
QName Text
x Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"style")
                   | Bool
otherwise -> Text -> Maybe Text -> Maybe Text -> QName
QName (Int -> Text -> Text
T.drop Int
1 Text
a) Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
b)
        styleAttr :: (Text, Text) -> Attr
styleAttr (Text
x, Text
y) = QName -> Text -> Attr
Attr (Text -> QName
styleName Text
x) Text
y
        styleAttrs :: [(Text, Text)] -> [Attr]
styleAttrs = ((Text, Text) -> Attr) -> [(Text, Text)] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Attr
styleAttr
        styleElement :: Text -> [(Text, Text)] -> [Content] -> Element
styleElement Text
x [(Text, Text)]
attrs [Content]
cs =
          QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (Text -> QName
styleName Text
x) ([(Text, Text)] -> [Attr]
styleAttrs [(Text, Text)]
attrs) [Content]
cs Maybe Line
forall a. Maybe a
Nothing
        toStyle :: TokenType -> Element
toStyle TokenType
toktype =
          Text -> [(Text, Text)] -> [Content] -> Element
styleElement Text
"style"
            [(Text
"name", TokenType -> Text
forall a. Show a => a -> Text
tshow TokenType
toktype), (Text
"family", Text
"text")]
            [Element -> Content
Elem (Text -> [(Text, Text)] -> [Content] -> Element
styleElement Text
"text-properties"
                      (TokenType -> [(Text, Text)]
forall {a}. IsString a => TokenType -> [(a, Text)]
tokColor TokenType
toktype [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ TokenType -> [(Text, Text)]
forall {a}. IsString a => TokenType -> [(a, Text)]
tokBgColor TokenType
toktype [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                        [(Text
"fo:font-style", Text
"italic") |
                           (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenItalic TokenType
toktype ] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                        [(Text
"fo:font-weight", Text
"bold") |
                           (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenBold TokenType
toktype ] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                        [(Text
"style:text-underline-style", Text
"solid") |
                           (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenUnderline TokenType
toktype ])
                        [])]
        tokStyles :: Map TokenType TokenStyle
tokStyles = Style -> Map TokenType TokenStyle
tokenStyles Style
style
        tokFeature :: (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
f TokenType
toktype = Bool -> (TokenStyle -> Bool) -> Maybe TokenStyle -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TokenStyle -> Bool
f (Maybe TokenStyle -> Bool) -> Maybe TokenStyle -> Bool
forall a b. (a -> b) -> a -> b
$ TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles
        tokColor :: TokenType -> [(a, Text)]
tokColor TokenType
toktype =
          [(a, Text)] -> (Color -> [(a, Text)]) -> Maybe Color -> [(a, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Color
c -> [(a
"fo:color", String -> Text
T.pack (Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c))])
                        ((TokenStyle -> Maybe Color
tokenColor (TokenStyle -> Maybe Color) -> Maybe TokenStyle -> Maybe Color
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
                           Maybe Color -> Maybe Color -> Maybe Color
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
defaultColor Style
style)
        tokBgColor :: TokenType -> [(a, Text)]
tokBgColor TokenType
toktype =
          [(a, Text)] -> (Color -> [(a, Text)]) -> Maybe Color -> [(a, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Color
c -> [(a
"fo:background-color", String -> Text
T.pack (Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c))])
                    (TokenStyle -> Maybe Color
tokenBackground (TokenStyle -> Maybe Color) -> Maybe TokenStyle -> Maybe Color
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)