aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs22
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser/Util.hs18
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs39
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 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
"<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