Merge remote-tracking branch 'upstream/ghc-head' into ghc-head

1 files changed, 75 insertions, 9 deletions

diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index 1724c664..5fa73ecd 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -403,20 +403,20 @@ spec = do
     context "when parsing module strings" $ do
       it "should parse a module on its own" $ do
         "\"Module\"" `shouldParseTo`
-          DocModule "Module"
+          DocModule (ModLink "Module" Nothing)
 
       it "should parse a module inline" $ do
         "This is a \"Module\"." `shouldParseTo`
-          "This is a " <> DocModule "Module" <> "."
+          "This is a " <> DocModule (ModLink "Module" Nothing) <> "."
 
       it "can accept a simple module name" $ do
-        "\"Hello\"" `shouldParseTo` DocModule "Hello"
+        "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing)
 
       it "can accept a module name with dots" $ do
-        "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World"
+        "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing)
 
       it "can accept a module name with unicode" $ do
-        "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ"
+        "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing)
 
       it "parses a module name with a trailing dot as regular quoted string" $ do
         "\"Hello.\"" `shouldParseTo` "\"Hello.\""
@@ -428,19 +428,85 @@ spec = do
         "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\""
 
       it "accepts a module name with unicode" $ do
-        "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ"
+        "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing)
 
       it "treats empty module name as regular double quotes" $ do
         "\"\"" `shouldParseTo` "\"\""
 
       it "accepts anchor reference syntax as DocModule" $ do
-        "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar"
+        "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing)
 
       it "accepts anchor with hyphen as DocModule" $ do
-        "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo#bar-baz"
+        "\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing)
 
       it "accepts old anchor reference syntax as DocModule" $ do
-        "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar"
+        "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing)
+
+    context "when parsing labeled module links" $ do
+      it "parses a simple labeled module link" $ do
+        "[some label](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some label"))
+
+      it "allows escaping in label" $ do
+        "[some\\] label](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some] label"))
+
+      it "strips leading and trailing whitespace from label" $ do
+        "[  some label  ](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some label"))
+
+      it "allows whitespace in module name link" $ do
+        "[some label]( \"Some.Module\"\t )" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just "some label"))
+
+      it "allows inline markup in the label" $ do
+        "[something /emphasized/](\"Some.Module\")" `shouldParseTo`
+          DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized")))
+
+      it "should parse a labeled module on its own" $ do
+        "[label](\"Module\")" `shouldParseTo`
+          DocModule (ModLink "Module" (Just "label"))
+
+      it "should parse a labeled module inline" $ do
+        "This is a [label](\"Module\")." `shouldParseTo`
+          "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "."
+
+      it "can accept a labeled module name with dots" $ do
+        "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label"))
+
+      it "can accept a labeled module name with unicode" $ do
+        "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label"))
+
+      it "parses a labeled module name with a trailing dot as a hyperlink" $ do
+        "[label](\"Hello.\")" `shouldParseTo`
+          hyperlink "\"Hello.\"" (Just "label")
+
+      it "parses a labeled module name with a space as a regular string" $ do
+        "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")"
+
+      it "parses a module name with invalid characters as a hyperlink" $ do
+        "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo`
+          hyperlink "\"Hello&[{}(=*+]!\"" (Just "label")
+
+      it "accepts a labeled module name with unicode" $ do
+        "[label](\"Foo.Barλ\")" `shouldParseTo`
+          DocModule (ModLink "Foo.Barλ" (Just "label"))
+
+      it "treats empty labeled module name as empty hyperlink" $ do
+        "[label](\"\")" `shouldParseTo`
+          hyperlink "\"\"" (Just "label")
+
+      it "accepts anchor reference syntax for labeled module name" $ do
+        "[label](\"Foo#bar\")" `shouldParseTo`
+          DocModule (ModLink "Foo#bar" (Just "label"))
+
+      it "accepts old anchor reference syntax for labeled module name" $ do
+        "[label](\"Foo\\#bar\")" `shouldParseTo`
+          DocModule (ModLink "Foo\\#bar" (Just "label"))
+
+      it "interprets empty label as a unlabeled module name" $ do
+        "[](\"Module.Name\")" `shouldParseTo`
+          "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")"
 
   describe "parseParas" $ do
     let infix 1 `shouldParseTo`