From 45479114e88a351fc63bb8eff142bb10cfd2c661 Mon Sep 17 00:00:00 2001
From: Ole Martin Ruud <barskern@outlook.com>
Date: Fri, 25 Oct 2019 07:27:49 +0200
Subject: HTML reader/writer: Better handling of <q> with cite attribute
 (#5837)

* HTML reader: Handle cite attribute for quotes.  If a `<q>` tag has a `cite` attribute, we interpret it as a Quoted element with an inner Span.  Closes #5798

* Refactor url canonicalization into a helper function

* Modify HTML writer to handle quote with cite.

[0]: https://developer.mozilla.org/en-US/docs/Web/HTML/Element/q
---
 src/Text/Pandoc/Readers/HTML.hs | 57 ++++++++++++++++++++++++-----------------
 src/Text/Pandoc/Writers/HTML.hs | 12 +++++++--
 2 files changed, 44 insertions(+), 25 deletions(-)

(limited to 'src')

diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index b6f88d3a9..1ed61591b 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -684,19 +684,27 @@ pSelfClosing f g = do
   return open
 
 pQ :: PandocMonad m => TagParser m Inlines
-pQ = do
-  context <- asks quoteContext
-  let quoteType = case context of
-                       InDoubleQuote -> SingleQuote
-                       _             -> DoubleQuote
-  let innerQuoteContext = if quoteType == SingleQuote
-                             then InSingleQuote
-                             else InDoubleQuote
-  let constructor = case quoteType of
-                            SingleQuote -> B.singleQuoted
-                            DoubleQuote -> B.doubleQuoted
-  withQuoteContext innerQuoteContext $
-    pInlinesInTags "q" constructor
+pQ = choice $ map try [citedQuote, normalQuote]
+  where citedQuote = do
+          tag <- pSatisfy $ tagOpenLit "q" (any ((=="cite") . fst))
+
+          url <- canonicalizeUrl $ T.unpack $ fromAttrib "cite" tag
+          let uid = fromMaybe (T.unpack $ fromAttrib "name" tag) $
+                       maybeFromAttrib "id" tag
+          let cls = words $ T.unpack $ fromAttrib "class" tag
+
+          makeQuote $ B.spanWith (uid, cls, [("cite", escapeURI url)])
+        normalQuote = do
+          pSatisfy $ tagOpenLit "q" (const True)
+          makeQuote id
+        makeQuote wrapper = do
+          ctx <- asks quoteContext
+          let (constructor, innerContext) = case ctx of
+                        InDoubleQuote -> (B.singleQuoted, InSingleQuote)
+                        _             -> (B.doubleQuoted, InDoubleQuote)
+
+          content <- withQuoteContext innerContext (mconcat <$> manyTill inline (pCloses "q"))
+          return $ extractSpaces (constructor . wrapper) content
 
 pEmph :: PandocMonad m => TagParser m Inlines
 pEmph = pInlinesInTags "em" B.emph <|> pInlinesInTags "i" B.emph
@@ -757,21 +765,13 @@ pLink = try $ do
        Nothing   ->
          return $ extractSpaces (B.spanWith (uid, cls, [])) lab
        Just url' -> do
-         mbBaseHref <- baseHref <$> getState
-         let url = case (parseURIReference url', mbBaseHref) of
-                        (Just rel, Just bs) ->
-                          show (rel `nonStrictRelativeTo` bs)
-                        _                   -> url'
+         url <- canonicalizeUrl url'
          return $ extractSpaces (B.linkWith (uid, cls, []) (escapeURI url) title) lab
 
 pImage :: PandocMonad m => TagParser m Inlines
 pImage = do
   tag <- pSelfClosing (=="img") (isJust . lookup "src")
-  mbBaseHref <- baseHref <$> getState
-  let url' = T.unpack $ fromAttrib "src" tag
-  let url = case (parseURIReference url', mbBaseHref) of
-                 (Just rel, Just bs) -> show (rel `nonStrictRelativeTo` bs)
-                 _                   -> url'
+  url <- canonicalizeUrl $ T.unpack $ fromAttrib "src" tag
   let title = T.unpack $ fromAttrib "title" tag
   let alt = T.unpack $ fromAttrib "alt" tag
   let uid = T.unpack $ fromAttrib "id" tag
@@ -1292,6 +1292,17 @@ isSpace '\n' = True
 isSpace '\r' = True
 isSpace _    = False
 
+-- Utilities
+
+-- | Adjusts a url according to the document's base URL.
+canonicalizeUrl :: PandocMonad m => String -> TagParser m String
+canonicalizeUrl url = do
+  mbBaseHref <- baseHref <$> getState
+  return $ case (parseURIReference url, mbBaseHref) of
+                (Just rel, Just bs) -> show (rel `nonStrictRelativeTo` bs)
+                _                   -> url
+
+
 -- Instances
 
 instance HasMacros HTMLState where
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index a1a617829..08d8345b0 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                 #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -1047,10 +1048,17 @@ inlineToHtml opts inline = do
                                               strToHtml "’")
                               DoubleQuote -> (strToHtml "“",
                                               strToHtml "”")
-                        in  if writerHtmlQTags opts
+
+                        in if writerHtmlQTags opts
                                then do
                                  modify $ \st -> st{ stQuotes = True }
-                                 H.q `fmap` inlineListToHtml opts lst
+                                 let (maybeAttr, lst') = case lst of
+                                      [Span attr@(_, _, kvs) cs]
+                                        | any ((=="cite") . fst) kvs
+                                          -> (Just attr, cs)
+                                      cs -> (Nothing, cs)
+                                 H.q `fmap` inlineListToHtml opts lst'
+                                   >>= maybe return (addAttrs opts) maybeAttr
                                else (\x -> leftQuote >> x >> rightQuote)
                                     `fmap` inlineListToHtml opts lst
     (Math t str) -> do
-- 
cgit v1.2.3