git.iko.soy/typeable/pandoc
on master help sign in
HTML Reader: Extended HTML Reader to recognise EPUB specific elements
266e197Matthew Pickering
src/Text/Pandoc/Readers/HTML.hs+178−28
compare with master
unifiedsplit
@@ -41,48 +41,64 @@ import Text.HTML.TagSoup
41import Text.HTML.TagSoup.Match
41import Text.HTML.TagSoup.Match
42import Text.Pandoc.Definition
42import Text.Pandoc.Definition
43import qualified Text.Pandoc.Builder as B
43import qualified Text.Pandoc.Builder as B
44−import Text.Pandoc.Builder (HasMeta (..), Blocks, Inlines, trimInlines)
44+import Text.Pandoc.Builder (Blocks, Inlines, trimInlines, HasMeta(..))
45−import Text.Pandoc.Shared
45+import Text.Pandoc.Shared ( extractSpaces, renderTags'
46+ , escapeURI, safeRead )
46−import Text.Pandoc.Options
47+import Text.Pandoc.Options (ReaderOptions(readerParseRaw, readerTrace)
48+ , Extension (Ext_epub_html_exts))
47−import Text.Pandoc.Parsing
49+import Text.Pandoc.Parsing hiding ((<|>))
50+import Text.Pandoc.Walk
48−import Data.Maybe ( fromMaybe, isJust )
51+import Data.Maybe ( fromMaybe, isJust)
49−import Data.List ( intercalate )
52+import Data.List ( intercalate, isInfixOf )
50import Data.Char ( isDigit )
53import Data.Char ( isDigit )
51−import Control.Monad ( liftM, guard, when, mzero )
54+import Control.Monad ( liftM, guard, when, mzero, void, unless )
55+import Control.Arrow ((***))
52−import Control.Applicative ( (<$>), (<$), (<*) )
56+import Control.Applicative ( (<$>), (<$), (<*), (*>), (<|>))
53−import Data.Monoid
57+import Data.Monoid (mconcat, Monoid, mempty, (<>), First (..))
54import Text.Printf (printf)
58import Text.Printf (printf)
55import Debug.Trace (trace)
59import Debug.Trace (trace)
60+import Text.TeXMath (readMathML, writeTeXMath)
56−import Data.Default (Default (..))
61+import Data.Default (Default (..), def)
57−import Control.Monad.Reader (Reader, runReader, asks, local, ask)
62+import Control.Monad.Reader (Reader,ask, asks, local, runReader)
58
63
59−isSpace :: Char -> Bool
60−isSpace ' ' = True
61−isSpace '\t' = True
62−isSpace '\n' = True
63−isSpace _ = False
64
64
65-- | Convert HTML-formatted string to 'Pandoc' document.
65-- | Convert HTML-formatted string to 'Pandoc' document.
66readHtml :: ReaderOptions -- ^ Reader options
66readHtml :: ReaderOptions -- ^ Reader options
67 -> String -- ^ String to parse (assumes @'\n'@ line endings)
67 -> String -- ^ String to parse (assumes @'\n'@ line endings)
68 -> Pandoc
68 -> Pandoc
69readHtml opts inp =
69readHtml opts inp =
70− case flip runReader def $ runParserT parseDoc (HTMLState def{ stateOptions = opts } ) "source" tags of
70+ case flip runReader def $ runParserT parseDoc (HTMLState def{ stateOptions = opts } []) "source" tags of
71 Left err' -> error $ "\nError at " ++ show err'
71 Left err' -> error $ "\nError at " ++ show err'
72 Right result -> result
72 Right result -> result
73− where tags = canonicalizeTags $
73+ where tags = stripPrefixes . canonicalizeTags $
74 parseTagsOptions parseOptions{ optTagPosition = True } inp
74 parseTagsOptions parseOptions{ optTagPosition = True } inp
75 parseDoc = do
75 parseDoc = do
76 blocks <- (fixPlains False) . mconcat <$> manyTill block eof
76 blocks <- (fixPlains False) . mconcat <$> manyTill block eof
77 meta <- stateMeta . parserState <$> getState
77 meta <- stateMeta . parserState <$> getState
78+ bs' <- replaceNotes (B.toList blocks)
78− return $ Pandoc meta (B.toList blocks)
79+ return $ Pandoc meta bs'
80+
81+replaceNotes :: [Block] -> TagParser [Block]
82+replaceNotes = walkM replaceNotes'
83+
84+replaceNotes' :: Inline -> TagParser Inline
85+replaceNotes' (RawInline (Format "noteref") ref) = maybe (Str "") (Note . B.toList) . lookup ref <$> getNotes
86+ where
87+ getNotes = noteTable <$> getState
88+replaceNotes' x = return x
79
89
80data HTMLState =
90data HTMLState =
81 HTMLState
91 HTMLState
82− { parserState :: ParserState
92+ { parserState :: ParserState,
93+ noteTable :: [(String, Blocks)]
83 }
94 }
84
95
85−data HTMLLocal = HTMLLocal { quoteContext :: QuoteContext }
96+data HTMLLocal = HTMLLocal { quoteContext :: QuoteContext
97+ , inChapter :: Bool -- ^ Set if in chapter section
98+ }
99+
100+setInChapter :: HTMLParser s a -> HTMLParser s a
101+setInChapter = local (\s -> s {inChapter = True})
86
102
87type HTMLParser s = ParserT s HTMLState (Reader HTMLLocal)
103type HTMLParser s = ParserT s HTMLState (Reader HTMLLocal)
88
104
@@ -110,7 +126,11 @@ block = do
110 tr <- getOption readerTrace
126 tr <- getOption readerTrace
111 pos <- getPosition
127 pos <- getPosition
112 res <- choice
128 res <- choice
129+ [ eSwitch
130+ , eSection
131+ , mempty <$ eFootnote
132+ , mempty <$ eTOC
113− [ pPara
133+ , pPara
114 , pHeader
134 , pHeader
115 , pBlockQuote
135 , pBlockQuote
116 , pCodeBlock
136 , pCodeBlock
@@ -127,6 +147,64 @@ block = do
127 (take 60 $ show $ B.toList res)) (return ())
147 (take 60 $ show $ B.toList res)) (return ())
128 return res
148 return res
129
149
150+namespaces :: [(String, TagParser Blocks)]
151+namespaces = [(mathMLNamespace, B.para <$> pMath True)]
152+
153+mathMLNamespace :: String
154+mathMLNamespace = "http://www.w3.org/1998/Math/MathML"
155+
156+eSwitch :: TagParser Blocks
157+eSwitch = try $ do
158+ guardEnabled Ext_epub_html_exts
159+ pSatisfy (~== TagOpen "switch" [])
160+ cases <- getFirst . mconcat <$>
161+ manyTill (First <$> (eCase <* skipMany pBlank) )
162+ (lookAhead $ try $ pSatisfy (~== TagOpen "default" []))
163+ skipMany pBlank
164+ fallback <- pInTags "default" ( skipMany pBlank *> block <* skipMany pBlank )
165+ skipMany pBlank
166+ pSatisfy (~== TagClose "switch")
167+ return (fromMaybe fallback cases)
168+
169+eCase :: TagParser (Maybe Blocks)
170+eCase = do
171+ skipMany pBlank
172+ TagOpen _ attr <- lookAhead $ pSatisfy $ (~== TagOpen "case" [])
173+ case (flip lookup namespaces) =<< lookup "required-namespace" attr of
174+ Just p -> Just <$> (pInTags "case" (skipMany pBlank *> p <* skipMany pBlank))
175+ Nothing -> Nothing <$ manyTill pAnyTag (pSatisfy (~== TagClose "case"))
176+
177+eFootnote :: TagParser ()
178+eFootnote = try $ do
179+ let notes = ["footnote", "rearnote"]
180+ guardEnabled Ext_epub_html_exts
181+ (TagOpen tag attr) <- lookAhead $ pAnyTag
182+ guard (maybe False (flip elem notes) (lookup "type" attr))
183+ let ident = fromMaybe "" (lookup "id" attr)
184+ content <- pInTags tag block
185+ addNote ident content
186+
187+addNote :: String -> Blocks -> TagParser ()
188+addNote uid cont = updateState (\s -> s {noteTable = (uid, cont) : (noteTable s)})
189+
190+eNoteref :: TagParser Inlines
191+eNoteref = try $ do
192+ guardEnabled Ext_epub_html_exts
193+ TagOpen tag attr <- lookAhead $ pAnyTag
194+ guard (maybe False (== "noteref") (lookup "type" attr))
195+ let ident = maybe "" (dropWhile (== '#')) (lookup "href" attr)
196+ guard (not (null ident))
197+ pInTags tag block
198+ return $ B.rawInline "noteref" ident
199+
200+-- Strip TOC if there is one, better to generate again
201+eTOC :: TagParser ()
202+eTOC = try $ do
203+ guardEnabled Ext_epub_html_exts
204+ (TagOpen tag attr) <- lookAhead $ pAnyTag
205+ guard (maybe False (== "toc") (lookup "type" attr))
206+ void (pInTags tag block)
207+
130pList :: TagParser Blocks
208pList :: TagParser Blocks
131pList = pBulletList <|> pOrderedList <|> pDefinitionList
209pList = pBulletList <|> pOrderedList <|> pDefinitionList
132
210
@@ -230,13 +308,35 @@ pHtmlBlock t = try $ do
230 contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
308 contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
231 return $ renderTags' $ [open] ++ contents ++ [TagClose t]
309 return $ renderTags' $ [open] ++ contents ++ [TagClose t]
232
310
311+-- Sets chapter context
312+eSection :: TagParser Blocks
313+eSection = try $ do
314+ let matchChapter as = maybe False (isInfixOf "chapter") (lookup "type" as)
315+ let sectTag = tagOpen (`elem` sectioningContent) matchChapter
316+ TagOpen tag _ <- lookAhead $ pSatisfy sectTag
317+ setInChapter (pInTags tag block)
318+
319+headerLevel :: String -> TagParser Int
320+headerLevel tagtype = do
321+ let level = read (drop 1 tagtype)
322+ (try $ do
323+ guardEnabled Ext_epub_html_exts
324+ asks inChapter >>= guard
325+ return (level - 1))
326+ <|>
327+ return level
328+
329+
330+
331+
332+
233pHeader :: TagParser Blocks
333pHeader :: TagParser Blocks
234pHeader = try $ do
334pHeader = try $ do
235 TagOpen tagtype attr <- pSatisfy $
335 TagOpen tagtype attr <- pSatisfy $
236 tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
336 tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
237 (const True)
337 (const True)
238 let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
338 let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
239− let level = read (drop 1 tagtype)
339+ level <- headerLevel tagtype
240 contents <- trimInlines . mconcat <$> manyTill inline (pCloses tagtype <|> eof)
340 contents <- trimInlines . mconcat <$> manyTill inline (pCloses tagtype <|> eof)
241 let ident = fromMaybe "" $ lookup "id" attr
341 let ident = fromMaybe "" $ lookup "id" attr
242 let classes = maybe [] words $ lookup "class" attr
342 let classes = maybe [] words $ lookup "class" attr
@@ -336,7 +436,8 @@ pCodeBlock = try $ do
336
436
337inline :: TagParser Inlines
437inline :: TagParser Inlines
338inline = choice
438inline = choice
439+ [ eNoteref
339− [ pTagText
440+ , pTagText
340 , pQ
441 , pQ
341 , pEmph
442 , pEmph
342 , pStrong
443 , pStrong
@@ -348,6 +449,7 @@ inline = choice
348 , pImage
449 , pImage
349 , pCode
450 , pCode
350 , pSpan
451 , pSpan
452+ , pMath False
351 , pRawHtmlInline
453 , pRawHtmlInline
352 ]
454 ]
353
455
@@ -620,8 +722,11 @@ blockDocBookTags = ["calloutlist", "bibliolist", "glosslist", "itemizedlist",
620 "classsynopsis", "blockquote", "epigraph", "msgset",
722 "classsynopsis", "blockquote", "epigraph", "msgset",
621 "sidebar", "title"]
723 "sidebar", "title"]
622
724
725+epubTags :: [String]
726+epubTags = ["case", "switch", "default"]
727+
623blockTags :: [String]
728blockTags :: [String]
624−blockTags = blockHtmlTags ++ blockDocBookTags
729+blockTags = blockHtmlTags ++ blockDocBookTags ++ epubTags
625
730
626isInlineTag :: Tag String -> Bool
731isInlineTag :: Tag String -> Bool
627isInlineTag t = tagOpen isInlineTagName (const True) t ||
732isInlineTag t = tagOpen isInlineTagName (const True) t ||
@@ -720,9 +825,32 @@ htmlTag f = try $ do
720mkAttr :: [(String, String)] -> Attr
825mkAttr :: [(String, String)] -> Attr
721mkAttr attr = (attribsId, attribsClasses, attribsKV)
826mkAttr attr = (attribsId, attribsClasses, attribsKV)
722 where attribsId = fromMaybe "" $ lookup "id" attr
827 where attribsId = fromMaybe "" $ lookup "id" attr
723− attribsClasses = words $ fromMaybe "" $ lookup "class" attr
828+ attribsClasses = (words $ fromMaybe "" $ lookup "class" attr) ++ epubTypes
724 attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr
829 attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr
830+ epubTypes = words $ fromMaybe "" $ lookup "epub:type" attr
831+
832+-- Strip namespace prefixes
833+stripPrefixes :: [Tag String] -> [Tag String]
834+stripPrefixes = map stripPrefix
725
835
836+stripPrefix :: Tag String -> Tag String
837+stripPrefix (TagOpen s as) =
838+ TagOpen (stripPrefix' s) (map (stripPrefix' *** id) as)
839+stripPrefix (TagClose s) = TagClose (stripPrefix' s)
840+stripPrefix x = x
841+
842+stripPrefix' :: String -> String
843+stripPrefix' s =
844+ case span (/= ':') s of
845+ (_, "") -> s
846+ (_, (_:ts)) -> ts
847+
848+isSpace :: Char -> Bool
849+isSpace ' ' = True
850+isSpace '\t' = True
851+isSpace '\n' = True
852+isSpace '\r' = True
853+isSpace _ = False
726
854
727-- Instances
855-- Instances
728
856
@@ -736,17 +864,39 @@ instance HasReaderOptions HTMLState where
736 extractReaderOptions = extractReaderOptions . parserState
864 extractReaderOptions = extractReaderOptions . parserState
737
865
738instance Default HTMLState where
866instance Default HTMLState where
739− def = HTMLState def
867+ def = HTMLState def []
740
868
741instance HasMeta HTMLState where
869instance HasMeta HTMLState where
742 setMeta s b st = st {parserState = setMeta s b $ parserState st}
870 setMeta s b st = st {parserState = setMeta s b $ parserState st}
743 deleteMeta s st = st {parserState = deleteMeta s $ parserState st}
871 deleteMeta s st = st {parserState = deleteMeta s $ parserState st}
744
872
745instance Default HTMLLocal where
873instance Default HTMLLocal where
746− def = HTMLLocal NoQuote
874+ def = HTMLLocal NoQuote False
747
875
748instance HasLastStrPosition HTMLState where
876instance HasLastStrPosition HTMLState where
749 setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
877 setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
750 getLastStrPos = getLastStrPos . parserState
878 getLastStrPos = getLastStrPos . parserState
751
879
752
880
881+-- EPUB Specific
882+--
883+--
884+sectioningContent :: [String]
885+sectioningContent = ["article", "aside", "nav", "section"]
886+
887+{-
888+groupingContent :: [String]
889+groupingContent = ["p", "hr", "pre", "blockquote", "ol"
890+ , "ul", "li", "dl", "dt", "dt", "dd"
891+ , "figure", "figcaption", "div", "main"]
892+
893+
894+
895+types :: [(String, ([String], Int))]
896+types = -- Document divisions
897+ map (\s -> (s, (["section", "body"], 0)))
898+ ["volume", "part", "chapter", "division"]
899+ ++ -- Document section and components
900+ [
901+ ("abstract", ([], 0))]
902+-}