01d109e · typeable/pandoc

30module Text.Pandoc.Writers.EPUB ( writeEPUB ) where

31import Data.IORef

32import Data.Maybe ( fromMaybe, isNothing )

33−import Data.List ( findIndices, isPrefixOf )

33+import Data.List ( isPrefixOf, intercalate )

34import System.Environment ( getEnv )

35import Text.Printf (printf)

36import System.FilePath ( (</>), (<.>), takeBaseName, takeExtension, takeFileName )

39import Codec.Archive.Zip

40import Data.Time.Clock.POSIX

41import Text.Pandoc.Shared hiding ( Element )

42+import qualified Text.Pandoc.Shared as Shared

42import Text.Pandoc.Options

43import Text.Pandoc.Options

43import Text.Pandoc.Definition

44import Text.Pandoc.Definition

44import Text.Pandoc.Generic

45import Text.Pandoc.Generic

46+import Text.Pandoc.Templates

45import Control.Monad.State

47import Control.Monad.State

46import Text.XML.Light hiding (ppTopElement)

48import Text.XML.Light hiding (ppTopElement)

47import Text.Pandoc.UUID

49import Text.Pandoc.UUID

52import Text.Pandoc.MIME (getMimeType)

54import Text.Pandoc.MIME (getMimeType)

53import Prelude hiding (catch)

55import Prelude hiding (catch)

54import Control.Exception (catch, SomeException)

56import Control.Exception (catch, SomeException)

57+import Text.HTML.TagSoup

55

58

56-- | Produce an EPUB file from a Pandoc document.

59-- | Produce an EPUB file from a Pandoc document.

57writeEPUB :: WriterOptions -- ^ Writer options

60writeEPUB :: WriterOptions -- ^ Writer options

110 fontEntries <- mapM mkFontEntry $ writerEpubFonts opts

113 fontEntries <- mapM mkFontEntry $ writerEpubFonts opts

111

114

112 -- body pages

115 -- body pages

116+ -- add level 1 header to beginning if none there

117+ let blocks' = case blocks of

113− let isH1 (Header 1 _) = True

118+ (Header 1 _ : _) -> blocks

114− isH1 _ = False

119+ _ -> Header 1 (docTitle meta) : blocks

115 -- internal reference IDs change when we chunk the file,

120 -- internal reference IDs change when we chunk the file,

116 -- so the next two lines fix that:

121 -- so the next two lines fix that:

117− let reftable = correlateRefs blocks

122+ let reftable = correlateRefs blocks'

118− let blocks' = replaceRefs reftable blocks

123+ let blocks'' = replaceRefs reftable blocks'

119− let h1Indices = dropWhile (== 0) $ findIndices isH1 blocks'

124+ let tags = parseTags $ writeHtmlString opts'{writerStandalone = False}

120− let chunks = splitByIndices h1Indices blocks'

125+ $ Pandoc (Meta [] [] []) blocks''

121− let titleize (Header 1 xs : ys) = Pandoc meta{docTitle = xs} ys

126+

122− titleize xs = Pandoc meta xs

127+ let chunks = partitions (~== TagOpen "h1" []) tags

123− let chapters = map titleize chunks

128+

124− let chapToHtml = writeHtmlString opts'{ writerTemplate = pageTemplate }

129+ let chapToEntry :: Int -> [Tag String] -> Entry

125− let chapterToEntry :: Int -> Pandoc -> Entry

126− chapterToEntry num chap = mkEntry

127− (showChapter num) $

130+ chapToEntry num ts = mkEntry (showChapter num)

128− fromStringLazy $ chapToHtml chap

131+ $ fromStringLazy

132+ $ renderTemplate [("body",renderTags ts)]

133+ $ pageTemplate

134+

129− let chapterEntries = zipWith chapterToEntry [1..] chapters

135+ let chapterEntries = zipWith chapToEntry [1..] chunks

130

136

131 -- contents.opf

137 -- contents.opf

132 localeLang <- catch (liftM (map (\c -> if c == '_' then '-' else c) .

138 localeLang <- catch (liftM (map (\c -> if c == '_' then '-' else c) .

182 let contentsEntry = mkEntry "content.opf" contentsData

188 let contentsEntry = mkEntry "content.opf" contentsData

183

189

184 -- toc.ncx

190 -- toc.ncx

191+ let secs = hierarchicalize blocks''

192+

193+ let navPointNode :: Shared.Element -> State Int Element

194+ navPointNode (Sec _ nums ident ils children) = do

195+ n <- get

196+ modify (+1)

197+ let showNums :: [Int] -> String

198+ showNums = intercalate "." . map show

199+ let tit' = plainify ils

200+ let tit = if writerNumberSections opts

201+ then showNums nums ++ " " ++ tit'

202+ else tit'

203+ let src = case lookup ident reftable of

204+ Just x -> x

205+ Nothing -> error (ident ++ " not found in reftable")

206+ let isSec (Sec lev _ _ _ _) = lev <= 3 -- only includes levels 1-3

207+ isSec _ = False

208+ let subsecs = filter isSec children

209+ subs <- mapM navPointNode subsecs

185− let navPointNode ent n tit = unode "navPoint" !

210+ return $ unode "navPoint" !

186− [("id", "navPoint-" ++ show n)

211+ [("id", "navPoint-" ++ show n)

187− ,("playOrder", show n)] $

212+ ,("playOrder", show n)] $

188− [ unode "navLabel" $ unode "text" tit

213+ [ unode "navLabel" $ unode "text" tit

189− , unode "content" ! [("src",

214+ , unode "content" ! [("src", src)] $ ()

190− eRelativePath ent)] $ ()

215+ ] ++ subs

191− ]

216+ navPointNode (Blk _) = error "navPointNode encountered Blk"

217+

218+ let tpNode = unode "navPoint" ! [("id", "navPoint-0")] $

219+ [ unode "navLabel" $ unode "text" (plainify $ docTitle meta)

220+ , unode "content" ! [("src","title_page.xhtml")] $ () ]

221+

192 let tocData = fromStringLazy $ ppTopElement $

222 let tocData = fromStringLazy $ ppTopElement $

193 unode "ncx" ! [("version","2005-1")

223 unode "ncx" ! [("version","2005-1")

194 ,("xmlns","http://www.daisy.org/z3986/2005/ncx/")] $

224 ,("xmlns","http://www.daisy.org/z3986/2005/ncx/")] $

206 Just _ -> [unode "meta" ! [("name","cover"),

236 Just _ -> [unode "meta" ! [("name","cover"),

207 ("content","cover-image")] $ ()]

237 ("content","cover-image")] $ ()]

208 , unode "docTitle" $ unode "text" $ plainTitle

238 , unode "docTitle" $ unode "text" $ plainTitle

209− , unode "navMap" $ zipWith3 navPointNode (tpEntry : chapterEntries)

239+ , unode "navMap" $ tpNode : evalState (mapM navPointNode secs) 1

210− [1..(length chapterEntries + 1)]

211− (plainTitle : map (\(Pandoc m _) ->

212− plainify $ docTitle m) chapters)

213 ]

240 ]

214 let tocEntry = mkEntry "toc.ncx" tocData

241 let tocEntry = mkEntry "toc.ncx" tocData

215

242