[commit: haddock] T6018-injective-type-families, adamse-D1033, ghc-head, master, metainfo, wip/10268, wip/10313, wip/D538, wip/D538-1, wip/D538-2, wip/D538-3, wip/D538-4, wip/D538-5, wip/D538-6, wip/D548-master, wip/D548-master-2, wip/T10483, wip/T9840, wip/api-annot-tweaks-7.10, wip/api-annots-ghc-7.10-3, wip/orf-reboot: Add support for markdown links (closes #336) (77ed6a6)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haddock

On branches: T6018-injective-type-families,adamse-D1033,ghc-head,master,metainfo,wip/10268,wip/10313,wip/D538,wip/D538-1,wip/D538-2,wip/D538-3,wip/D538-4,wip/D538-5,wip/D538-6,wip/D548-master,wip/D548-master-2,wip/T10483,wip/T9840,wip/api-annot-tweaks-7.10,wip/api-annots-ghc-7.10-3,wip/orf-reboot
Link       : http://git.haskell.org/haddock.git/commitdiff/77ed6a63df3d2653401f1869f116c8854021a71e

>---------------------------------------------------------------

commit 77ed6a63df3d2653401f1869f116c8854021a71e
Author: Simon Hengel <sol at typeful.net>
Date:   Sun Nov 2 10:13:00 2014 +0800

    Add support for markdown links (closes #336)


>---------------------------------------------------------------

77ed6a63df3d2653401f1869f116c8854021a71e
 .../src/Documentation/Haddock/Parser.hs            | 22 ++++++++++--
 .../src/Documentation/Haddock/Parser/Util.hs       | 18 +++++-----
 .../test/Documentation/Haddock/ParserSpec.hs       | 39 ++++++++++++++++++++++
 3 files changed, 69 insertions(+), 10 deletions(-)

diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index 6aa6ad1..e53597e 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -20,7 +20,7 @@ module Documentation.Haddock.Parser ( parseString, parseParas
 
 import           Control.Applicative
 import           Control.Arrow (first)
-import           Control.Monad (void, mfilter)
+import           Control.Monad
 import           Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine)
 import qualified Data.ByteString.Char8 as BS
 import           Data.Char (chr, isAsciiUpper)
@@ -444,11 +444,29 @@ codeblock =
           | isNewline && isSpace c = Just isNewline
           | otherwise = Just $ c == '\n'
 
--- | Parses links that were specifically marked as such.
 hyperlink :: Parser (DocH mod a)
 hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8
               <$> disallowNewline ("<" *> takeUntil ">")
             <|> autoUrl
+            <|> markdownLink
+
+markdownLink :: Parser (DocH mod a)
+markdownLink = DocHyperlink <$> (flip Hyperlink <$> label <*> (whitespace *> url))
+  where
+    label :: Parser (Maybe String)
+    label = Just . strip . decode <$> ("[" *> takeUntil "]")
+
+    whitespace :: Parser ()
+    whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
+
+    url :: Parser String
+    url = rejectWhitespace (decode <$> ("(" *> takeUntil ")"))
+
+    rejectWhitespace :: MonadPlus m => m String -> m String
+    rejectWhitespace = mfilter (all (not . isSpace))
+
+    decode :: BS.ByteString -> String
+    decode = removeEscapes . decodeUtf8
 
 -- | Looks for URL-like things to automatically hyperlink even if they
 -- weren't marked as links.
diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs
index ef2af14..eff7dfc 100644
--- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs
@@ -14,6 +14,7 @@ module Documentation.Haddock.Parser.Util (
   unsnoc
 , strip
 , takeUntil
+, removeEscapes
 , makeLabeled
 , takeHorizontalSpace
 , skipHorizontalSpace
@@ -49,14 +50,15 @@ makeLabeled :: (String -> Maybe String -> a) -> String -> a
 makeLabeled f input = case break isSpace $ removeEscapes $ strip input of
   (uri, "")    -> f uri Nothing
   (uri, label) -> f uri (Just $ dropWhile isSpace label)
-  where
-    -- As we don't parse these any further, we don't do any processing to the
-    -- string so we at least remove escape character here. Perhaps we should
-    -- actually be parsing the label at the very least?
-    removeEscapes "" = ""
-    removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs
-    removeEscapes ('\\':xs) = removeEscapes xs
-    removeEscapes (x:xs) = x : removeEscapes xs
+
+-- | Remove escapes from given string.
+--
+-- Only do this if you do not process (read: parse) the input any further.
+removeEscapes :: String -> String
+removeEscapes "" = ""
+removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs
+removeEscapes ('\\':xs) = removeEscapes xs
+removeEscapes (x:xs) = x : removeEscapes xs
 
 takeUntil :: ByteString -> Parser ByteString
 takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index 9ef0e2d..cb417cf 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -114,6 +114,45 @@ spec = do
       it "doesn't allow for multi-line link tags" $ do
         "<ba\nz aar>" `shouldParseTo` "<ba\nz aar>"
 
+      context "when parsing markdown links" $ do
+        it "parses a simple link" $ do
+          "[some label](url)" `shouldParseTo`
+            hyperlink "url" "some label"
+
+        it "allows whitespace between label and URL" $ do
+          "[some label] \t (url)" `shouldParseTo`
+            hyperlink "url" "some label"
+
+        it "allows newlines in label" $ do
+          "[some\n\nlabel](url)" `shouldParseTo`
+            hyperlink "url" "some\n\nlabel"
+
+        it "allows escaping in label" $ do
+          "[some\\] label](url)" `shouldParseTo`
+            hyperlink "url" "some] label"
+
+        it "strips leading and trailing whitespace from label" $ do
+          "[  some label  ](url)" `shouldParseTo`
+            hyperlink "url" "some label"
+
+        it "rejects whitespace in URL" $ do
+          "[some label]( url)" `shouldParseTo`
+            "[some label]( url)"
+
+        context "when URL is on a separate line" $ do
+          it "allows URL to be on a separate line" $ do
+            "[some label]\n(url)" `shouldParseTo`
+              hyperlink "url" "some label"
+
+          it "allows leading whitespace" $ do
+            "[some label]\n  \t (url)" `shouldParseTo`
+              hyperlink "url" "some label"
+
+          it "rejects additional newlines" $ do
+            "[some label]\n\n(url)" `shouldParseTo`
+              "[some label]\n\n(url)"
+
+
       context "when autolinking URLs" $ do
         it "autolinks HTTP URLs" $ do
           "http://example.com/" `shouldParseTo` hyperlink "http://example.com/" Nothing