diff options
6 files changed, 82 insertions, 23 deletions
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 358266b2..40e9e172 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -21,9 +21,10 @@ library default-language: Haskell2010 build-depends: - base >= 4.3 && < 4.8, - bytestring, - deepseq + base >= 4.3 && < 4.8 + , bytestring + , transformers + , deepseq hs-source-dirs: src, vendor/attoparsec-0.12.1.1 ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 @@ -68,10 +69,12 @@ test-suite spec build-depends: base - , base-compat - , hspec , bytestring + , transformers , deepseq + + , base-compat + , hspec , QuickCheck == 2.* source-repository head diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index c323ce0c..1cc277b8 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -78,7 +78,7 @@ overIdentifier f d = g d g (DocExamples x) = DocExamples x g (DocHeader (Header l x)) = DocHeader . Header l $ g x -parse :: Parser a -> BS.ByteString -> a +parse :: Parser a -> BS.ByteString -> (ParserState, a) parse p = either err id . parseOnly (p <* endOfInput) where err = error . ("Haddock.Parser.parse: " ++) @@ -86,19 +86,27 @@ parse p = either err id . parseOnly (p <* endOfInput) -- | Main entry point to the parser. Appends the newline character -- to the input string. parseParas :: String -- ^ String to parse - -> DocH mod Identifier -parseParas = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") + -> (Maybe Version, DocH mod Identifier) +parseParas input = case parseParasState input of + (state, a) -> (parserStateSince state, a) + +parseParasState :: String -> (ParserState, DocH mod Identifier) +parseParasState = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") where p :: Parser (DocH mod Identifier) p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n") +parseParagraphs :: String -> Parser (DocH mod Identifier) +parseParagraphs input = case parseParasState input of + (state, a) -> setParserState state >> return a + -- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which -- drops leading whitespace and encodes the string to UTF8 first. parseString :: String -> DocH mod Identifier parseString = parseStringBS . encodeUtf8 . dropWhile isSpace parseStringBS :: BS.ByteString -> DocH mod Identifier -parseStringBS = parse p +parseStringBS = snd . parse p where p :: Parser (DocH mod Identifier) p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName @@ -217,7 +225,8 @@ markdownImage = fromHyperlink <$> ("!" *> linkParser) -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) paragraph = examples <|> skipSpace *> ( - unorderedList + since + <|> unorderedList <|> orderedList <|> birdtracks <|> codeblock @@ -228,6 +237,11 @@ paragraph = examples <|> skipSpace *> ( <|> docParagraph <$> textParagraph ) +since :: Parser (DocH mod a) +since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty + where + version = decimal `sepBy1'` "." + -- | Headers inside the comment denoted with @=@ signs, up to 6 levels -- deep. -- @@ -334,7 +348,7 @@ moreContent item = first . (:) <$> nonEmptyLine <*> more item -- | Parses an indented paragraph. -- The indentation is 4 spaces. indentedParagraphs :: Parser (DocH mod Identifier) -indentedParagraphs = parseParas . concat <$> dropFrontOfPara " " +indentedParagraphs = (concat <$> dropFrontOfPara " ") >>= parseParagraphs -- | Grab as many fully indented paragraphs as we can. dropFrontOfPara :: Parser BS.ByteString -> Parser [String] diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 19edce04..a421c58c 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Documentation.Haddock.Parser.Monad ( module Documentation.Haddock.Parser.Monad , Attoparsec.isDigit @@ -34,17 +34,38 @@ import Data.String import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import Control.Monad.Trans.State +import qualified Control.Monad.Trans.Class as Trans import Data.Word import Data.Bits +import Data.Tuple -newtype Parser a = Parser (Attoparsec.Parser a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, IsString) +import Documentation.Haddock.Types (Version) -parseOnly :: Parser a -> ByteString -> Either String a -parseOnly (Parser p) = Attoparsec.parseOnly p +data ParserState = ParserState { + parserStateSince :: Maybe Version +} deriving (Eq, Show) + +initialParserState :: ParserState +initialParserState = ParserState Nothing + +newtype Parser a = Parser (StateT ParserState Attoparsec.Parser a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus) + +instance (a ~ ByteString) => IsString (Parser a) where + fromString = lift . fromString + +parseOnly :: Parser a -> ByteString -> Either String (ParserState, a) +parseOnly (Parser p) = fmap swap . Attoparsec.parseOnly (runStateT p initialParserState) lift :: Attoparsec.Parser a -> Parser a -lift = Parser +lift = Parser . Trans.lift + +setParserState :: ParserState -> Parser () +setParserState = Parser . put + +setSince :: Version -> Parser () +setSince since = Parser $ modify (\st -> st {parserStateSince = Just since}) char :: Char -> Parser Char char = lift . Attoparsec.char diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index b2d28be9..92ddeb7e 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -17,6 +17,8 @@ module Documentation.Haddock.Types where import Data.Foldable import Data.Traversable +type Version = [Int] + data Hyperlink = Hyperlink { hyperlinkUrl :: String , hyperlinkLabel :: Maybe String diff --git a/haddock-library/test/Documentation/Haddock/Parser/UtilSpec.hs b/haddock-library/test/Documentation/Haddock/Parser/UtilSpec.hs index 32dd11d4..10c701c7 100644 --- a/haddock-library/test/Documentation/Haddock/Parser/UtilSpec.hs +++ b/haddock-library/test/Documentation/Haddock/Parser/UtilSpec.hs @@ -5,6 +5,7 @@ import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util import Data.Either.Compat (isLeft) import Test.Hspec +import Control.Applicative main :: IO () main = hspec spec @@ -13,10 +14,10 @@ spec :: Spec spec = do describe "takeUntil" $ do it "takes everything until a specified byte sequence" $ do - parseOnly (takeUntil "end") "someend" `shouldBe` Right "some" + snd <$> parseOnly (takeUntil "end") "someend" `shouldBe` Right "some" it "requires the end sequence" $ do - parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft + snd <$> parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft it "takes escaped bytes unconditionally" $ do - parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end" + snd <$> parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end" diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 5550e836..7b0ef78d 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -22,8 +22,8 @@ instance IsString (Doc String) where instance IsString a => IsString (Maybe a) where fromString = Just . fromString -parseParas :: String -> Doc String -parseParas = Parse.toRegular . Parse.parseParas +parseParas :: String -> (Maybe Version, Doc String) +parseParas = fmap Parse.toRegular . Parse.parseParas parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString @@ -358,12 +358,30 @@ spec = do describe "parseParas" $ do let infix 1 `shouldParseTo` shouldParseTo :: String -> Doc String -> Expectation - shouldParseTo input ast = parseParas input `shouldBe` ast + shouldParseTo input ast = snd (parseParas input) `shouldBe` ast it "is total" $ do property $ \xs -> (length . show . parseParas) xs `shouldSatisfy` (> 0) + context "when parsing @since" $ do + it "adds specified version to the result" $ do + parseParas "@since 0.5.0" `shouldBe` (Just [0,5,0], DocEmpty) + + it "ignores trailing whitespace" $ do + parseParas "@since 0.5.0 \t " `shouldBe` (Just [0,5,0], DocEmpty) + + it "does not allow trailing input" $ do + parseParas "@since 0.5.0 foo" `shouldBe` (Nothing, DocParagraph "@since 0.5.0 foo") + + context "when given multiple times" $ do + it "gives last occurrence precedence" $ do + (parseParas . unlines) [ + "@since 0.5.0" + , "@since 0.6.0" + , "@since 0.7.0" + ] `shouldBe` (Just [0,7,0], DocEmpty) + context "when parsing text paragraphs" $ do let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) |