aboutsummaryrefslogtreecommitdiff
path: root/haddock-library
diff options
context:
space:
mode:
authorSimon Hengel <sol@typeful.net>2014-11-16 08:58:40 +0800
committerSimon Hengel <sol@typeful.net>2014-11-16 10:20:19 +0800
commit06517a6a4c5c6c7a89ea4ad57d85ffc458393a07 (patch)
treeaa06a22a299eb9d8f7e5efa5528a7c31534bd6d3 /haddock-library
parentc2b84c0c55bce1120db9826391de0466c33b3062 (diff)
(wip) Add support for @since (closes #26)
Diffstat (limited to 'haddock-library')
-rw-r--r--haddock-library/haddock-library.cabal13
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs26
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser/Monad.hs33
-rw-r--r--haddock-library/src/Documentation/Haddock/Types.hs2
-rw-r--r--haddock-library/test/Documentation/Haddock/Parser/UtilSpec.hs7
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs24
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))