module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where
import Control.Arrow ((***), (>>>))
import Control.Monad.State.Strict hiding (when)
import Data.Char (chr)
import Data.List (sortBy)
import qualified Data.Map as Map
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Text (Text)
import Text.Pandoc.BCP47 (Lang (..), parseBCP47)
import Text.Pandoc.Class (PandocMonad, report)
import Text.Pandoc.Definition
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Pretty
import Text.Pandoc.Shared (linesToPara)
import Text.Pandoc.Templates (renderTemplate')
import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared
import Text.Pandoc.XML
import Text.Printf (printf)
plainToPara :: Block -> Block
plainToPara (Plain x) = Para x
plainToPara x = x
type OD m = StateT WriterState m
data WriterState =
WriterState { stNotes :: [Doc]
, stTableStyles :: [Doc]
, stParaStyles :: [Doc]
, stListStyles :: [(Int, [Doc])]
, stTextStyles :: Map.Map (Set.Set TextStyle) (String, Doc)
, stTextStyleAttr :: Set.Set TextStyle
, stIndentPara :: Int
, stInDefinition :: Bool
, stTight :: Bool
, stFirstPara :: Bool
, stImageId :: Int
}
defaultWriterState :: WriterState
defaultWriterState =
WriterState { stNotes = []
, stTableStyles = []
, stParaStyles = []
, stListStyles = []
, stTextStyles = Map.empty
, stTextStyleAttr = Set.empty
, stIndentPara = 0
, stInDefinition = False
, stTight = False
, stFirstPara = False
, stImageId = 1
}
when :: Bool -> Doc -> Doc
when p a = if p then a else empty
addTableStyle :: PandocMonad m => Doc -> OD m ()
addTableStyle i = modify $ \s -> s { stTableStyles = i : stTableStyles s }
addNote :: PandocMonad m => Doc -> OD m ()
addNote i = modify $ \s -> s { stNotes = i : stNotes s }
addParaStyle :: PandocMonad m => Doc -> OD m ()
addParaStyle i = modify $ \s -> s { stParaStyles = i : stParaStyles s }
addTextStyle :: PandocMonad m => Set.Set TextStyle -> (String, Doc) -> OD m ()
addTextStyle attrs i = modify $ \s ->
s { stTextStyles = Map.insert attrs i (stTextStyles s) }
addTextStyleAttr :: PandocMonad m => TextStyle -> OD m ()
addTextStyleAttr t = modify $ \s ->
s { stTextStyleAttr = Set.insert t (stTextStyleAttr s) }
increaseIndent :: PandocMonad m => OD m ()
increaseIndent = modify $ \s -> s { stIndentPara = 1 + stIndentPara s }
resetIndent :: PandocMonad m => OD m ()
resetIndent = modify $ \s -> s { stIndentPara = stIndentPara s 1 }
inTightList :: PandocMonad m => OD m a -> OD m a
inTightList f = modify (\s -> s { stTight = True }) >> f >>= \r ->
modify (\s -> s { stTight = False }) >> return r
setInDefinitionList :: PandocMonad m => Bool -> OD m ()
setInDefinitionList b = modify $ \s -> s { stInDefinition = b }
setFirstPara :: PandocMonad m => OD m ()
setFirstPara = modify $ \s -> s { stFirstPara = True }
inParagraphTags :: PandocMonad m => Doc -> OD m Doc
inParagraphTags d = do
b <- gets stFirstPara
a <- if b
then do modify $ \st -> st { stFirstPara = False }
return [("text:style-name", "First_20_paragraph")]
else return [("text:style-name", "Text_20_body")]
return $ inTags False "text:p" a d
inParagraphTagsWithStyle :: String -> Doc -> Doc
inParagraphTagsWithStyle sty = inTags False "text:p" [("text:style-name", sty)]
inSpanTags :: String -> Doc -> Doc
inSpanTags s = inTags False "text:span" [("text:style-name",s)]
withTextStyle :: PandocMonad m => TextStyle -> OD m a -> OD m a
withTextStyle s f = do
oldTextStyleAttr <- gets stTextStyleAttr
addTextStyleAttr s
res <- f
modify $ \st -> st{ stTextStyleAttr = oldTextStyleAttr }
return res
inTextStyle :: PandocMonad m => Doc -> OD m Doc
inTextStyle d = do
at <- gets stTextStyleAttr
if Set.null at
then return d
else do
styles <- gets stTextStyles
case Map.lookup at styles of
Just (styleName, _) -> return $
inTags False "text:span" [("text:style-name",styleName)] d
Nothing -> do
let styleName = "T" ++ show (Map.size styles + 1)
addTextStyle at (styleName,
inTags False "style:style"
[("style:name", styleName)
,("style:family", "text")]
$ selfClosingTag "style:text-properties"
(concatMap textStyleAttr (Set.toList at)))
return $ inTags False
"text:span" [("text:style-name",styleName)] d
formulaStyles :: [Doc]
formulaStyles = [formulaStyle InlineMath, formulaStyle DisplayMath]
formulaStyle :: MathType -> Doc
formulaStyle mt = inTags False "style:style"
[("style:name", if mt == InlineMath then "fr1" else "fr2")
,("style:family", "graphic")
,("style:parent-style-name", "Formula")]
$ selfClosingTag "style:graphic-properties" $ if mt == InlineMath then
[("style:vertical-pos", "middle")
,("style:vertical-rel", "text")]
else
[("style:vertical-pos", "middle")
,("style:vertical-rel", "paragraph-content")
,("style:horizontal-pos", "center")
,("style:horizontal-rel", "paragraph-content")
,("style:wrap", "none")]
inHeaderTags :: PandocMonad m => Int -> Doc -> OD m Doc
inHeaderTags i d =
return $ inTags False "text:h" [ ("text:style-name", "Heading_20_" ++ show i)
, ("text:outline-level", show i)] d
inQuotes :: QuoteType -> Doc -> Doc
inQuotes SingleQuote s = char '\8216' <> s <> char '\8217'
inQuotes DoubleQuote s = char '\8220' <> s <> char '\8221'
handleSpaces :: String -> Doc
handleSpaces s
| ( ' ':_) <- s = genTag s
| ('\t':x) <- s = selfClosingTag "text:tab" [] <> rm x
| otherwise = rm s
where
genTag = span (==' ') >>> tag . length *** rm >>> uncurry (<>)
tag n = when (n /= 0) $ selfClosingTag "text:s" [("text:c", show n)]
rm ( ' ':xs) = char ' ' <> genTag xs
rm ('\t':xs) = selfClosingTag "text:tab" [] <> genTag xs
rm ( x:xs) = char x <> rm xs
rm [] = empty
writeOpenDocument :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeOpenDocument opts (Pandoc meta blocks) = do
let colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
let render' :: Doc -> Text
render' = render colwidth
((body, metadata),s) <- flip runStateT
defaultWriterState $ do
m <- metaToJSON opts
(fmap render' . blocksToOpenDocument opts)
(fmap render' . inlinesToOpenDocument opts)
meta
b <- render' `fmap` blocksToOpenDocument opts blocks
return (b, m)
let styles = stTableStyles s ++ stParaStyles s ++ formulaStyles ++
map snd (sortBy (flip (comparing fst)) (
Map.elems (stTextStyles s)))
listStyle (n,l) = inTags True "text:list-style"
[("style:name", "L" ++ show n)] (vcat l)
let listStyles = map listStyle (stListStyles s)
let automaticStyles = vcat $ reverse $ styles ++ listStyles
let context = defField "body" body
$ defField "toc" (writerTableOfContents opts)
$defField "automatic-styles" (render' automaticStyles) metadata
case writerTemplate opts of
Nothing -> return body
Just tpl -> renderTemplate' tpl context
withParagraphStyle :: PandocMonad m
=> WriterOptions -> String -> [Block] -> OD m Doc
withParagraphStyle o s (b:bs)
| Para l <- b = go =<< inParagraphTagsWithStyle s <$> inlinesToOpenDocument o l
| otherwise = go =<< blockToOpenDocument o b
where go i = (<>) i <$> withParagraphStyle o s bs
withParagraphStyle _ _ [] = return empty
inPreformattedTags :: PandocMonad m => String -> OD m Doc
inPreformattedTags s = do
n <- paraStyle [("style:parent-style-name","Preformatted_20_Text")]
return . inParagraphTagsWithStyle ("P" ++ show n) . handleSpaces $ s
orderedListToOpenDocument :: PandocMonad m
=> WriterOptions -> Int -> [[Block]] -> OD m Doc
orderedListToOpenDocument o pn bs =
vcat . map (inTagsIndented "text:list-item") <$>
mapM (orderedItemToOpenDocument o pn . map plainToPara) bs
orderedItemToOpenDocument :: PandocMonad m
=> WriterOptions -> Int -> [Block] -> OD m Doc
orderedItemToOpenDocument o n bs = vcat <$> mapM go bs
where go (OrderedList a l) = newLevel a l
go (Para l) = inParagraphTagsWithStyle ("P" ++ show n) <$>
inlinesToOpenDocument o l
go b = blockToOpenDocument o b
newLevel a l = do
nn <- length <$> gets stParaStyles
ls <- head <$> gets stListStyles
modify $ \s -> s { stListStyles = orderedListLevelStyle a ls :
drop 1 (stListStyles s) }
inTagsIndented "text:list" <$> orderedListToOpenDocument o nn l
isTightList :: [[Block]] -> Bool
isTightList [] = False
isTightList (b:_)
| Plain {} : _ <- b = True
| otherwise = False
newOrderedListStyle :: PandocMonad m
=> Bool -> ListAttributes -> OD m (Int,Int)
newOrderedListStyle b a = do
ln <- (+) 1 . length <$> gets stListStyles
let nbs = orderedListLevelStyle a (ln, [])
pn <- if b then inTightList (paraListStyle ln) else paraListStyle ln
modify $ \s -> s { stListStyles = nbs : stListStyles s }
return (ln,pn)
bulletListToOpenDocument :: PandocMonad m
=> WriterOptions -> [[Block]] -> OD m Doc
bulletListToOpenDocument o b = do
ln <- (+) 1 . length <$> gets stListStyles
(pn,ns) <- if isTightList b then inTightList (bulletListStyle ln) else bulletListStyle ln
modify $ \s -> s { stListStyles = ns : stListStyles s }
is <- listItemsToOpenDocument ("P" ++ show pn) o b
return $ inTags True "text:list" [("text:style-name", "L" ++ show ln)] is
listItemsToOpenDocument :: PandocMonad m
=> String -> WriterOptions -> [[Block]] -> OD m Doc
listItemsToOpenDocument s o is =
vcat . map (inTagsIndented "text:list-item") <$> mapM (withParagraphStyle o s . map plainToPara) is
deflistItemToOpenDocument :: PandocMonad m
=> WriterOptions -> ([Inline],[[Block]]) -> OD m Doc
deflistItemToOpenDocument o (t,d) = do
let ts = if isTightList d
then "Definition_20_Term_20_Tight" else "Definition_20_Term"
ds = if isTightList d
then "Definition_20_Definition_20_Tight" else "Definition_20_Definition"
t' <- withParagraphStyle o ts [Para t]
d' <- liftM vcat $ mapM (withParagraphStyle o ds . map plainToPara) d
return $ t' $$ d'
inBlockQuote :: PandocMonad m
=> WriterOptions -> Int -> [Block] -> OD m Doc
inBlockQuote o i (b:bs)
| BlockQuote l <- b = do increaseIndent
ni <- paraStyle
[("style:parent-style-name","Quotations")]
go =<< inBlockQuote o ni (map plainToPara l)
| Para l <- b = go =<< inParagraphTagsWithStyle ("P" ++ show i) <$> inlinesToOpenDocument o l
| otherwise = go =<< blockToOpenDocument o b
where go block = ($$) block <$> inBlockQuote o i bs
inBlockQuote _ _ [] = resetIndent >> return empty
blocksToOpenDocument :: PandocMonad m => WriterOptions -> [Block] -> OD m Doc
blocksToOpenDocument o b = vcat <$> mapM (blockToOpenDocument o) b
blockToOpenDocument :: PandocMonad m => WriterOptions -> Block -> OD m Doc
blockToOpenDocument o bs
| Plain b <- bs = if null b
then return empty
else inParagraphTags =<< inlinesToOpenDocument o b
| Para [Image attr c (s,'f':'i':'g':':':t)] <- bs
= figure attr c s t
| Para b <- bs = if null b &&
not (isEnabled Ext_empty_paragraphs o)
then return empty
else inParagraphTags =<< inlinesToOpenDocument o b
| LineBlock b <- bs = blockToOpenDocument o $ linesToPara b
| 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
| DefinitionList b <- bs = setFirstPara >> defList b
| BulletList b <- bs = setFirstPara >> bulletListToOpenDocument o b
| OrderedList a b <- bs = setFirstPara >> orderedList a b
| CodeBlock _ s <- bs = setFirstPara >> preformatted s
| Table c a w h r <- bs = setFirstPara >> table c a w h r
| HorizontalRule <- bs = setFirstPara >> return (selfClosingTag "text:p"
[ ("text:style-name", "Horizontal_20_Line") ])
| RawBlock f s <- bs = if f == Format "opendocument"
then return $ text s
else do
report $ BlockNotRendered bs
return empty
| Null <- bs = return empty
| otherwise = return empty
where
defList b = do setInDefinitionList True
r <- vcat <$> mapM (deflistItemToOpenDocument o) b
setInDefinitionList False
return r
preformatted s = (flush . vcat) <$> mapM (inPreformattedTags . escapeStringForXML) (lines s)
mkBlockQuote b = do increaseIndent
i <- paraStyle
[("style:parent-style-name","Quotations")]
inBlockQuote o i (map plainToPara b)
orderedList a b = do (ln,pn) <- newOrderedListStyle (isTightList b) a
inTags True "text:list" [ ("text:style-name", "L" ++ show ln)]
<$> orderedListToOpenDocument o pn b
table c a w h r = do
tn <- length <$> gets stTableStyles
pn <- length <$> gets stParaStyles
let genIds = map chr [65..]
name = "Table" ++ show (tn + 1)
columnIds = zip genIds w
mkColumn n = selfClosingTag "table:table-column" [("table:style-name", name ++ "." ++ [fst n])]
columns = map mkColumn columnIds
paraHStyles = paraTableStyles "Heading" pn a
paraStyles = paraTableStyles "Contents" (pn + length (newPara paraHStyles)) a
newPara = map snd . filter (not . isEmpty . snd)
addTableStyle $ tableStyle tn columnIds
mapM_ addParaStyle . newPara $ paraHStyles ++ paraStyles
captionDoc <- if null c
then return empty
else withParagraphStyle o "Table" [Para c]
th <- if all null h
then return empty
else colHeadsToOpenDocument o name (map fst paraHStyles) h
tr <- mapM (tableRowToOpenDocument o name (map fst paraStyles)) r
return $ inTags True "table:table" [ ("table:name" , name)
, ("table:style-name", name)
] (vcat columns $$ th $$ vcat tr) $$ captionDoc
figure attr caption source title | null caption =
withParagraphStyle o "Figure" [Para [Image attr caption (source,title)]]
| otherwise = do
imageDoc <- withParagraphStyle o "FigureWithCaption" [Para [Image attr caption (source,title)]]
captionDoc <- withParagraphStyle o "FigureCaption" [Para caption]
return $ imageDoc $$ captionDoc
colHeadsToOpenDocument :: PandocMonad m
=> WriterOptions -> String -> [String] -> [[Block]]
-> OD m Doc
colHeadsToOpenDocument o tn ns hs =
inTagsIndented "table:table-header-rows" . inTagsIndented "table:table-row" . vcat <$>
mapM (tableItemToOpenDocument o tn) (zip ns hs)
tableRowToOpenDocument :: PandocMonad m
=> WriterOptions -> String -> [String] -> [[Block]]
-> OD m Doc
tableRowToOpenDocument o tn ns cs =
inTagsIndented "table:table-row" . vcat <$>
mapM (tableItemToOpenDocument o tn) (zip ns cs)
tableItemToOpenDocument :: PandocMonad m
=> WriterOptions -> String -> (String,[Block])
-> OD m Doc
tableItemToOpenDocument o tn (n,i) =
let a = [ ("table:style-name" , tn ++ ".A1" )
, ("office:value-type", "string" )
]
in inTags True "table:table-cell" a <$>
withParagraphStyle o n (map plainToPara i)
inlinesToOpenDocument :: PandocMonad m => WriterOptions -> [Inline] -> OD m Doc
inlinesToOpenDocument o l = hcat <$> toChunks o l
toChunks :: PandocMonad m => WriterOptions -> [Inline] -> OD m [Doc]
toChunks _ [] = return []
toChunks o (x : xs)
| isChunkable x = do
contents <- (inTextStyle . hcat) =<<
mapM (inlineToOpenDocument o) (x:ys)
rest <- toChunks o zs
return (contents : rest)
| otherwise = do
contents <- inlineToOpenDocument o x
rest <- toChunks o xs
return (contents : rest)
where (ys, zs) = span isChunkable xs
isChunkable :: Inline -> Bool
isChunkable (Str _) = True
isChunkable Space = True
isChunkable SoftBreak = True
isChunkable _ = False
inlineToOpenDocument :: PandocMonad m => WriterOptions -> Inline -> OD m Doc
inlineToOpenDocument o ils
= case ils of
Space -> return space
SoftBreak
| writerWrapText o == WrapPreserve
-> return $ preformatted "\n"
| otherwise ->return space
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
Strong l -> withTextStyle Bold $ inlinesToOpenDocument o l
Strikeout l -> withTextStyle Strike $ inlinesToOpenDocument o l
Superscript l -> withTextStyle Sup $ inlinesToOpenDocument o l
Subscript l -> withTextStyle Sub $ inlinesToOpenDocument o l
SmallCaps l -> withTextStyle SmallC $ inlinesToOpenDocument o l
Quoted t l -> inQuotes t <$> inlinesToOpenDocument o l
Code _ s -> inlinedCode $ preformatted s
Math t s -> lift (texMathToInlines t s) >>=
inlinesToOpenDocument o
Cite _ l -> inlinesToOpenDocument o l
RawInline f s -> if f == Format "opendocument"
then return $ text s
else do
report $ InlineNotRendered ils
return empty
Link _ l (s,t) -> mkLink s t <$> inlinesToOpenDocument o l
Image attr _ (s,t) -> mkImg attr s t
Note l -> mkNote l
where
preformatted s = handleSpaces $ escapeStringForXML s
inlinedCode s = return $ inTags False "text:span" [("text:style-name", "Source_Text")] s
mkLink s t = inTags False "text:a" [ ("xlink:type" , "simple")
, ("xlink:href" , s )
, ("office:name", t )
] . inSpanTags "Definition"
mkImg (_, _, kvs) s _ = do
id' <- gets stImageId
modify (\st -> st{ stImageId = id' + 1 })
let getDims [] = []
getDims (("width", w) :xs) = ("svg:width", w) : getDims xs
getDims (("height", h):xs) = ("svg:height", h) : getDims xs
getDims (_:xs) = getDims xs
return $ inTags False "draw:frame"
(("draw:name", "img" ++ show id') : getDims kvs) $
selfClosingTag "draw:image" [ ("xlink:href" , s )
, ("xlink:type" , "simple")
, ("xlink:show" , "embed" )
, ("xlink:actuate", "onLoad")]
mkNote l = do
n <- length <$> gets stNotes
let footNote t = inTags False "text:note"
[ ("text:id" , "ftn" ++ show n)
, ("text:note-class", "footnote" )] $
inTagsSimple "text:note-citation" (text . show $ n + 1) <>
inTagsSimple "text:note-body" t
nn <- footNote <$> withParagraphStyle o "Footnote" l
addNote nn
return nn
bulletListStyle :: PandocMonad m => Int -> OD m (Int,(Int,[Doc]))
bulletListStyle l = do
let doStyles i = inTags True "text:list-level-style-bullet"
[ ("text:level" , show (i + 1) )
, ("text:style-name" , "Bullet_20_Symbols")
, ("style:num-suffix", "." )
, ("text:bullet-char", [bulletList !! i] )
] (listLevelStyle (1 + i))
bulletList = map chr $ cycle [8226,9702,9642]
listElStyle = map doStyles [0..9]
pn <- paraListStyle l
return (pn, (l, listElStyle))
orderedListLevelStyle :: ListAttributes -> (Int, [Doc]) -> (Int,[Doc])
orderedListLevelStyle (s,n, d) (l,ls) =
let suffix = case d of
OneParen -> [("style:num-suffix", ")")]
TwoParens -> [("style:num-prefix", "(")
,("style:num-suffix", ")")]
_ -> [("style:num-suffix", ".")]
format = case n of
UpperAlpha -> "A"
LowerAlpha -> "a"
UpperRoman -> "I"
LowerRoman -> "i"
_ -> "1"
listStyle = inTags True "text:list-level-style-number"
([ ("text:level" , show $ 1 + length ls )
, ("text:style-name" , "Numbering_20_Symbols")
, ("style:num-format", format )
, ("text:start-value", show s )
] ++ suffix) (listLevelStyle (1 + length ls))
in (l, ls ++ [listStyle])
listLevelStyle :: Int -> Doc
listLevelStyle i =
let indent = show (0.4 * fromIntegral (i 1) :: Double) in
selfClosingTag "style:list-level-properties"
[ ("text:space-before" , indent ++ "in")
, ("text:min-label-width", "0.4in")]
tableStyle :: Int -> [(Char,Double)] -> Doc
tableStyle num wcs =
let tableId = "Table" ++ show (num + 1)
table = inTags True "style:style"
[("style:name", tableId)
,("style:family", "table")] $
selfClosingTag "style:table-properties"
[("table:align" , "center")]
colStyle (c,0) = selfClosingTag "style:style"
[ ("style:name" , tableId ++ "." ++ [c])
, ("style:family", "table-column" )]
colStyle (c,w) = inTags True "style:style"
[ ("style:name" , tableId ++ "." ++ [c])
, ("style:family", "table-column" )] $
selfClosingTag "style:table-column-properties"
[("style:rel-column-width", printf "%d*" (floor $ w * 65535 :: Integer))]
cellStyle = inTags True "style:style"
[ ("style:name" , tableId ++ ".A1")
, ("style:family", "table-cell" )] $
selfClosingTag "style:table-cell-properties"
[ ("fo:border", "none")]
columnStyles = map colStyle wcs
in table $$ vcat columnStyles $$ cellStyle
paraStyle :: PandocMonad m => [(String,String)] -> OD m Int
paraStyle attrs = do
pn <- (+) 1 . length <$> gets stParaStyles
i <- (*) (0.5 :: Double) . fromIntegral <$> gets stIndentPara
b <- gets stInDefinition
t <- gets stTight
let styleAttr = [ ("style:name" , "P" ++ show pn)
, ("style:family" , "paragraph" )]
indentVal = flip (++) "in" . show $ if b then max 0.5 i else i
tight = if t then [ ("fo:margin-top" , "0in" )
, ("fo:margin-bottom" , "0in" )]
else []
indent = if (i /= 0 || b)
then [ ("fo:margin-left" , indentVal)
, ("fo:margin-right" , "0in" )
, ("fo:text-indent" , "0in" )
, ("style:auto-text-indent" , "false" )]
else []
attributes = indent ++ tight
paraProps = if null attributes
then mempty
else selfClosingTag
"style:paragraph-properties" attributes
addParaStyle $ inTags True "style:style" (styleAttr ++ attrs) paraProps
return pn
paraListStyle :: PandocMonad m => Int -> OD m Int
paraListStyle l = paraStyle
[("style:parent-style-name","Text_20_body")
,("style:list-style-name", "L" ++ show l )]
paraTableStyles :: String -> Int -> [Alignment] -> [(String, Doc)]
paraTableStyles _ _ [] = []
paraTableStyles t s (a:xs)
| AlignRight <- a = ( pName s, res s "end" ) : paraTableStyles t (s + 1) xs
| AlignCenter <- a = ( pName s, res s "center") : paraTableStyles t (s + 1) xs
| otherwise = ("Table_20_" ++ t, empty ) : paraTableStyles t s xs
where pName sn = "P" ++ show (sn + 1)
res sn x = inTags True "style:style"
[ ("style:name" , pName sn )
, ("style:family" , "paragraph" )
, ("style:parent-style-name", "Table_20_" ++ t)] $
selfClosingTag "style:paragraph-properties"
[ ("fo:text-align", x)
, ("style:justify-single-word", "false")]
data TextStyle = Italic
| Bold
| Strike
| Sub
| Sup
| SmallC
| Pre
| Language Lang
deriving ( Eq,Ord )
textStyleAttr :: TextStyle -> [(String,String)]
textStyleAttr s
| Italic <- s = [("fo:font-style" ,"italic" )
,("style:font-style-asian" ,"italic" )
,("style:font-style-complex" ,"italic" )]
| Bold <- s = [("fo:font-weight" ,"bold" )
,("style:font-weight-asian" ,"bold" )
,("style:font-weight-complex" ,"bold" )]
| Strike <- s = [("style:text-line-through-style", "solid" )]
| Sub <- s = [("style:text-position" ,"sub 58%" )]
| Sup <- s = [("style:text-position" ,"super 58%" )]
| SmallC <- s = [("fo:font-variant" ,"small-caps")]
| Pre <- s = [("style:font-name" ,"Courier New")
,("style:font-name-asian" ,"Courier New")
,("style:font-name-complex" ,"Courier New")]
| Language lang <- s
= [("fo:language" ,langLanguage lang)
,("fo:country" ,langRegion lang)]
| otherwise = []
withLangFromAttr :: PandocMonad m => Attr -> OD m a -> OD m a
withLangFromAttr (_,_,kvs) action =
case lookup "lang" kvs of
Nothing -> action
Just l ->
case parseBCP47 l of
Right lang -> withTextStyle (Language lang) action
Left _ -> do
report $ InvalidLang l
action