@@ -41,48 +41,64 @@ import Text.HTML.TagSoup
4141import Text.HTML.TagSoup.Match
4242import Text.Pandoc.Definition
4343import qualified Text.Pandoc.Builder as B
44−import Text.Pandoc.Builder (HasMeta (..), Blocks, Inlines, trimInlines)
45−import Text.Pandoc.Shared
46−import Text.Pandoc.Options
47−import Text.Pandoc.Parsing
48−import Data.Maybe ( fromMaybe, isJust )
49−import Data.List ( intercalate )
44+import Text.Pandoc.Builder (Blocks, Inlines, trimInlines, HasMeta(..))
45+import Text.Pandoc.Shared ( extractSpaces, renderTags'
46+ , escapeURI, safeRead )
47+import Text.Pandoc.Options (ReaderOptions(readerParseRaw, readerTrace)
48+ , Extension (Ext_epub_html_exts))
49+import Text.Pandoc.Parsing hiding ((<|>))
50+import Text.Pandoc.Walk
51+import Data.Maybe ( fromMaybe, isJust)
52+import Data.List ( intercalate, isInfixOf )
5053import Data.Char ( isDigit )
51−import Control.Monad ( liftM, guard, when, mzero )
52−import Control.Applicative ( (<$>), (<$), (<*) )
53−import Data.Monoid
54+import Control.Monad ( liftM, guard, when, mzero, void, unless )
55+import Control.Arrow ((***))
56+import Control.Applicative ( (<$>), (<$), (<*), (*>), (<|>))
57+import Data.Monoid (mconcat, Monoid, mempty, (<>), First (..))
5458import Text.Printf (printf)
5559import Debug.Trace (trace)
56−import Data.Default (Default (..))
57−import Control.Monad.Reader (Reader, runReader, asks, local, ask)
60+import Text.TeXMath (readMathML, writeTeXMath)
61+import Data.Default (Default (..), def)
62+import Control.Monad.Reader (Reader,ask, asks, local, runReader)
5863
59−isSpace :: Char -> Bool
60−isSpace ' ' = True
61−isSpace '\t' = True
62−isSpace '\n' = True
63−isSpace _ = False
6464
6565-- | Convert HTML-formatted string to 'Pandoc' document.
6666readHtml :: ReaderOptions -- ^ Reader options
6767 -> String -- ^ String to parse (assumes @'\n'@ line endings)
6868 -> Pandoc
6969readHtml 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
7171 Left err' -> error $ "\nError at " ++ show err'
7272 Right result -> result
73− where tags = canonicalizeTags $
73+ where tags = stripPrefixes . canonicalizeTags $
7474 parseTagsOptions parseOptions{ optTagPosition = True } inp
7575 parseDoc = do
7676 blocks <- (fixPlains False) . mconcat <$> manyTill block eof
7777 meta <- stateMeta . parserState <$> getState
78− return $ Pandoc meta (B.toList blocks)
78+ bs' <- replaceNotes (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
7989
8090data HTMLState =
8191 HTMLState
82− { parserState :: ParserState
92+ { parserState :: ParserState,
93+ noteTable :: [(String, Blocks)]
8394 }
8495
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})
86102
87103type HTMLParser s = ParserT s HTMLState (Reader HTMLLocal)
88104
@@ -110,7 +126,11 @@ block = do
110126 tr <- getOption readerTrace
111127 pos <- getPosition
112128 res <- choice
113− [ pPara
129+ [ eSwitch
130+ , eSection
131+ , mempty <$ eFootnote
132+ , mempty <$ eTOC
133+ , pPara
114134 , pHeader
115135 , pBlockQuote
116136 , pCodeBlock
@@ -127,6 +147,64 @@ block = do
127147 (take 60 $ show $ B.toList res)) (return ())
128148 return res
129149
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+
130208pList :: TagParser Blocks
131209pList = pBulletList <|> pOrderedList <|> pDefinitionList
132210
@@ -230,13 +308,35 @@ pHtmlBlock t = try $ do
230308 contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
231309 return $ renderTags' $ [open] ++ contents ++ [TagClose t]
232310
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+
233333pHeader :: TagParser Blocks
234334pHeader = try $ do
235335 TagOpen tagtype attr <- pSatisfy $
236336 tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
237337 (const True)
238338 let bodyTitle = TagOpen tagtype attr ~== TagOpen "h1" [("class","title")]
239− let level = read (drop 1 tagtype)
339+ level <- headerLevel tagtype
240340 contents <- trimInlines . mconcat <$> manyTill inline (pCloses tagtype <|> eof)
241341 let ident = fromMaybe "" $ lookup "id" attr
242342 let classes = maybe [] words $ lookup "class" attr
@@ -336,7 +436,8 @@ pCodeBlock = try $ do
336436
337437inline :: TagParser Inlines
338438inline = choice
339− [ pTagText
439+ [ eNoteref
440+ , pTagText
340441 , pQ
341442 , pEmph
342443 , pStrong
@@ -348,6 +449,7 @@ inline = choice
348449 , pImage
349450 , pCode
350451 , pSpan
452+ , pMath False
351453 , pRawHtmlInline
352454 ]
353455
@@ -620,8 +722,11 @@ blockDocBookTags = ["calloutlist", "bibliolist", "glosslist", "itemizedlist",
620722 "classsynopsis", "blockquote", "epigraph", "msgset",
621723 "sidebar", "title"]
622724
725+epubTags :: [String]
726+epubTags = ["case", "switch", "default"]
727+
623728blockTags :: [String]
624−blockTags = blockHtmlTags ++ blockDocBookTags
729+blockTags = blockHtmlTags ++ blockDocBookTags ++ epubTags
625730
626731isInlineTag :: Tag String -> Bool
627732isInlineTag t = tagOpen isInlineTagName (const True) t ||
@@ -720,9 +825,32 @@ htmlTag f = try $ do
720825mkAttr :: [(String, String)] -> Attr
721826mkAttr attr = (attribsId, attribsClasses, attribsKV)
722827 where attribsId = fromMaybe "" $ lookup "id" attr
723− attribsClasses = words $ fromMaybe "" $ lookup "class" attr
828+ attribsClasses = (words $ fromMaybe "" $ lookup "class" attr) ++ epubTypes
724829 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
725835
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
726854
727855-- Instances
728856
@@ -736,17 +864,39 @@ instance HasReaderOptions HTMLState where
736864 extractReaderOptions = extractReaderOptions . parserState
737865
738866instance Default HTMLState where
739− def = HTMLState def
867+ def = HTMLState def []
740868
741869instance HasMeta HTMLState where
742870 setMeta s b st = st {parserState = setMeta s b $ parserState st}
743871 deleteMeta s st = st {parserState = deleteMeta s $ parserState st}
744872
745873instance Default HTMLLocal where
746− def = HTMLLocal NoQuote
874+ def = HTMLLocal NoQuote False
747875
748876instance HasLastStrPosition HTMLState where
749877 setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
750878 getLastStrPos = getLastStrPos . parserState
751879
752880
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+-}