81d2841 · typeable/pandoc

38module Text.Pandoc.Writers.FB2 (writeFB2) where

39

40import Control.Monad.Except (catchError)

41−import Control.Monad.State.Strict (StateT, evalStateT, get, lift, modify)

41+import Control.Monad.State.Strict (StateT, evalStateT, get, lift, modify, liftM)

42−import Control.Monad.State.Strict (liftM)

42+import Control.Monad (zipWithM)

43import Data.ByteString.Base64 (encode)

44import qualified Data.ByteString.Char8 as B8

45import Data.Char (isAscii, isControl, isSpace, toLower)

100 secs <- renderSections 1 blocks

101 let body = el "body" $ fp ++ secs

102 notes <- renderFootnotes

103− (imgs,missing) <- liftM imagesToFetch get >>= \s -> lift (fetchImages s)

103+ (imgs,missing) <- fmap imagesToFetch get >>= \s -> lift (fetchImages s)

104 let body' = replaceImagesWithAlt missing body

105 let fb2_xml = el "FictionBook" (fb2_attrs, [desc, body'] ++ notes ++ imgs)

106− return $ pack $ xml_head ++ (showContent fb2_xml) ++ "\n"

106+ return $ pack $ xml_head ++ showContent fb2_xml ++ "\n"

107 where

108 xml_head = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"

109 fb2_attrs =

115frontpage :: PandocMonad m => Meta -> FBM m [Content]

116frontpage meta' = do

117 t <- cMapM toXml . docTitle $ meta'

118− return $

118+ return

119 [ el "title" (el "p" t)

120 , el "annotation" (map (el "p" . cMap plain)

121 (docAuthors meta' ++ [docDate meta']))

131 Just (MetaString s) -> [el "lang" $ iso639 s]

132 _ -> []

133 where iso639 = takeWhile (/= '-') -- Convert BCP 47 to ISO 639

134− return $ el "description" $

134+ return $ el "description"

135 [ el "title-info" (bt ++ as ++ dd ++ lang)

136 , el "document-info" [ el "program-used" "pandoc" ] -- FIXME: +version

137 ]

149author :: [Inline] -> [Content]

150author ss =

151 let ws = words . cMap plain $ ss

152− email = (el "email") `fmap` (take 1 $ filter ('@' `elem`) ws)

152+ email = el "email" <$> take 1 (filter ('@' `elem`) ws)

153 ws' = filter ('@' `notElem`) ws

154 names = case ws' of

155− (nickname:[]) -> [ el "nickname" nickname ]

155+ [nickname] -> [ el "nickname" nickname ]

156− (fname:lname:[]) -> [ el "first-name" fname

156+ [fname, lname] -> [ el "first-name" fname

157 , el "last-name" lname ]

158 (fname:rest) -> [ el "first-name" fname

159 , el "middle-name" (concat . init $ rest)

160 , el "last-name" (last rest) ]

161− ([]) -> []

161+ [] -> []

162 in list $ el "author" (names ++ email)

163

164docdate :: PandocMonad m => Meta -> FBM m [Content]

181 title <- if null ttl

182 then return []

183 else return . list . el "title" . formatTitle $ ttl

184− content <- if (hasSubsections body)

184+ content <- if hasSubsections body

185 then renderSections (level + 1) body

186 else cMapM blockToXml body

187 return $ el "section" (title ++ content)

213 let (lastsec, before) = break sameLevel rblocks

214 (header, prevblocks) =

215 case before of

216− ((Header n _ title):prevblocks') ->

216+ (Header n _ title:prevblocks') ->

217 if n == level

218 then (title, prevblocks')

219 else ([], before)

232 el "body" ([uattr "name" "notes"], map renderFN (reverse fns))

233 where

234 renderFN (n, idstr, cs) =

235− let fn_texts = (el "title" (el "p" (show n))) : cs

235+ let fn_texts = el "title" (el "p" (show n)) : cs

236 in el "section" ([uattr "id" idstr], fn_texts)

237

238-- | Fetch images and encode them for the FictionBook XML.

240fetchImages :: PandocMonad m => [(String,String)] -> m ([Content],[String])

241fetchImages links = do

242 imgs <- mapM (uncurry fetchImage) links

243− return $ (rights imgs, lefts imgs)

243+ return (rights imgs, lefts imgs)

244

245-- | Fetch image data from disk or from network and make a <binary> XML section.

246-- Return either (Left hrefOfMissingImage) or (Right xmlContent).

254 then return (Just (mime',base64))

255 else return Nothing

256 (True, Just _) -> return Nothing -- not base64-encoded

257− _ -> do

257+ _ ->

258 catchError (do (bs, mbmime) <- P.fetchItem link

259 case mbmime of

260 Nothing -> do

266 do report $ CouldNotFetchResource link (show e)

267 return Nothing)

268 case mbimg of

269− Just (imgtype, imgdata) -> do

269+ Just (imgtype, imgdata) ->

270 return . Right $ el "binary"

271 ( [uattr "id" href

272 , uattr "content-type" imgtype]

300isMimeType s =

301 case split (=='/') s of

302 [mtype,msubtype] ->

303− ((map toLower mtype) `elem` types

303+ (map toLower mtype `elem` types

304− || "x-" `isPrefixOf` (map toLower mtype))

304+ || "x-" `isPrefixOf` map toLower mtype)

305 && all valid mtype

306 && all valid msubtype

307 _ -> False

311 c `notElem` "()<>@,;:\\\"/[]?="

312

313footnoteID :: Int -> String

314−footnoteID i = "n" ++ (show i)

314+footnoteID i = "n" ++ show i

315

316linkID :: Int -> String

317−linkID i = "l" ++ (show i)

317+linkID i = "l" ++ show i

318

319-- | Convert a block-level Pandoc's element to FictionBook XML representation.

320blockToXml :: PandocMonad m => Block -> FBM m [Content]

323-- title beginning with fig: indicates that the image is a figure

324blockToXml (Para [Image atr alt (src,'f':'i':'g':':':tit)]) =

325 insertImage NormalImage (Image atr alt (src,tit))

326−blockToXml (Para ss) = liftM (list . el "p") $ cMapM toXml ss

326+blockToXml (Para ss) = (list . el "p") <$> cMapM toXml ss

327blockToXml (CodeBlock _ s) = return . spaceBeforeAfter .

328 map (el "p" . el "code") . lines $ s

329blockToXml b@(RawBlock _ _) = do

330 report $ BlockNotRendered b

331 return []

332blockToXml (Div _ bs) = cMapM blockToXml bs

333−blockToXml (BlockQuote bs) = liftM (list . el "cite") $ cMapM blockToXml bs

333+blockToXml (BlockQuote bs) = (list . el "cite") <$> cMapM blockToXml bs

334blockToXml (LineBlock lns) = blockToXml $ linesToPara lns

335blockToXml (OrderedList a bss) = do

336 state <- get

341 itemtext <- cMapM blockToXml . paraToPlain $ bs

342 modify (\s -> s { parentListMarker = pmrk }) -- old parent marker

343 return . el "p" $ [ txt mrk, txt " " ] ++ itemtext

344− mapM (uncurry mkitem) (zip markers bss)

344+ zipWithM mkitem markers bss

345blockToXml (BulletList bss) = do

346 state <- get

347 let level = parentBulletLevel state

348 let pmrk = parentListMarker state

349 let prefix = replicate (length pmrk) ' '

350 let bullets = ["\x2022", "\x25e6", "*", "\x2043", "\x2023"]

351− let mrk = prefix ++ bullets !! (level `mod` (length bullets))

351+ let mrk = prefix ++ bullets !! (level `mod` length bullets)

352 let mkitem bs = do

353− modify (\s -> s { parentBulletLevel = (level+1) })

353+ modify (\s -> s { parentBulletLevel = level+1 })

354 itemtext <- cMapM blockToXml . paraToPlain $ bs

355 modify (\s -> s { parentBulletLevel = level }) -- restore bullet level

356− return $ el "p" $ [ txt (mrk ++ " ") ] ++ itemtext

356+ return $ el "p" $ txt (mrk ++ " ") : itemtext

357 mapM mkitem bss

358blockToXml (DefinitionList defs) =

359 cMapM mkdef defs

370 needsBreak (Para _) = False

371 needsBreak (Plain ins) = LineBreak `notElem` ins

372 needsBreak _ = True

373−blockToXml h@(Header _ _ _) = do

373+blockToXml h@Header{} = do

374 -- should not occur after hierarchicalize, except inside lists/blockquotes

375 report $ BlockNotRendered h

376 return []

381blockToXml (Table caption aligns _ headers rows) = do

382 hd <- mkrow "th" headers aligns

383 bd <- mapM (\r -> mkrow "td" r aligns) rows

384− c <- return . el "emphasis" =<< cMapM toXml caption

384+ c <- el "emphasis" <$> cMapM toXml caption

385 return [el "table" (hd : bd), el "p" c]

386 where

387 mkrow :: PandocMonad m => String -> [TableCell] -> [Alignment] -> FBM m Content

388 mkrow tag cells aligns' =

389− (el "tr") `liftM` (mapM (mkcell tag) (zip cells aligns'))

389+ el "tr" <$> mapM (mkcell tag) (zip cells aligns')

390 --

391 mkcell :: PandocMonad m => String -> (TableCell, Alignment) -> FBM m Content

392 mkcell tag (cell, align) = do

405paraToPlain :: [Block] -> [Block]

406paraToPlain [] = []

407paraToPlain (Para inlines : rest) =

408− let p = (Plain (inlines ++ [LineBreak]))

408+ let p = Plain (inlines ++ [LineBreak])

409 in p : paraToPlain rest

410paraToPlain (p:rest) = p : paraToPlain rest

411

418 spacer :: String

419 spacer = replicate 4 ' '

420 --

421− indentBlock (Plain ins) = Plain ((Str spacer):ins)

421+ indentBlock (Plain ins) = Plain (Str spacer:ins)

422− indentBlock (Para ins) = Para ((Str spacer):ins)

422+ indentBlock (Para ins) = Para (Str spacer:ins)

423 indentBlock (CodeBlock a s) =

424 let s' = unlines . map (spacer++) . lines $ s

425 in CodeBlock a s'

429 -- indent every (explicit) line

430 indentLines :: [Inline] -> [Inline]

431 indentLines ins = let lns = split isLineBreak ins :: [[Inline]]

432− in intercalate [LineBreak] $ map ((Str spacer):) lns

432+ in intercalate [LineBreak] $ map (Str spacer:) lns

433

434-- | Convert a Pandoc's Inline element to FictionBook XML representation.

435toXml :: PandocMonad m => Inline -> FBM m [Content]

473 ( [ attr ("l","href") ('#':ln_id)

474 , uattr "type" "note" ]

475 , ln_ref) ]

476−toXml img@(Image _ _ _) = insertImage InlineImage img

476+toXml img@Image{} = insertImage InlineImage img

477toXml (Note bs) = do

478 fns <- footnotes `liftM` get

479 let n = 1 + length fns

487

488insertMath :: PandocMonad m => ImageMode -> String -> FBM m [Content]

489insertMath immode formula = do

490− htmlMath <- return . writerHTMLMathMethod . writerOptions =<< get

490+ htmlMath <- fmap (writerHTMLMathMethod . writerOptions) get

491 case htmlMath of

492 WebTeX url -> do

493 let alt = [Code nullAttr formula]

531 Nothing -> c' -- end of document

532 --

533 isImage :: Content -> Bool

534− isImage (Elem e) = (elName e) == (uname "image")

534+ isImage (Elem e) = elName e == uname "image"

535 isImage _ = False

536 --

537− isMissing (Elem img@(Element _ _ _ _)) =

537+ isMissing (Elem img@Element{}) =

538 let imgAttrs = elAttribs img

539 badAttrs = map (attr ("l","href")) missingHrefs

540 in any (`elem` imgAttrs) badAttrs

541 isMissing _ = False

542 --

543 replaceNode :: Content -> Content

544− replaceNode n@(Elem img@(Element _ _ _ _)) =

544+ replaceNode n@(Elem img@Element{}) =

545 let attrs = elAttribs img

546 alt = getAttrVal attrs (uname "alt")

547 imtype = getAttrVal attrs (qname "l" "type")

572-- | Convert an 'Inline' to plaintext.

573plain :: Inline -> String

574plain (Str s) = s

575−plain (Emph ss) = concat (map plain ss)

575+plain (Emph ss) = concatMap plain ss

576−plain (Span _ ss) = concat (map plain ss)

576+plain (Span _ ss) = concatMap plain ss

577−plain (Strong ss) = concat (map plain ss)

577+plain (Strong ss) = concatMap plain ss

578−plain (Strikeout ss) = concat (map plain ss)

578+plain (Strikeout ss) = concatMap plain ss

579−plain (Superscript ss) = concat (map plain ss)

579+plain (Superscript ss) = concatMap plain ss

580−plain (Subscript ss) = concat (map plain ss)

580+plain (Subscript ss) = concatMap plain ss

581−plain (SmallCaps ss) = concat (map plain ss)

581+plain (SmallCaps ss) = concatMap plain ss

582−plain (Quoted _ ss) = concat (map plain ss)

582+plain (Quoted _ ss) = concatMap plain ss

583−plain (Cite _ ss) = concat (map plain ss) -- FIXME

583+plain (Cite _ ss) = concatMap plain ss -- FIXME

584plain (Code _ s) = s

585plain Space = " "

586plain SoftBreak = " "

588plain (Math _ s) = s

589plain (RawInline _ _) = ""

590plain (Link _ text (url,_)) = concat (map plain text ++ [" <", url, ">"])

591−plain (Image _ alt _) = concat (map plain alt)

591+plain (Image _ alt _) = concatMap plain alt

592plain (Note _) = "" -- FIXME

593

594-- | Create an XML element.

610

611-- | Create an XML attribute with an unqualified name.

612uattr :: String -> String -> Text.XML.Light.Attr

613−uattr name val = Attr (uname name) val

613+uattr name = Attr (uname name)

614

615-- | Create an XML attribute with a qualified name from given namespace.

616attr :: (String, String) -> String -> Text.XML.Light.Attr

617−attr (ns, name) val = Attr (qname ns name) val

617+attr (ns, name) = Attr (qname ns name)

618

619-- | Unqualified name

620uname :: String -> QName