4547911 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

HTML reader/writer: Better handling of <q> with cite attribute (#5837)

4547911Ole Martin Ruud7 years ago

src/Text/Pandoc/Readers/HTML.hs+34−23

compare with master

unifiedsplit

@@ -684,19 +684,27 @@ pSelfClosing f g = do

684 return open

685

686pQ :: PandocMonad m => TagParser m Inlines

687−pQ = do

687+pQ = choice $ map try [citedQuote, normalQuote]

688+ where citedQuote = do

689+ tag <- pSatisfy $ tagOpenLit "q" (any ((=="cite") . fst))

690+

691+ url <- canonicalizeUrl $ T.unpack $ fromAttrib "cite" tag

692+ let uid = fromMaybe (T.unpack $ fromAttrib "name" tag) $

693+ maybeFromAttrib "id" tag

694+ let cls = words $ T.unpack $ fromAttrib "class" tag

695+

696+ makeQuote $ B.spanWith (uid, cls, [("cite", escapeURI url)])

697+ normalQuote = do

698+ pSatisfy $ tagOpenLit "q" (const True)

699+ makeQuote id

700+ makeQuote wrapper = do

688− context <- asks quoteContext

701+ ctx <- asks quoteContext

689− let quoteType = case context of

702+ let (constructor, innerContext) = case ctx of

690− InDoubleQuote -> SingleQuote

703+ InDoubleQuote -> (B.singleQuoted, InSingleQuote)

691− _ -> DoubleQuote

692− let innerQuoteContext = if quoteType == SingleQuote

693− then InSingleQuote

694− else InDoubleQuote

695− let constructor = case quoteType of

696− SingleQuote -> B.singleQuoted

697− DoubleQuote -> B.doubleQuoted

704+ _ -> (B.doubleQuoted, InDoubleQuote)

698− withQuoteContext innerQuoteContext $

705+

699− pInlinesInTags "q" constructor

706+ content <- withQuoteContext innerContext (mconcat <$> manyTill inline (pCloses "q"))

707+ return $ extractSpaces (constructor . wrapper) content

700

708

701pEmph :: PandocMonad m => TagParser m Inlines

709pEmph :: PandocMonad m => TagParser m Inlines

702pEmph = pInlinesInTags "em" B.emph <|> pInlinesInTags "i" B.emph

710pEmph = pInlinesInTags "em" B.emph <|> pInlinesInTags "i" B.emph

@@ -757,21 +765,13 @@ pLink = try $ do

757 Nothing ->

765 Nothing ->

758 return $ extractSpaces (B.spanWith (uid, cls, [])) lab

766 return $ extractSpaces (B.spanWith (uid, cls, [])) lab

759 Just url' -> do

767 Just url' -> do

760− mbBaseHref <- baseHref <$> getState

768+ url <- canonicalizeUrl url'

761− let url = case (parseURIReference url', mbBaseHref) of

762− (Just rel, Just bs) ->

763− show (rel `nonStrictRelativeTo` bs)

764− _ -> url'

765 return $ extractSpaces (B.linkWith (uid, cls, []) (escapeURI url) title) lab

769 return $ extractSpaces (B.linkWith (uid, cls, []) (escapeURI url) title) lab

766

770

767pImage :: PandocMonad m => TagParser m Inlines

771pImage :: PandocMonad m => TagParser m Inlines

768pImage = do

772pImage = do

769 tag <- pSelfClosing (=="img") (isJust . lookup "src")

773 tag <- pSelfClosing (=="img") (isJust . lookup "src")

770− mbBaseHref <- baseHref <$> getState

771− let url' = T.unpack $ fromAttrib "src" tag

774+ url <- canonicalizeUrl $ T.unpack $ fromAttrib "src" tag

772− let url = case (parseURIReference url', mbBaseHref) of

773− (Just rel, Just bs) -> show (rel `nonStrictRelativeTo` bs)

774− _ -> url'

775 let title = T.unpack $ fromAttrib "title" tag

776 let alt = T.unpack $ fromAttrib "alt" tag

777 let uid = T.unpack $ fromAttrib "id" tag

@@ -1292,6 +1292,17 @@ isSpace '\n' = True

1292isSpace '\r' = True

1293isSpace _ = False

1294

1295+-- Utilities

1296+

1297+-- | Adjusts a url according to the document's base URL.

1298+canonicalizeUrl :: PandocMonad m => String -> TagParser m String

1299+canonicalizeUrl url = do

1300+ mbBaseHref <- baseHref <$> getState

1301+ return $ case (parseURIReference url, mbBaseHref) of

1302+ (Just rel, Just bs) -> show (rel `nonStrictRelativeTo` bs)

1303+ _ -> url

1304+

1305+

1295-- Instances

1306-- Instances

1296

1307

1297instance HasMacros HTMLState where

1308instance HasMacros HTMLState where

src/Text/Pandoc/Writers/HTML.hs+10−2

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE MultiWayIf #-}

3{-# LANGUAGE MultiWayIf #-}

3{-# LANGUAGE NoImplicitPrelude #-}

4{-# LANGUAGE NoImplicitPrelude #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

@@ -1047,10 +1048,17 @@ inlineToHtml opts inline = do

1047 strToHtml "’")

1048 strToHtml "’")

1048 DoubleQuote -> (strToHtml "“",

1049 DoubleQuote -> (strToHtml "“",

1049 strToHtml "”")

1050 strToHtml "”")

1051+

1050− in if writerHtmlQTags opts

1052+ in if writerHtmlQTags opts

1051 then do

1053 then do

1052 modify $ \st -> st{ stQuotes = True }

1054 modify $ \st -> st{ stQuotes = True }

1055+ let (maybeAttr, lst') = case lst of

1056+ [Span attr@(_, _, kvs) cs]

1057+ | any ((=="cite") . fst) kvs

1058+ -> (Just attr, cs)

1059+ cs -> (Nothing, cs)

1053− H.q `fmap` inlineListToHtml opts lst

1060+ H.q `fmap` inlineListToHtml opts lst'

1061+ >>= maybe return (addAttrs opts) maybeAttr

1054 else (\x -> leftQuote >> x >> rightQuote)

1062 else (\x -> leftQuote >> x >> rightQuote)

1055 `fmap` inlineListToHtml opts lst

1063 `fmap` inlineListToHtml opts lst

1056 (Math t str) -> do

1064 (Math t str) -> do

test/Tests/Writers/HTML.hs+17

@@ -13,6 +13,11 @@ import Text.Pandoc.Builder

13html :: (ToPandoc a) => a -> String

14html = unpack . purely (writeHtml4String def{ writerWrapText = WrapNone }) . toPandoc

16+htmlQTags :: (ToPandoc a) => a -> String

17+htmlQTags = unpack

18+ . purely (writeHtml4String def{ writerWrapText = WrapNone, writerHtmlQTags = True })

19+ . toPandoc

20+

16{-

21{-

17 "my test" =: X =?> Y

22 "my test" =: X =?> Y

@@ -48,4 +53,16 @@ tests = [ testGroup "inline code"

48 definitionList [(mempty, [para $ text "foo bar"])]

53 definitionList [(mempty, [para $ text "foo bar"])]

49 =?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>"

54 =?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>"

50 ]

55 ]

56+ , testGroup "quotes"

57+ [ "quote with cite attribute (without q-tags)" =:

58+ doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))

59+ =?> "“<span cite=\"http://example.org\">examples</span>”"

60+ , tQ "quote with cite attribute (with q-tags)" $

61+ doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))

62+ =?> "<q cite=\"http://example.org\">examples</q>"

63+ ]

51 ]

64 ]

