From f639b9ddfb60e1ce52e4e784e4f34d41466399a8 Mon Sep 17 00:00:00 2001
From: Lysxia <lysxia@gmail.com>
Date: Sun, 29 Mar 2020 15:09:10 -0400
Subject: [PATCH] Forbid spaces in anchors (#1148)

---
 haddock-library/src/Documentation/Haddock/Parser.hs      | 2 +-
 haddock-library/src/Documentation/Haddock/Types.hs       | 2 +-
 haddock-library/test/Documentation/Haddock/ParserSpec.hs | 9 +++++++--
 3 files changed, 9 insertions(+), 4 deletions(-)

diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 028422a704..23b2211e0c 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -227,7 +227,7 @@ takeWhile1_ = mfilter (not . T.null) . takeWhile_
 -- DocAName "Hello world"
 anchor :: Parser (DocH mod a)
 anchor = DocAName . T.unpack <$>
-         disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")
+         ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#")
 
 -- | Monospaced strings.
 --
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 4cf61fee9c..4180a56bf2 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -126,7 +126,7 @@ data DocH mod id
   | DocMathInline String
   | DocMathDisplay String
   | DocAName String
-  -- ^ A (HTML) anchor.
+  -- ^ A (HTML) anchor. It must not contain any spaces.
   | DocProperty String
   | DocExamples [Example]
   | DocHeader (Header (DocH mod id))
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index bc40a0a23b..da0ab355ed 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -288,8 +288,10 @@ spec = do
       it "parses a single word anchor" $ do
         "#foo#" `shouldParseTo` DocAName "foo"
 
-      it "parses a multi word anchor" $ do
-        "#foo bar#" `shouldParseTo` DocAName "foo bar"
+      -- Spaces are not allowed:
+      -- https://www.w3.org/TR/html51/dom.html#the-id-attribute
+      it "doesn't parse a multi word anchor" $ do
+        "#foo bar#" `shouldParseTo` "#foo bar#"
 
       it "parses a unicode anchor" $ do
         "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ"
@@ -304,6 +306,9 @@ spec = do
       it "does not accept empty anchors" $ do
         "##" `shouldParseTo` "##"
 
+      it "does not accept anchors containing spaces" $ do
+        "{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}"
+
     context "when parsing emphasised text" $ do
       it "emphasises a word on its own" $ do
         "/foo/" `shouldParseTo` DocEmphasis "foo"