From 083a224d1e3d791c459a998d18aa9975b8816c15 Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Sun, 25 Jun 2017 10:38:11 +0200 Subject: Support `lang` attribute in OpenDocument and ODT writers. This adds the required attributes to the temporary styles, and also replaces existing language attributes in styles.xml. Support for lang attributes on Div and Span has also been added. Closes #1667. --- src/Text/Pandoc/Writers/Docx.hs | 7 ++--- src/Text/Pandoc/Writers/ODT.hs | 48 ++++++++++++++++++++++++++++----- src/Text/Pandoc/Writers/OpenDocument.hs | 35 +++++++++++++++++++----- 3 files changed, 72 insertions(+), 18 deletions(-) (limited to 'src/Text') diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index b488f2479..d93b99486 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -67,7 +67,7 @@ import Text.Pandoc.Shared hiding (Element) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Walk import Text.Pandoc.Writers.Math -import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.Shared (fixDisplayMath, getLang) import Text.Printf (printf) import Text.TeXMath import Text.XML.Light as XML @@ -257,10 +257,7 @@ writeDocx opts doc@(Pandoc meta _) = do ) -- styles - let lang = case lookupMeta "lang" meta of - Just (MetaInlines [Str s]) -> Just s - Just (MetaString s) -> Just s - _ -> Nothing + let lang = getLang opts meta let addLang :: Element -> Element addLang e = case lang >>= \l -> (return . XMLC.toTree . go l . XMLC.fromElement) e of Just (Elem e') -> e' diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index c9a7de642..dff4f8fcf 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -33,6 +33,7 @@ import Codec.Archive.Zip import Control.Monad.Except (catchError) import Control.Monad.State.Strict import qualified Data.ByteString.Lazy as B +import Data.Generics (everywhere', mkT) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as TL @@ -46,13 +47,13 @@ import Text.Pandoc.MIME (extensionFromMimeType, getMimeType) import Text.Pandoc.Options (WrapOption (..), WriterOptions (..)) import Text.Pandoc.Pretty import Text.Pandoc.Shared (stringify) -import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy) +import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toStringLazy) import Text.Pandoc.Walk import Text.Pandoc.Writers.OpenDocument (writeOpenDocument) -import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.Shared (fixDisplayMath, getLang, splitLang) import Text.Pandoc.XML import Text.TeXMath -import Text.XML.Light.Output +import Text.XML.Light data ODTState = ODTState { stEntries :: [Entry] } @@ -78,6 +79,7 @@ pandocToODT :: PandocMonad m pandocToODT opts doc@(Pandoc meta _) = do let datadir = writerUserDataDir opts let title = docTitle meta + let lang = getLang opts meta refArchive <- case writerReferenceDoc opts of Just f -> liftM toArchive $ lift $ P.readFileLazy f @@ -132,18 +134,50 @@ pandocToODT opts doc@(Pandoc meta _) = do ,("xmlns:ooo","http://openoffice.org/2004/office") ,("xmlns:grddl","http://www.w3.org/2003/g/data-view#") ,("office:version","1.2")] - $ ( inTagsSimple "office:meta" - $ ( inTagsSimple "dc:title" (text $ escapeStringForXML (stringify title)) - ) + $ ( inTagsSimple "office:meta" $ + ( inTagsSimple "dc:title" + (text $ escapeStringForXML (stringify title)) + $$ + case lang of + Just l -> inTagsSimple "dc:language" + (text (escapeStringForXML l)) + Nothing -> empty + ) ) ) -- make sure mimetype is first let mimetypeEntry = toEntry "mimetype" epochtime $ fromStringLazy "application/vnd.oasis.opendocument.text" - let archive'' = addEntryToArchive mimetypeEntry + archive'' <- updateStyleWithLang lang + $ addEntryToArchive mimetypeEntry $ addEntryToArchive metaEntry archive' return $ fromArchive archive'' +updateStyleWithLang :: PandocMonad m => Maybe String -> Archive -> O m Archive +updateStyleWithLang Nothing arch = return arch +updateStyleWithLang (Just l) arch = do + (mblang, mbcountry) <- splitLang l + epochtime <- floor `fmap` (lift P.getPOSIXTime) + return arch{ zEntries = [if eRelativePath e == "styles.xml" + then case parseXMLDoc + (toStringLazy (fromEntry e)) of + Nothing -> e + Just d -> + toEntry "styles.xml" epochtime + ( fromStringLazy + . ppTopElement + . addLang mblang mbcountry $ d ) + else e + | e <- zEntries arch] } + +addLang :: Maybe String -> Maybe String -> Element -> Element +addLang mblang mbcountry = everywhere' (mkT updateLangAttr) + where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) l) + = Attr n (maybe l id mblang) + updateLangAttr (Attr n@(QName "country" _ (Just "fo")) c) + = Attr n (maybe c id mbcountry) + updateLangAttr x = x + -- | transform both Image and Math elements transformPicMath :: PandocMonad m => WriterOptions ->Inline -> O m Inline transformPicMath opts (Image attr@(id', cls, _) lab (src,t)) = catchError diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index 95a800c94..a4c9e0ef2 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -45,7 +45,7 @@ import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Pretty -import Text.Pandoc.Shared (linesToPara) +import Text.Pandoc.Shared (linesToPara, splitBy) import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared @@ -75,6 +75,8 @@ data WriterState = , stTight :: Bool , stFirstPara :: Bool , stImageId :: Int + , stLang :: Maybe String + , stCountry :: Maybe String } defaultWriterState :: WriterState @@ -90,6 +92,8 @@ defaultWriterState = , stTight = False , stFirstPara = False , stImageId = 1 + , stLang = Nothing + , stCountry = Nothing } when :: Bool -> Doc -> Doc @@ -155,6 +159,10 @@ withTextStyle s f = do inTextStyle :: PandocMonad m => Doc -> OD m Doc inTextStyle d = do at <- gets stTextStyleAttr + mblang <- gets stLang + mbcountry <- gets stCountry + let langat = maybe [] (\la -> [("fo:language", la)]) mblang + let countryat = maybe [] (\co -> [("fo:country", co)]) mbcountry if Set.null at then return d else do @@ -168,8 +176,9 @@ inTextStyle d = do inTags False "style:style" [("style:name", styleName) ,("style:family", "text")] - $ selfClosingTag "style:text-properties" - (concatMap textStyleAttr (Set.toList at))) + $ selfClosingTag "style:text-properties" + (langat ++ countryat ++ + concatMap textStyleAttr (Set.toList at))) return $ inTags False "text:span" [("text:style-name",styleName)] d @@ -203,8 +212,10 @@ writeOpenDocument opts (Pandoc meta blocks) = do else Nothing let render' :: Doc -> Text render' = render colwidth + let lang = getLang opts meta + (mblang, mbcountry) <- maybe (return (Nothing, Nothing)) splitLang lang ((body, metadata),s) <- flip runStateT - defaultWriterState $ do + defaultWriterState{ stLang = mblang, stCountry = mbcountry } $ do m <- metaToJSON opts (fmap render' . blocksToOpenDocument opts) (fmap render' . inlinesToOpenDocument opts) @@ -326,7 +337,8 @@ blockToOpenDocument o bs then return empty else inParagraphTags =<< inlinesToOpenDocument o b | LineBlock b <- bs = blockToOpenDocument o $ linesToPara b - | Div _ xs <- bs = blocksToOpenDocument o xs + | Div attr xs <- bs = withLangFromAttr attr + (blocksToOpenDocument o xs) | Header i _ b <- bs = setFirstPara >> (inHeaderTags i =<< inlinesToOpenDocument o b) | BlockQuote b <- bs = setFirstPara >> mkBlockQuote b @@ -444,7 +456,7 @@ inlineToOpenDocument o ils | writerWrapText o == WrapPreserve -> return $ preformatted "\n" | otherwise -> return $ space - Span _ xs -> inlinesToOpenDocument o xs + Span attr xs -> withLangFromAttr attr (inlinesToOpenDocument o xs) LineBreak -> return $ selfClosingTag "text:line-break" [] Str s -> return $ handleSpaces $ escapeStringForXML s Emph l -> withTextStyle Italic $ inlinesToOpenDocument o l @@ -625,3 +637,14 @@ textStyleAttr s ,("style:font-name-asian" ,"Courier New") ,("style:font-name-complex" ,"Courier New")] | otherwise = [] + +withLangFromAttr :: PandocMonad m => Attr -> OD m a -> OD m a +withLangFromAttr (_,_,kvs) action = do + oldlang <- gets stLang + case lookup "lang" kvs of + Nothing -> action + Just l -> do + modify (\st -> st{ stLang = Just l}) + result <- action + modify (\st -> st{ stLang = oldlang}) + return result -- cgit v1.2.3