65+ where

66+ tQ :: (ToString a, ToPandoc a)

67+ => String -> (a, String) -> TestTree

68+ tQ = test htmlQTags

test/html-reader.html+4

@@ -81,6 +81,10 @@ span.pandocNoteMarker { }

81</blockquote>

82<p>And a following paragraph.</p>

83<hr />

84+<h1>Inline quotes</h1>

85+<p>Normal text but then a <q cite="https://www.imdb.com/title/tt0062622/quotes/qt0396921">inline quote</q>.</p>

86+<p><q>Missing a cite attribute means its just normal text</q></p>

87+<hr />

84<h1>Code Blocks</h1>

88<h1>Code Blocks</h1>

85<p>Code:</p>

89<p>Code:</p>

86<pre><code>---- (should be four hyphens)

90<pre><code>---- (should be four hyphens)

test/html-reader.native+4

@@ -51,6 +51,10 @@ Pandoc (Meta {unMeta = fromList [("generator",MetaInlines [Str "pandoc"]),("titl

51 [Para [Str "Don't",Space,Str "quote",Space,Str "me."]]]

52,Para [Str "And",Space,Str "a",Space,Str "following",Space,Str "paragraph."]

53,HorizontalRule

54+,Header 1 ("inline-quotes",[],[]) [Str "Inline",Space,Str "quotes"]

55+,Para [Str "Normal",Space,Str "text",Space,Str "but",Space,Str "then",Space,Str "a",Space,Quoted DoubleQuote [Span ("",[],[("cite","https://www.imdb.com/title/tt0062622/quotes/qt0396921")]) [Str "inline",Space,Str "quote"]],Str "."]

56+,Para [Quoted DoubleQuote [Str "Missing",Space,Str "a",Space,Str "cite",Space,Str "attribute",Space,Str "means",Space,Str "its",Space,Str "just",Space,Str "normal",Space,Str "text"]]

57+,HorizontalRule

54,Header 1 ("code-blocks",[],[]) [Str "Code",Space,Str "Blocks"]

58,Header 1 ("code-blocks",[],[]) [Str "Code",Space,Str "Blocks"]

55,Para [Str "Code:"]

59,Para [Str "Code:"]

56,CodeBlock ("",[],[]) "---- (should be four hyphens)\n\nsub status {\n print \"working\";\n}\n\nthis code block is indented by one tab"

60,CodeBlock ("",[],[]) "---- (should be four hyphens)\n\nsub status {\n print \"working\";\n}\n\nthis code block is indented by one tab"