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.
This commit is contained in:
John MacFarlane
parent
a02f08c9fc
commit
083a224d1e
3 changed files with 72 additions and 18 deletions
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue