8d1d0eb · typeable/pandoc

29Conversion of 'Pandoc' documents to ODT.

30-}

31module Text.Pandoc.Writers.ODT ( writeODTPure, writeODT ) where

32−import Data.IORef

33import Data.List ( isPrefixOf )

32import Data.List ( isPrefixOf )

34import Data.Maybe ( fromMaybe )

33import Data.Maybe ( fromMaybe )

35import Text.XML.Light.Output

34import Text.XML.Light.Output

46import Text.Pandoc.Writers.Shared ( fixDisplayMath )

45import Text.Pandoc.Writers.Shared ( fixDisplayMath )

47import Text.Pandoc.Writers.OpenDocument ( writeOpenDocument )

46import Text.Pandoc.Writers.OpenDocument ( writeOpenDocument )

48import Control.Monad (liftM)

47import Control.Monad (liftM)

48+import Control.Monad.State

49import Text.Pandoc.XML

50import Text.Pandoc.Pretty

51import qualified Control.Exception as E

55

56type ODTAction = PandocAction [Entry]

57

58+data ODTState = ODTState { stEntries :: [Entry]

59+ }

60+

61+type O = StateT ODTState ODTAction

62+

58-- | Produce an ODT file from a Pandoc document.

63-- | Produce an ODT file from a Pandoc document.

59writeODT :: WriterOptions -- ^ Writer options

64writeODT :: WriterOptions -- ^ Writer options

60 -> Pandoc -- ^ Document to convert

65 -> Pandoc -- ^ Document to convert

61 -> IO B.ByteString

66 -> IO B.ByteString

62writeODT opts doc = runIO $ writeODTPure opts doc

67writeODT opts doc = runIO $ writeODTPure opts doc

63

68

64−-- | Produce an ODT file from a Pandoc document.

65−writeODTPure :: WriterOptions -- ^ Writer options

69+writeODTPure :: WriterOptions

66− -> Pandoc -- ^ Document to convert

70+ -> Pandoc

67 -> ODTAction B.ByteString

71 -> ODTAction B.ByteString

68−writeODTPure opts doc@(Pandoc meta _) = do

72+writeODTPure opts doc =

73+ let initState = ODTState{ stEntries = []

74+ }

75+ in

76+ evalStateT (pandocToODT opts doc) initState

77+

78+-- | Produce an ODT file from a Pandoc document.

79+pandocToODT :: WriterOptions -- ^ Writer options

80+ -> Pandoc -- ^ Document to convert

81+ -> O B.ByteString

82+pandocToODT opts doc@(Pandoc meta _) = do

69 let datadir = writerUserDataDir opts

83 let datadir = writerUserDataDir opts

70 let title = docTitle meta

84 let title = docTitle meta

71 refArchive <-

85 refArchive <-

72 case writerReferenceODT opts of

86 case writerReferenceODT opts of

73− Just f -> liftM toArchive $ P.readFileLazy f

87+ Just f -> liftM toArchive $ lift $ P.readFileLazy f

74− Nothing -> P.getDefaultReferenceODT datadir

88+ Nothing -> lift $ P.getDefaultReferenceODT datadir

75 -- handle formulas and pictures

89 -- handle formulas and pictures

76− picEntriesRef <- P.newIORef ([] :: [Entry])

90+ -- picEntriesRef <- P.newIORef ([] :: [Entry])

77− doc' <- walkM (transformPicMath opts picEntriesRef) $ walk fixDisplayMath doc

91+ doc' <- walkM (transformPicMath opts) $ walk fixDisplayMath doc

78 let newContents = writeOpenDocument opts{writerWrapText = WrapNone} doc'

92 let newContents = writeOpenDocument opts{writerWrapText = WrapNone} doc'

79− epochtime <- floor `fmap` P.getPOSIXTime

93+ epochtime <- floor `fmap` (lift P.getPOSIXTime)

80 let contentEntry = toEntry "content.xml" epochtime

94 let contentEntry = toEntry "content.xml" epochtime

81 $ fromStringLazy newContents

95 $ fromStringLazy newContents

82− picEntries <- P.readIORef picEntriesRef

96+ picEntries <- gets stEntries

83 let archive = foldr addEntryToArchive refArchive

97 let archive = foldr addEntryToArchive refArchive

84 $ contentEntry : picEntries

98 $ contentEntry : picEntries

85 -- construct META-INF/manifest.xml based on archive

99 -- construct META-INF/manifest.xml based on archive

134 return $ fromArchive archive''

148 return $ fromArchive archive''

135

149

136-- | transform both Image and Math elements

150-- | transform both Image and Math elements

137−transformPicMath :: WriterOptions -> IORef [Entry] -> Inline -> ODTAction Inline

151+transformPicMath :: WriterOptions ->Inline -> O Inline

138−transformPicMath opts entriesRef (Image attr@(id', cls, _) lab (src,t)) = do

152+transformPicMath opts (Image attr@(id', cls, _) lab (src,t)) = do

139− res <- P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) src

153+ res <- lift $ P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) src

140 case res of

154 case res of

141 Left (_ :: E.SomeException) -> do

155 Left (_ :: E.SomeException) -> do

142− P.warn $ "Could not find image `" ++ src ++ "', skipping..."

156+ lift $ P.warn $ "Could not find image `" ++ src ++ "', skipping..."

143 return $ Emph lab

157 return $ Emph lab

144 Right (img, mbMimeType) -> do

158 Right (img, mbMimeType) -> do

145 (ptX, ptY) <- case imageSize img of

159 (ptX, ptY) <- case imageSize img of

146 Right s -> return $ sizeInPoints s

160 Right s -> return $ sizeInPoints s

147 Left msg -> do

161 Left msg -> do

148− P.warn $ "Could not determine image size in `" ++

162+ lift $ P.warn $ "Could not determine image size in `" ++

149 src ++ "': " ++ msg

163 src ++ "': " ++ msg

150 return (100, 100)

164 return (100, 100)

151 let dims =

165 let dims =

163 Just dim -> Just $ Inch $ inInch opts dim

177 Just dim -> Just $ Inch $ inInch opts dim

164 Nothing -> Nothing

178 Nothing -> Nothing

165 let newattr = (id', cls, dims)

179 let newattr = (id', cls, dims)

166− entries <- P.readIORef entriesRef

180+ entries <- gets stEntries

167 let extension = fromMaybe (takeExtension $ takeWhile (/='?') src)

181 let extension = fromMaybe (takeExtension $ takeWhile (/='?') src)

168 (mbMimeType >>= extensionFromMimeType)

182 (mbMimeType >>= extensionFromMimeType)

169 let newsrc = "Pictures/" ++ show (length entries) <.> extension

183 let newsrc = "Pictures/" ++ show (length entries) <.> extension

170 let toLazy = B.fromChunks . (:[])

184 let toLazy = B.fromChunks . (:[])

171− epochtime <- floor `fmap` P.getPOSIXTime

185+ epochtime <- floor `fmap` (lift P.getPOSIXTime)

172 let entry = toEntry newsrc epochtime $ toLazy img

186 let entry = toEntry newsrc epochtime $ toLazy img

173− P.modifyIORef entriesRef (entry:)

187+ modify $ \st -> st{ stEntries = entry : entries }

174 return $ Image newattr lab (newsrc, t)

188 return $ Image newattr lab (newsrc, t)

175−transformPicMath _ entriesRef (Math t math) = do

189+transformPicMath _ (Math t math) = do

176− entries <- P.readIORef entriesRef

190+ entries <- gets stEntries

177 let dt = if t == InlineMath then DisplayInline else DisplayBlock

191 let dt = if t == InlineMath then DisplayInline else DisplayBlock

178 case writeMathML dt <$> readTeX math of

192 case writeMathML dt <$> readTeX math of

179 Left _ -> return $ Math t math

193 Left _ -> return $ Math t math

180 Right r -> do

194 Right r -> do

181 let conf = useShortEmptyTags (const False) defaultConfigPP

195 let conf = useShortEmptyTags (const False) defaultConfigPP

182 let mathml = ppcTopElement conf r

196 let mathml = ppcTopElement conf r

183− epochtime <- floor `fmap` P.getPOSIXTime

197+ epochtime <- floor `fmap` (lift $ P.getPOSIXTime)

184 let dirname = "Formula-" ++ show (length entries) ++ "/"

198 let dirname = "Formula-" ++ show (length entries) ++ "/"

185 let fname = dirname ++ "content.xml"

199 let fname = dirname ++ "content.xml"

186 let entry = toEntry fname epochtime (fromStringLazy mathml)

200 let entry = toEntry fname epochtime (fromStringLazy mathml)

187− P.modifyIORef entriesRef (entry:)

201+ modify $ \st -> st{ stEntries = entry : entries }

188 return $ RawInline (Format "opendocument") $ render Nothing $

202 return $ RawInline (Format "opendocument") $ render Nothing $

189 inTags False "draw:frame" [("text:anchor-type",

203 inTags False "draw:frame" [("text:anchor-type",

190 if t == DisplayMath

204 if t == DisplayMath

197 , ("xlink:show", "embed")

211 , ("xlink:show", "embed")

198 , ("xlink:actuate", "onLoad")]

212 , ("xlink:actuate", "onLoad")]

199

213

200−transformPicMath _ _ x = return x

214+transformPicMath _ x = return x