diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +## Changes in version 1.11.0 + + * Add support for linking identifiers with a quote between backticks (#1408) + +## Changes in version 1.10.0 + + * Add support for labeled module references (#1360) ## Changes in version 1.9.0 * Fix build-time regression for `base < 4.7` (#1119) diff --git a/fixtures/Fixtures.hs b/fixtures/Fixtures.hs --- a/fixtures/Fixtures.hs +++ b/fixtures/Fixtures.hs @@ -9,8 +9,7 @@ import Data.List (foldl') import Data.Traversable (for) import GHC.Generics (Generic) -import Prelude () -import Prelude.Compat +import Prelude import System.Directory (getDirectoryContents) import System.Exit (exitFailure) import System.FilePath @@ -148,6 +147,9 @@ deriving instance Generic (Hyperlink id) instance ToExpr id => ToExpr (Hyperlink id) + +deriving instance Generic (ModLink id) +instance ToExpr id => ToExpr (ModLink id) deriving instance Generic Picture instance ToExpr Picture diff --git a/haddock-library.cabal b/haddock-library.cabal --- a/haddock-library.cabal +++ b/haddock-library.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: haddock-library -version: 1.9.0 +version: 1.11.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell @@ -27,6 +27,8 @@ , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 + , GHC == 9.0.1 + , GHC == 9.2.0 extra-source-files: CHANGES.md @@ -37,14 +39,12 @@ default-language: Haskell2010 build-depends: - , base >= 4.5 && < 4.15 - , bytestring ^>= 0.9.2.1 || ^>= 0.10.0.0 + , base >= 4.5 && < 4.17 , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1 - , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0 - , text ^>= 1.2.3.0 + , text ^>= 1.2.3.0 || ^>= 2.0 , parsec ^>= 3.1.13.0 - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs + ghc-options: -funbox-strict-fields -Wall if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances @@ -86,8 +86,8 @@ Documentation.Haddock.Parser.Identifier build-depends: - , base-compat ^>= 0.9.3 || ^>= 0.11.0 - , QuickCheck ^>= 2.11 || ^>= 2.13.2 + , base-compat ^>= 0.12.0 + , QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14 , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 -- NB: build-depends & build-tool-depends have independent @@ -95,10 +95,10 @@ -- version of `hspec` & `hspec-discover` to ensure -- intercompatibility build-depends: - , hspec >= 2.4.4 && < 2.8 + , hspec >= 2.4.4 && < 2.10 build-tool-depends: - , hspec-discover:hspec-discover >= 2.4.4 && < 2.8 + , hspec-discover:hspec-discover >= 2.4.4 && < 2.10 test-suite fixtures type: exitcode-stdio-1.0 @@ -113,11 +113,11 @@ , base -- extra dependencies - , base-compat ^>= 0.9.3 || ^>= 0.11.0 + , base-compat ^>= 0.12.0 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 , optparse-applicative ^>= 0.15 - , tree-diff ^>= 0.1 + , tree-diff ^>= 0.2 source-repository head type: git diff --git a/src/CompatPrelude.hs b/src/CompatPrelude.hs --- a/src/CompatPrelude.hs +++ b/src/CompatPrelude.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -#if !MIN_VERSION_base(4,5,0) +#ifdef __HLINT__ +#elif !MIN_VERSION_base(4,5,0) # error This module doesn't provide compat-shims for versions prior to base-4.5 #endif diff --git a/src/Documentation/Haddock/Markup.hs b/src/Documentation/Haddock/Markup.hs --- a/src/Documentation/Haddock/Markup.hs +++ b/src/Documentation/Haddock/Markup.hs @@ -16,13 +16,13 @@ markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 +markup m (DocModule (ModLink mo l)) = markupModule m (ModLink mo (fmap (markup m) l)) markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocBold d) = markupBold m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l)) @@ -78,7 +78,7 @@ markupAppend = (++), markupIdentifier = plainIdent, markupIdentifierUnchecked = plainMod, - markupModule = id, + markupModule = \(ModLink m lbl) -> fromMaybe m lbl, markupWarning = id, markupEmphasis = id, markupBold = id, diff --git a/src/Documentation/Haddock/Parser.hs b/src/Documentation/Haddock/Parser.hs --- a/src/Documentation/Haddock/Parser.hs +++ b/src/Documentation/Haddock/Parser.hs @@ -72,13 +72,13 @@ g (DocString x) = DocString x g (DocParagraph x) = DocParagraph $ g x g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x - g (DocModule x) = DocModule x + g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x)) g (DocWarning x) = DocWarning $ g x g (DocEmphasis x) = DocEmphasis $ g x g (DocMonospaced x) = DocMonospaced $ g x g (DocBold x) = DocBold $ g x g (DocUnorderedList x) = DocUnorderedList $ fmap g x - g (DocOrderedList x) = DocOrderedList $ fmap g x + g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x g (DocCodeBlock x) = DocCodeBlock $ g x g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x)) @@ -148,6 +148,7 @@ , mathDisplay , mathInline , markdownImage + , markdownLink , hyperlink , bold , emphasis @@ -172,11 +173,11 @@ -- Once we have checked for any of these and tried to parse the -- relevant markup, we can assume they are used as regular text. specialChar :: [Char] -specialChar = "_/<@\"&'`# " +specialChar = "_/<@\"&'`#[ " -- | Plain, regular parser for text. Called as one of the last parsers -- to ensure that we have already given a chance to more meaningful parsers --- before capturing their characers. +-- before capturing their characters. string' :: Parser (DocH mod a) string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar) where @@ -227,7 +228,7 @@ -- DocAName "Hello world" anchor :: Parser (DocH mod a) anchor = DocAName . T.unpack <$> - disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") + ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#") -- | Monospaced strings. -- @@ -242,15 +243,43 @@ -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) -moduleName = DocModule <$> ("\"" *> modid <* "\"") +moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"") + +-- | A module name, optionally with an anchor +-- +moduleNameString :: Parser String +moduleNameString = modid `maybeFollowedBy` anchor_ where modid = intercalate "." <$> conid `Parsec.sepBy1` "." + anchor_ = (++) + <$> (Parsec.string "#" <|> Parsec.string "\\#") + <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c))) + + maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf + conid :: Parser String conid = (:) <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) - <*> many (conChar <|> Parsec.oneOf "\\#") + <*> many conChar conChar = Parsec.alphaNum <|> Parsec.char '_' +-- | A labeled link to an indentifier, module or url using markdown +-- syntax. +markdownLink :: Parser (DocH mod Identifier) +markdownLink = do + lbl <- markdownLinkText + choice' [ markdownModuleName lbl, markdownURL lbl ] + where + markdownModuleName lbl = do + mn <- "(" *> skipHorizontalSpace *> + "\"" *> moduleNameString <* "\"" + <* skipHorizontalSpace <* ")" + pure $ DocModule (ModLink mn (Just lbl)) + + markdownURL lbl = do + target <- markdownLinkTarget + pure $ DocHyperlink $ Hyperlink target (Just lbl) + -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. -- @@ -284,9 +313,11 @@ -- >>> parseString "![some /emphasis/ in a description](www.site.com)" -- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) markdownImage :: Parser (DocH mod Identifier) -markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) +markdownImage = do + text <- markup stringMarkup <$> ("!" *> markdownLinkText) + url <- markdownLinkTarget + pure $ DocPic (Picture url (Just text)) where - fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) stringMarkup = plainMarkup (const "") renderIdent renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] @@ -330,7 +361,7 @@ firstRow <- parseFirstRow let len = T.length firstRow - -- then we parse all consequtive rows starting and ending with + or |, + -- then we parse all consecutive rows starting and ending with + or |, -- of the width `len`. restRows <- many (try (parseRestRows len)) @@ -512,11 +543,11 @@ header :: Parser (DocH mod Identifier) header = do let psers = map (string . flip T.replicate "=") [6, 5 .. 1] - pser = choice' psers - delim <- T.unpack <$> pser - line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText + pser = Parsec.choice psers + depth <- T.length <$> pser + line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine) rest <- try paragraph <|> return DocEmpty - return $ DocHeader (Header (length delim) line) `docAppend` rest + return $ DocHeader (Header depth line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier) textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine @@ -546,10 +577,24 @@ orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p where - p = (paren <|> dot) *> innerList indent p + p = do + index <- paren <|> dot + innerList' indent p index dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" +-- | Like 'innerList' but takes the parsed index of the list item +innerList' :: Text -> Parser [(Int, DocH mod Identifier)] + -> Int + -> Parser [(Int, DocH mod Identifier)] +innerList' indent item index = do + c <- takeLine + (cs, items) <- more indent item + let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs + return $ case items of + Left p -> [(index, contents `docAppend` p)] + Right i -> (index, contents) : i + -- | Generic function collecting any further lines belonging to the -- list entry and recursively collecting any further lists in the -- same paragraph. Usually used as @@ -679,7 +724,7 @@ Just (' ',t') -> Just t' _ -> Nothing --- | Parses examples. Examples are a paragraph level entitity (separated by an empty line). +-- | Parses examples. Examples are a paragraph level entity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a) examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go) @@ -766,22 +811,21 @@ | otherwise = Just $ c == '\n' hyperlink :: Parser (DocH mod Identifier) -hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] +hyperlink = choice' [ angleBracketLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod Identifier) -markdownLink = DocHyperlink <$> linkParser +-- | The text for a markdown link, enclosed in square brackets. +markdownLinkText :: Parser (DocH mod Identifier) +markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]") -linkParser :: Parser (Hyperlink (DocH mod Identifier)) -linkParser = flip Hyperlink <$> label <*> (whitespace *> url) +-- | The target for a markdown link, enclosed in parenthesis. +markdownLinkTarget :: Parser String +markdownLinkTarget = whitespace *> url where - label :: Parser (Maybe (DocH mod Identifier)) - label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]") - whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) diff --git a/src/Documentation/Haddock/Parser/Identifier.hs b/src/Documentation/Haddock/Parser/Identifier.hs --- a/src/Documentation/Haddock/Parser/Identifier.hs +++ b/src/Documentation/Haddock/Parser/Identifier.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -- | -- Module : Documentation.Haddock.Parser.Identifier -- Copyright : (c) Alec Theriault 2019, @@ -150,9 +149,9 @@ | otherwise = Nothing -- | Parse all but the last quote off the front of the input - -- PRECONDITION: T.head t == '\'' + -- PRECONDITION: T.head t `elem` ['\'', '`'] quotes :: Text -> (Int, Text) - quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1 + quotes t = let !n = T.length (T.takeWhile (`elem` ['\'', '`']) t) - 1 in (n, T.drop n t) -- | Parse an operator off the front of the input diff --git a/src/Documentation/Haddock/Parser/Monad.hs b/src/Documentation/Haddock/Parser/Monad.hs --- a/src/Documentation/Haddock/Parser/Monad.hs +++ b/src/Documentation/Haddock/Parser/Monad.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Documentation.Haddock.Parser.Monad -- Copyright : (c) Alec Theriault 2018-2019, @@ -40,7 +39,7 @@ import Prelude hiding (takeWhile) import CompatPrelude --- | The only bit of information we really care about truding along with us +-- | The only bit of information we really care about trudging along with us -- through parsing is the version attached to a @\@since@ annotation - if -- the doc even contained one. newtype ParserState = ParserState { diff --git a/src/Documentation/Haddock/Parser/Util.hs b/src/Documentation/Haddock/Parser/Util.hs --- a/src/Documentation/Haddock/Parser/Util.hs +++ b/src/Documentation/Haddock/Parser/Util.hs @@ -31,16 +31,16 @@ import Data.Char (isSpace) -- | Characters that count as horizontal space -horizontalSpace :: [Char] -horizontalSpace = " \t\f\v\r" +horizontalSpace :: Char -> Bool +horizontalSpace c = isSpace c && c /= '\n' -- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser () -skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) +skipHorizontalSpace = Parsec.skipMany (Parsec.satisfy horizontalSpace) -- | Take leading horizontal space -takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (`elem` horizontalSpace) +takeHorizontalSpace :: Parser Text +takeHorizontalSpace = takeWhile horizontalSpace makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of @@ -60,10 +60,10 @@ -- | Consume characters from the input up to and including the given pattern. -- Return everything consumed except for the end pattern itself. -takeUntil :: Text -> Parser Text +takeUntil :: Text -> Parser Text takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome where - end = T.unpack end_ + end = T.unpack end_ p :: (Bool, String) -> Char -> Maybe (Bool, String) p acc c = case acc of diff --git a/src/Documentation/Haddock/Types.hs b/src/Documentation/Haddock/Types.hs --- a/src/Documentation/Haddock/Types.hs +++ b/src/Documentation/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types @@ -73,13 +73,18 @@ , hyperlinkLabel :: Maybe id } deriving (Eq, Show, Functor, Foldable, Traversable) +data ModLink id = ModLink + { modLinkName :: String + , modLinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) + data Picture = Picture { pictureUri :: String , pictureTitle :: Maybe String } deriving (Eq, Show) data Header id = Header - { headerLevel :: Int + { headerLevel :: Int -- ^ between 1 and 6 inclusive , headerTitle :: id } deriving (Eq, Show, Functor, Foldable, Traversable) @@ -111,14 +116,15 @@ | DocIdentifier id | DocIdentifierUnchecked mod -- ^ A qualified identifier that couldn't be resolved. - | DocModule String + | DocModule (ModLink (DocH mod id)) + -- ^ A link to a module, with an optional label. | DocWarning (DocH mod id) -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) | DocMonospaced (DocH mod id) | DocBold (DocH mod id) | DocUnorderedList [DocH mod id] - | DocOrderedList [DocH mod id] + | DocOrderedList [(Int, DocH mod id)] | DocDefList [(DocH mod id, DocH mod id)] | DocCodeBlock (DocH mod id) | DocHyperlink (Hyperlink (DocH mod id)) @@ -126,7 +132,7 @@ | 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)) @@ -142,13 +148,13 @@ bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) bimap _ g (DocIdentifier i) = DocIdentifier (g i) bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) - bimap _ _ (DocModule s) = DocModule s + bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl)) bimap f g (DocWarning doc) = DocWarning (bimap f g doc) bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) bimap f g (DocBold doc) = DocBold (bimap f g doc) bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs) - bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) + bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs) bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl)) @@ -174,7 +180,7 @@ bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc bifoldr f g z (DocBold doc) = bifoldr f g z doc bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs - bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs + bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs) bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title @@ -189,13 +195,14 @@ bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m - bitraverse _ _ (DocModule s) = pure (DocModule s) + bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl) bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs - bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs + bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs + where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a) bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl) @@ -234,13 +241,13 @@ , markupAppend :: a -> a -> a , markupIdentifier :: id -> a , markupIdentifierUnchecked :: mod -> a - , markupModule :: String -> a + , markupModule :: ModLink a -> a , markupWarning :: a -> a , markupEmphasis :: a -> a , markupBold :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a + , markupOrderedList :: [(Int,a)] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a , markupHyperlink :: Hyperlink a -> a diff --git a/test/Documentation/Haddock/Parser/UtilSpec.hs b/test/Documentation/Haddock/Parser/UtilSpec.hs --- a/test/Documentation/Haddock/Parser/UtilSpec.hs +++ b/test/Documentation/Haddock/Parser/UtilSpec.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Documentation.Haddock.Parser.UtilSpec (main, spec) where import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util -import Data.Either.Compat (isLeft) +import Data.Either (isLeft) import Test.Hspec +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative +#endif main :: IO () main = hspec spec diff --git a/test/Documentation/Haddock/ParserSpec.hs b/test/Documentation/Haddock/ParserSpec.hs --- a/test/Documentation/Haddock/ParserSpec.hs +++ b/test/Documentation/Haddock/ParserSpec.hs @@ -3,6 +3,7 @@ module Documentation.Haddock.ParserSpec (main, spec) where +import Data.Char (isSpace) import Data.String import qualified Documentation.Haddock.Parser as Parse import Documentation.Haddock.Types @@ -120,6 +121,9 @@ it "can parse identifiers ending with a single quote" $ do "'foo''" `shouldParseTo` DocIdentifier "foo'" + it "can parse identifiers in backticks ending with a single quote" $ do + "`foo'`" `shouldParseTo` DocIdentifier "foo'" + it "can parse an identifier containing a digit" $ do "'f0'" `shouldParseTo` DocIdentifier "f0" @@ -288,8 +292,10 @@ 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 +310,9 @@ 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" @@ -397,20 +406,20 @@ 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.\"" @@ -422,17 +431,86 @@ "\"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 (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` shouldParseTo :: String -> Doc String -> Expectation @@ -442,6 +520,10 @@ property $ \xs -> (length . show . parseParas) xs `shouldSatisfy` (> 0) + -- See + it "doesn't crash on unicode whitespace" $ do + "\8197" `shouldParseTo` DocEmpty + context "when parsing @since" $ do it "adds specified version to the result" $ do parseParas "@since 0.5.0" `shouldBe` @@ -470,7 +552,8 @@ context "when parsing text paragraphs" $ do - let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) + let isSpecial c = isSpace c || c `elem` (".(=#-[*`\\\"'_/@<>" :: String) + filterSpecial = filter (not . isSpecial) it "parses an empty paragraph" $ do "" `shouldParseTo` DocEmpty @@ -496,28 +579,38 @@ it "turns it into a code block" $ do "@foo@" `shouldParseTo` DocCodeBlock "foo" - context "when a paragraph starts with a markdown link" $ do - it "correctly parses it as a text paragraph (not a definition list)" $ do - "[label](url)" `shouldParseTo` - DocParagraph (hyperlink "url" "label") + context "when a paragraph contains a markdown link" $ do + it "correctly parses the link" $ do + "Blah [label](url)" `shouldParseTo` + DocParagraph ("Blah " <> hyperlink "url" "label") - it "can be followed by an other paragraph" $ do - "[label](url)\n\nfoobar" `shouldParseTo` - DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar" + context "when the paragraph starts with the markdown link" $ do + it "correctly parses it as a text paragraph (not a definition list)" $ do + "[label](url)" `shouldParseTo` + DocParagraph (hyperlink "url" "label") - context "when paragraph contains additional text" $ do - it "accepts more text after the link" $ do - "[label](url) foo bar baz" `shouldParseTo` - DocParagraph (hyperlink "url" "label" <> " foo bar baz") + it "can be followed by an other paragraph" $ do + "[label](url)\n\nfoobar" `shouldParseTo` + DocParagraph (hyperlink "url" "label") <> DocParagraph "foobar" - it "accepts a newline right after the markdown link" $ do - "[label](url)\nfoo bar baz" `shouldParseTo` - DocParagraph (hyperlink "url" "label" <> " foo bar baz") + context "when paragraph contains additional text" $ do + it "accepts more text after the link" $ do + "[label](url) foo bar baz" `shouldParseTo` + DocParagraph (hyperlink "url" "label" <> " foo bar baz") - it "can be followed by an other paragraph" $ do - "[label](url)foo\n\nbar" `shouldParseTo` - DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar" + it "accepts a newline right after the markdown link" $ do + "[label](url)\nfoo bar baz" `shouldParseTo` + DocParagraph (hyperlink "url" "label" <> " foo bar baz") + it "can be followed by an other paragraph" $ do + "[label](url)foo\n\nbar" `shouldParseTo` + DocParagraph (hyperlink "url" "label" <> "foo") <> DocParagraph "bar" + + context "when the link starts on a new line not at the beginning of the paragraph" $ do + it "correctly parses the link" $ do + "Bla\n[label](url)" `shouldParseTo` + DocParagraph ("Bla\n" <> hyperlink "url" "label") + context "when parsing birdtracks" $ do it "parses them as a code block" $ do unlines [ @@ -730,7 +823,7 @@ it "can nest another type of list inside" $ do "* foo\n\n 1. bar" `shouldParseTo` DocUnorderedList [ DocParagraph "foo" - <> DocOrderedList [DocParagraph "bar"]] + <> DocOrderedList [(1, DocParagraph "bar")]] it "can nest a code block inside" $ do "* foo\n\n @foo bar baz@" `shouldParseTo` @@ -769,7 +862,7 @@ DocUnorderedList [ DocParagraph "foo" <> DocUnorderedList [ DocParagraph "bar" ] ] - <> DocOrderedList [ DocParagraph "baz" ] + <> DocOrderedList [ (1, DocParagraph "baz") ] it "allows arbitrary initial indent of a list" $ do unlines @@ -793,20 +886,20 @@ DocDefList [ ("foo", "foov" <> DocDefList [ ("bar", "barv") ]) ] - <> DocOrderedList [ DocParagraph "baz" ] + <> DocOrderedList [ (1, DocParagraph "baz") ] it "list order is preserved in presence of nesting + extra text" $ do "1. Foo\n\n > Some code\n\n2. Bar\n\nSome text" `shouldParseTo` - DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code" - , DocParagraph "Bar" + DocOrderedList [ (1, DocParagraph "Foo" <> DocCodeBlock "Some code") + , (2, DocParagraph "Bar") ] <> DocParagraph (DocString "Some text") "1. Foo\n\n2. Bar\n\nSome text" `shouldParseTo` - DocOrderedList [ DocParagraph "Foo" - , DocParagraph "Bar" + DocOrderedList [ (1, DocParagraph "Foo") + , (2, DocParagraph "Bar") ] <> DocParagraph (DocString "Some text") @@ -890,9 +983,9 @@ , " 3. three" ] `shouldParseTo` DocOrderedList [ - DocParagraph "one" - , DocParagraph "two" - , DocParagraph "three" + (1, DocParagraph "one") + , (1, DocParagraph "two") + , (3, DocParagraph "three") ] it "ignores empty lines between list items" $ do @@ -902,12 +995,12 @@ , "2. two" ] `shouldParseTo` DocOrderedList [ - DocParagraph "one" - , DocParagraph "two" + (1, DocParagraph "one") + , (2, DocParagraph "two") ] it "accepts an empty list item" $ do - "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty] + "1." `shouldParseTo` DocOrderedList [(1, DocParagraph DocEmpty)] it "accepts multi-line list items" $ do unlines [ @@ -917,12 +1010,12 @@ , "more two" ] `shouldParseTo` DocOrderedList [ - DocParagraph "point one\n more one" - , DocParagraph "point two\nmore two" + (1, DocParagraph "point one\n more one") + , (1, DocParagraph "point two\nmore two") ] it "accepts markup in list items" $ do - "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")] + "1. /foo/" `shouldParseTo` DocOrderedList [(1, DocParagraph (DocEmphasis "foo"))] it "requires empty lines between list and other paragraphs" $ do unlines [ @@ -932,7 +1025,7 @@ , "" , "baz" ] - `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz" + `shouldParseTo` DocParagraph "foo" <> DocOrderedList [(1, DocParagraph "bar")] <> DocParagraph "baz" context "when parsing definition lists" $ do it "parses a simple list" $ do @@ -1019,8 +1112,8 @@ ] `shouldParseTo` DocUnorderedList [ DocParagraph "bullet" , DocParagraph "different bullet"] - <> DocOrderedList [ DocParagraph "ordered" - , DocParagraph "different bullet" + <> DocOrderedList [ (1, DocParagraph "ordered") + , (2, DocParagraph "different bullet") ] <> DocDefList [ ("cat", "kitten") , ("pineapple", "fruit")