From 06517a6a4c5c6c7a89ea4ad57d85ffc458393a07 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 16 Nov 2014 08:58:40 +0800 Subject: (wip) Add support for @since (closes #26) --- .../src/Documentation/Haddock/Parser.hs | 26 +++++++++++++---- .../src/Documentation/Haddock/Parser/Monad.hs | 33 ++++++++++++++++++---- haddock-library/src/Documentation/Haddock/Types.hs | 2 ++ 3 files changed, 49 insertions(+), 12 deletions(-) (limited to 'haddock-library/src/Documentation/Haddock') 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 -- cgit v1.2.3