{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Writers.ODT ( writeODT ) 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 qualified Data.ByteString.Lazy as B
import Data.Maybe (fromMaybe)
import Data.Generics (everywhere', mkT)
import Data.List (isPrefixOf)
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, (<.>))
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 (..))
import Text.DocLayout
import Text.Pandoc.Shared (stringify, tshow)
import Text.Pandoc.Version (pandocVersionText)
import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks,
fixDisplayMath, getLang,
ensureValidXmlIdentifiers)
import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toTextLazy)
import Text.Pandoc.Walk
import Text.Pandoc.Writers.OpenDocument (writeOpenDocument)
import Text.Pandoc.XML
import Text.Pandoc.XML.Light
import Text.TeXMath
import qualified Text.XML.Light as XL
import Network.URI (parseRelativeReference, URI(uriPath))
import Skylighting
newtype ODTState = ODTState { ODTState -> [Entry]
stEntries :: [Entry]
}
type O m = StateT ODTState m
writeODT :: PandocMonad m
=> WriterOptions
-> Pandoc
-> 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 = []
}
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
StateT ODTState m ByteString -> ODTState -> m ByteString
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterOptions -> Pandoc -> StateT ODTState m ByteString
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> O m ByteString
pandocToODT WriterOptions
opts Pandoc
doc') ODTState
initState
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
pandocToODT :: PandocMonad m
=> WriterOptions
-> Pandoc
-> O m B.ByteString
pandocToODT :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> O m ByteString
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
utctime <- StateT ODTState m UTCTime
forall (m :: * -> *). PandocMonad m => m UTCTime
P.getTimestamp
Maybe Lang
lang <- Maybe Text -> StateT ODTState m (Maybe Lang)
forall (m :: * -> *). PandocMonad m => Maybe Text -> m (Maybe Lang)
toLang (WriterOptions -> Meta -> Maybe Text
getLang WriterOptions
opts Meta
meta)
Archive
refArchive <-
case WriterOptions -> Maybe String
writerReferenceDoc WriterOptions
opts of
Just String
f -> m Archive -> StateT ODTState m 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 Archive -> StateT ODTState m Archive)
-> m Archive -> StateT ODTState m Archive
forall a b. (a -> b) -> a -> b
$ ByteString -> Archive
toArchive (ByteString -> Archive)
-> ((ByteString, Maybe Text) -> ByteString)
-> (ByteString, Maybe Text)
-> 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) -> Archive)
-> m (ByteString, Maybe Text) -> m 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))
Maybe String
Nothing -> m Archive -> StateT ODTState m 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 Archive -> StateT ODTState m Archive)
-> m Archive -> StateT ODTState m Archive
forall a b. (a -> b) -> a -> b
$ ByteString -> Archive
toArchive (ByteString -> Archive)
-> (ByteString -> ByteString) -> ByteString -> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.fromStrict (ByteString -> Archive) -> m ByteString -> m 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"
Pandoc
doc' <- (Inline -> StateT ODTState m Inline)
-> Pandoc -> StateT ODTState m Pandoc
forall a b (m :: * -> *).
(Walkable a b, Monad m, Applicative m, Functor m) =>
(a -> m a) -> b -> m b
forall (m :: * -> *).
(Monad m, Applicative m, Functor m) =>
(Inline -> m Inline) -> Pandoc -> m Pandoc
walkM (WriterOptions -> Inline -> StateT ODTState m Inline
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> O m Inline
transformPicMath WriterOptions
opts) (Pandoc -> StateT ODTState m Pandoc)
-> Pandoc -> StateT ODTState m Pandoc
forall a b. (a -> b) -> a -> b
$ (Block -> Block) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
fixDisplayMath Pandoc
doc
Text
newContents <- m Text -> StateT ODTState m Text
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 Text -> StateT ODTState m Text)
-> m Text -> StateT ODTState m Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeOpenDocument WriterOptions
opts{writerWrapText = WrapNone} Pandoc
doc'
Integer
epochtime <- POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer)
-> StateT ODTState m POSIXTime -> StateT ODTState m Integer
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 contentEntry :: Entry
contentEntry = String -> Integer -> ByteString -> Entry
toEntry String
"content.xml" Integer
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
[Entry]
picEntries <- (ODTState -> [Entry]) -> StateT ODTState m [Entry]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ODTState -> [Entry]
stEntries
let archive :: Archive
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
let toFileEntry :: String -> Doc a
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]
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 :: [String]
formulas = [ String -> String
takeDirectory String
ent String -> String -> String
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, String -> String
takeExtension String
ent String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".xml" ]
let manifestEntry :: Entry
manifestEntry = String -> Integer -> ByteString -> Entry
toEntry String
"META-INF/manifest.xml" Integer
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' :: Archive
archive' = Entry -> Archive -> Archive
addEntryToArchive Entry
manifestEntry Archive
archive
let userDefinedMetaFields :: [Text]
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 :: Text -> Doc String
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 :: [Text]
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 :: [Doc String]
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 -> Text -> Doc String
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 :: Entry
metaEntry = String -> Integer -> ByteString -> Entry
toEntry String
"meta.xml" Integer
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 a. Walkable Inline a => a -> Text
stringify [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 a. Walkable Inline a => a -> Text
stringify [[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
)
)
let mimetypeEntry :: Entry
mimetypeEntry = String -> Integer -> ByteString -> Entry
toEntry String
"mimetype" Integer
epochtime
(ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ String -> ByteString
fromStringLazy String
"application/vnd.oasis.opendocument.text"
Archive
archive'' <- WriterOptions -> Maybe Lang -> Archive -> StateT ODTState m Archive
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe Lang -> Archive -> O m Archive
updateStyle WriterOptions
opts Maybe Lang
lang
(Archive -> StateT ODTState m Archive)
-> Archive -> StateT ODTState m Archive
forall a b. (a -> b) -> a -> b
$ Entry -> Archive -> Archive
addEntryToArchive Entry
mimetypeEntry
(Archive -> Archive) -> Archive -> Archive
forall a b. (a -> b) -> a -> b
$ Entry -> Archive -> Archive
addEntryToArchive Entry
metaEntry Archive
archive'
ByteString -> O m ByteString
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> O m ByteString) -> ByteString -> O m ByteString
forall a b. (a -> b) -> a -> b
$ Archive -> ByteString
fromArchive Archive
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
Integer
epochtime <- POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer)
-> StateT ODTState m POSIXTime -> StateT ODTState m Integer
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 -> 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 -> Integer -> ByteString -> Entry
toEntry String
"styles.xml" Integer
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)
-> (Style -> Element -> Element)
-> Maybe Style
-> Element
-> Element
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Element -> Element
forall a. a -> a
id Style -> Element -> Element
addHlStyles (WriterOptions -> Maybe Style
writerHighlightStyle WriterOptions
opts))
(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
[Entry]
entries <- (Entry -> O m Entry) -> [Entry] -> StateT ODTState m [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Entry -> O m Entry
goEntry (Archive -> [Entry]
zEntries Archive
arch)
Archive -> O m Archive
forall a. a -> StateT ODTState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Archive
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
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
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
transformPicMath :: PandocMonad m => WriterOptions ->Inline -> O m Inline
transformPicMath :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> O m Inline
transformPicMath WriterOptions
opts (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 (ByteString
img, Maybe Text
mbMimeType) <- Text -> StateT ODTState m (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem Text
src
(Double
ptX, Double
ptY) <- case WriterOptions -> ByteString -> Either Text ImageSize
imageSize WriterOptions
opts ByteString
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 dims :: [(Text, Text)]
dims =
case (Direction -> Maybe Dimension
getDim Direction
Width, Direction -> Maybe Dimension
getDim Direction
Height) of
(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 :: Attr
newattr = (Text
id', [Text]
cls, [(Text, Text)]
dims)
[Entry]
entries <- (ODTState -> [Entry]) -> StateT ODTState m [Entry]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ODTState -> [Entry]
stEntries
let extension :: String
extension = String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String
takeExtension (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'?') (String -> String) -> String -> String
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
newsrc = String
"Pictures/" String -> String -> String
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 -> String -> String
<.> String
extension
let toLazy :: ByteString -> ByteString
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]
:[])
Integer
epochtime <- POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer)
-> StateT ODTState m POSIXTime -> StateT ODTState m Integer
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 entry :: Entry
entry = String -> Integer -> ByteString -> Entry
toEntry String
newsrc Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toLazy ByteString
img
(ODTState -> ODTState) -> StateT ODTState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ODTState -> ODTState) -> StateT ODTState m ())
-> (ODTState -> ODTState) -> StateT ODTState m ()
forall a b. (a -> b) -> a -> b
$ \ODTState
st -> ODTState
st{ stEntries = entry : entries }
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
$ Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
newattr [Inline]
lab (String -> Text
T.pack String
newsrc, Text
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
_ (Math MathType
t Text
math) = do
[Entry]
entries <- (ODTState -> [Entry]) -> StateT ODTState m [Entry]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ODTState -> [Entry]
stEntries
let dt :: DisplayType
dt = if MathType
t MathType -> MathType -> Bool
forall a. Eq a => a -> a -> Bool
== MathType
InlineMath then DisplayType
DisplayInline else DisplayType
DisplayBlock
case DisplayType -> [Exp] -> Element
writeMathML DisplayType
dt ([Exp] -> Element) -> Either Text [Exp] -> Either Text Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text [Exp]
readTeX Text
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 Element
r -> 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 mathml :: String
mathml = ConfigPP -> Element -> String
XL.ppcTopElement ConfigPP
conf Element
r
Integer
epochtime <- POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer)
-> StateT ODTState m POSIXTime -> StateT ODTState m Integer
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
dirname = String
"Formula-" String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
let fname :: String
fname = String
dirname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"content.xml"
let entry :: Entry
entry = String -> Integer -> ByteString -> Entry
toEntry String
fname Integer
epochtime (String -> ByteString
fromStringLazy String
mathml)
let fname' :: String
fname' = String
dirname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"settings.xml"
let entry' :: Entry
entry' = String -> Integer -> ByteString -> Entry
toEntry String
fname' Integer
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)
(ODTState -> ODTState) -> StateT ODTState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ODTState -> ODTState) -> StateT ODTState m ())
-> (ODTState -> ODTState) -> StateT ODTState m ()
forall a b. (a -> b) -> a -> b
$ \ODTState
st -> ODTState
st{ stEntries = entry' : (entry : entries) }
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
$ Format -> Text -> Inline
RawInline (Text -> Format
Format Text
"opendocument") (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing (Doc Text -> Text) -> Doc Text -> Text
forall a b. (a -> b) -> a -> b
$
Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"draw:frame" (if MathType
t MathType -> MathType -> Bool
forall a. Eq a => a -> a -> Bool
== MathType
DisplayMath
then [(Text
"draw:style-name",Text
"fr2")
,(Text
"text:anchor-type",Text
"paragraph")]
else [(Text
"draw:style-name",Text
"fr1")
,(Text
"text:anchor-type",Text
"as-char")]) (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"draw:object" [(Text
"xlink:href", String -> Text
T.pack String
dirname)
, (Text
"xlink:type", Text
"simple")
, (Text
"xlink:show", Text
"embed")
, (Text
"xlink:actuate", Text
"onLoad")]
transformPicMath WriterOptions
_ 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
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 Integer -> Element
Element (Text -> QName
styleName Text
x) ([(Text, Text)] -> [Attr]
styleAttrs [(Text, Text)]
attrs) [Content]
cs Maybe Integer
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)