From 77ed6a63df3d2653401f1869f116c8854021a71e Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 2 Nov 2014 10:13:00 +0800 Subject: Add support for markdown links (closes #336) --- .../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(-) (limited to 'haddock-library') diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 6aa6ad10..e53597eb 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 ef2af140..eff7dfc6 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 9ef0e2d1..cb417cf6 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 "" `shouldParseTo` "" + 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 -- cgit v1.2.3