From 27876dc77ff259e27a71ea6f30662a668adfd134 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 3 Sep 2013 19:14:08 +0200 Subject: Don't append newline to parseString input We also check that we have parsed everything with endOfInput. --- html-test/ref/A.html | 2 +- html-test/ref/AdvanceTypes.html | 2 +- html-test/ref/B.html | 2 +- html-test/ref/Bug1.html | 2 +- html-test/ref/Bug2.html | 2 +- html-test/ref/Bug3.html | 2 +- html-test/ref/Bug4.html | 2 +- html-test/ref/Bug6.html | 2 +- html-test/ref/Bug7.html | 2 +- html-test/ref/Bug8.html | 8 +-- html-test/ref/BugDeprecated.html | 20 +++--- html-test/ref/BugExportHeadings.html | 47 +++++--------- html-test/ref/Bugs.html | 2 +- html-test/ref/CrossPackageDocs.html | 35 ++++------- html-test/ref/DeprecatedClass.html | 14 ++--- html-test/ref/DeprecatedData.html | 20 +++--- html-test/ref/DeprecatedFunction.html | 5 +- html-test/ref/DeprecatedFunction2.html | 5 +- html-test/ref/DeprecatedFunction3.html | 5 +- html-test/ref/DeprecatedModule.html | 5 +- html-test/ref/DeprecatedModule2.html | 5 +- html-test/ref/DeprecatedNewtype.html | 14 ++--- html-test/ref/DeprecatedReExport.html | 17 ++--- html-test/ref/DeprecatedRecord.html | 5 +- html-test/ref/DeprecatedTypeFamily.html | 8 +-- html-test/ref/DeprecatedTypeSynonym.html | 8 +-- html-test/ref/Examples.html | 2 +- html-test/ref/FunArgs.html | 2 +- html-test/ref/GADTRecords.html | 2 +- html-test/ref/Hash.html | 20 +++--- html-test/ref/HiddenInstances.html | 2 +- html-test/ref/HiddenInstancesB.html | 2 +- html-test/ref/Hyperlinks.html | 2 +- html-test/ref/IgnoreExports.html | 2 +- html-test/ref/ModuleWithWarning.html | 5 +- html-test/ref/NamedDoc.html | 2 +- html-test/ref/NoLayout.html | 2 +- html-test/ref/NonGreedy.html | 2 +- html-test/ref/Properties.html | 2 +- html-test/ref/PruneWithWarning.html | 2 +- html-test/ref/SpuriousSuperclassConstraints.html | 2 +- html-test/ref/Test.html | 80 +++++++++--------------- html-test/ref/Ticket253_1.html | 2 +- html-test/ref/Ticket253_2.html | 2 +- html-test/ref/Ticket61.html | 2 +- html-test/ref/Ticket75.html | 2 +- html-test/ref/TitledPicture.html | 2 +- html-test/ref/TypeFamilies.html | 2 +- html-test/ref/TypeOperators.html | 8 +-- html-test/ref/Unicode.html | 2 +- html-test/ref/Visible.html | 2 +- html-test/ref/mini_BugExportHeadings.html | 18 ++---- html-test/ref/mini_DeprecatedReExport.html | 6 +- html-test/ref/mini_Hash.html | 9 +-- html-test/ref/mini_Test.html | 36 ++++------- html-test/ref/mini_TypeOperators.html | 3 +- html-test/run.lhs | 21 +++++-- html-test/src/Bug7.hs | 1 + html-test/src/Bug8.hs | 6 +- html-test/src/FunArgs.hs | 1 + html-test/src/Test.hs | 52 +++++++-------- html-test/src/Ticket75.hs | 1 + src/Haddock/Parser.hs | 30 ++++----- test/Haddock/ParserSpec.hs | 77 +++++++++++------------ 64 files changed, 272 insertions(+), 385 deletions(-) diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 4ba16b7b..4d55ba16 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -35,7 +35,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Type (StringTyp, [Typ])TFree (StringTyp, [StringTyp]) Safe HaskellNoneSafe-Inferred

Deprecated: for foo -

Deprecated: for foo

Deprecated: for baz -

Deprecated: for baz

Deprecated: for bar -

Deprecated: for bar

Deprecated: for one -

Deprecated: for one

some documentation for one, two and three @@ -159,8 +155,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for three -

Deprecated: for three

some documentation for one, two and three @@ -177,8 +172,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");} >

Deprecated: for two -

Deprecated: for two

some documentation for one, two and three diff --git a/html-test/ref/BugExportHeadings.html b/html-test/ref/BugExportHeadings.html index 1010dc54..7e3ea0d3 100644 --- a/html-test/ref/BugExportHeadings.html +++ b/html-test/ref/BugExportHeadings.html @@ -35,7 +35,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_BugExportHeadings.html >Safe HaskellNoneSafe-Inferred

Class for string-like datastructures; used by the overloaded string - extension (-XOverloadedStrings in GHC). -

proc for details) -

for details)

]

Arguments to pass to the executable -

Arguments to pass to the executable

Optional path to the working directory -

Optional path to the working directory

)]

Optional environment (otherwise inherit) -

Optional environment (otherwise inherit)

stdout and stderr respectively. -

respectively.

For example, to start a process and feed a string to its stdin: -

For example, to start a process and feed a string to its stdin:

   (inp,out,err,pid) <- runInteractiveProcess "..."
-   forkIO (hPutStr inp str)
-

The hSetBinaryMode. -

.

Safe HaskellNoneSafe-Inferred

Deprecated: SomeClass -

Deprecated: SomeClass

some class @@ -107,8 +106,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html") >

Deprecated: foo -

Deprecated: foo

documentation for foo @@ -128,8 +126,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html") >

Deprecated: SomeOtherClass -

Deprecated: SomeOtherClass

Deprecated: bar -

Deprecated: bar

Safe HaskellNoneSafe-Inferred

Deprecated: Foo -

Deprecated: Foo

type Foo @@ -111,8 +110,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: Foo -

Deprecated: Foo

constructor Foo @@ -127,8 +125,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: Bar -

Deprecated: Bar

constructor Bar @@ -148,8 +145,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html"); >

Deprecated: One -

Deprecated: One

Deprecated: One -

Deprecated: One

Deprecated: Two -

Deprecated: Two

Safe HaskellNoneSafe-Inferred

bar instead -

instead

some documentation for foo diff --git a/html-test/ref/DeprecatedFunction2.html b/html-test/ref/DeprecatedFunction2.html index 023081b3..f212adf2 100644 --- a/html-test/ref/DeprecatedFunction2.html +++ b/html-test/ref/DeprecatedFunction2.html @@ -35,7 +35,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedFunction2.ht >Safe HaskellNoneSafe-Inferred

Deprecated: use bar instead -

Deprecated: use bar instead

Safe HaskellNoneSafe-Inferred

Deprecated: use bar instead -

Deprecated: use bar instead

Safe HaskellNoneSafe-Inferred

Deprecated: Use Foo instead -

instead

Documentation for Safe HaskellNoneSafe-Inferred

Deprecated: Use Foo instead -

Deprecated: Use Foo instead

Safe HaskellNoneSafe-Inferred

Deprecated: SomeNewType -

Deprecated: SomeNewType

some documentation @@ -101,8 +100,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html >

Deprecated: SomeNewTypeConst -

Deprecated: SomeNewTypeConst

constructor docu @@ -122,8 +120,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html >

Deprecated: SomeOtherNewType -

Deprecated: SomeOtherNewType

Deprecated: SomeOtherNewTypeConst -

Deprecated: SomeOtherNewTypeConst

Safe HaskellNoneSafe-Inferred

Re-exported from an other module -

Re-exported from an other module

bar instead -

instead

some documentation for foo @@ -110,8 +106,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedReExport.htm >

Re-exported from an other package -

Re-exported from an other package

Not yet working, see Safe HaskellNoneSafe-Inferred

Deprecated: do not use this -

Deprecated: do not use this

some value diff --git a/html-test/ref/DeprecatedTypeFamily.html b/html-test/ref/DeprecatedTypeFamily.html index 874272b7..b9f49036 100644 --- a/html-test/ref/DeprecatedTypeFamily.html +++ b/html-test/ref/DeprecatedTypeFamily.html @@ -35,7 +35,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.h >Safe HaskellNoneSafe-Inferred

Deprecated: SomeTypeFamily -

Deprecated: SomeTypeFamily

some documentation @@ -90,8 +89,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.h >

Deprecated: SomeOtherTypeFamily -

Deprecated: SomeOtherTypeFamily

Safe HaskellNoneSafe-Inferred

Deprecated: TypeSyn -

Deprecated: TypeSyn

some documentation @@ -98,8 +97,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeSynonym. >

Deprecated: OtherTypeSyn -

Deprecated: OtherTypeSyn

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

The HashTable type - type

The Hash class - class

The HashTable type -

type

Operations on HashTables -

s

The Hash class -

class

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Warning: This is an unstable interface. Prefer functions from Prelude instead! -

instead!

Documentation for Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Type declarations -

Type declarations

Data types -

Data types

n3 field + > field

Records -

Records

Class declarations -

Class declarations

Function types -

Function types

Auxiliary stuff -

Auxiliary stuff

This is some documentation that is attached to a name ($aux1) @@ -1865,8 +1847,7 @@ test2

A hidden module -

A hidden module

A visible module -

A visible module

module

Existential / Universal types -

Existential / Universal types

Type signatures with argument docs -

Type signatures with argument docs

This function has some arg docs + >This function has some arg docs

A section -

A section

A subsection -

A subsection
 a literal line
@@ -2215,7 +2191,7 @@ test2
 	      >f' 
+	      >
  but f' doesn't get link'd 'f\''
Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

stuff -

stuff

Safe HaskellNoneSafe-Inferred

Safe HaskellNoneSafe-Inferred

Foo -

Foo

Bar -

Bar

Baz -

Baz

One -

One

Two -

Two

Three -

Three

The HashTable type -

type

Operations on HashTables -

s

The Hash class -

class

Type declarations -

Type declarations

Data types -

Data types

a b

Records -

Records

Class declarations -

Class declarations

a

Function types -

Function types

Auxiliary stuff -

Auxiliary stuff

A hidden module -

A hidden module

A visible module -

A visible module

Existential / Universal types -

Existential / Universal types

a

Type signatures with argument docs -

Type signatures with argument docs

A section -

A section

A subsection -

A subsection

stuff -

stuff

String stripLinks str = let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str') + Just str' -> case dropWhile (/= '>') (dropWhile (/= '"') str') of + [] -> [] + x:xs -> stripLinks (stripHrefEnd xs) Nothing -> case str of [] -> [] x : xs -> x : stripLinks xs +stripHrefEnd :: String -> String +stripHrefEnd s = + let pref = " case dropWhile (/= '>') str' of + [] -> [] + x:xs -> xs + Nothing -> + case s of + [] -> [] + x : xs -> x : stripHrefEnd xs + programOnPath :: FilePath -> IO Bool programOnPath p = do result <- findProgramLocation silent p diff --git a/html-test/src/Bug7.hs b/html-test/src/Bug7.hs index 8cf57914..a07934c4 100644 --- a/html-test/src/Bug7.hs +++ b/html-test/src/Bug7.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} -- | This module caused a duplicate instance in the documentation for the Foo -- type. module Bug7 where diff --git a/html-test/src/Bug8.hs b/html-test/src/Bug8.hs index 18df63c8..e569b01d 100644 --- a/html-test/src/Bug8.hs +++ b/html-test/src/Bug8.hs @@ -3,10 +3,10 @@ module Bug8 where infix --> infix ---> -data Typ = Type (String,[Typ]) - | TFree (String, [String]) +data Typ = Type (Typ,[Typ]) + | TFree (Typ, [Typ]) -x --> y = Type("fun",[s,t]) +x --> y = Type(s,[s,t]) (--->) = flip $ foldr (-->) s = undefined diff --git a/html-test/src/FunArgs.hs b/html-test/src/FunArgs.hs index b34d84b7..cfde185d 100644 --- a/html-test/src/FunArgs.hs +++ b/html-test/src/FunArgs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExplicitForAll #-} module FunArgs where f :: forall a. Ord a diff --git a/html-test/src/Test.hs b/html-test/src/Test.hs index d352f029..677106c6 100644 --- a/html-test/src/Test.hs +++ b/html-test/src/Test.hs @@ -3,7 +3,7 @@ -- Module : Test -- Copyright : (c) Simon Marlow 2002 -- License : BSD-style --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable @@ -14,8 +14,8 @@ ----------------------------------------------------------------------------- -- This is plain comment, ignored by Haddock. - -module Test ( +{-# LANGUAGE Rank2Types, GADTs #-} +module Test ( -- Section headings are introduced with '-- *': -- * Type declarations @@ -33,7 +33,7 @@ module Test ( -- * Class declarations C(a,b), D(..), E, F(..), - + -- | Test that we can export a class method on its own: a, @@ -88,7 +88,7 @@ module Test ( -- * A section -- and without an intervening comma: - -- ** A subsection + -- ** A subsection {-| > a literal line @@ -112,7 +112,7 @@ bla = Nothing data T a b = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor | -- | This comment describes the 'B' constructor - B (T a b, T Int Float) -- ^ + B (T a b, T Int Float) -- ^ -- | An abstract data declaration data T2 a b = T2 a b @@ -145,7 +145,7 @@ newtype N1 a = N1 a newtype N2 a b = N2 {n :: a b} -- | A newtype with a fieldname, documentation on the field -newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field +newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field } -- | An abstract newtype - we show this one as data rather than newtype because @@ -163,7 +163,7 @@ newtype N6 a b = N6 {n6 :: a b newtype N7 a b = N7 {n7 :: a b } -- ^ The 'N7' constructor - + class (D a) => C a where -- |this is a description of the 'a' method @@ -198,7 +198,7 @@ class F a where -- | This is the documentation for the 'R' record, which has four fields, -- 'p', 'q', 'r', and 's'. -data R = +data R = -- | This is the 'C1' record constructor, with the following fields: C1 { p :: Int -- ^ This comment applies to the 'p' field , q :: forall a . a->a -- ^ This comment applies to the 'q' field @@ -211,15 +211,15 @@ data R = -- ^ This is the 'C2' record constructor, also with some fields: -- | Testing different record commenting styles -data R1 +data R1 -- | This is the 'C3' record constructor - = C3 { + = C3 { -- | The 's1' record selector s1 :: Int -- | The 's2' record selector , s2 :: Int , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. - -- Since GHC doesn't allow that, I have removed it in this file. + -- Since GHC doesn't allow that, I have removed it in this file. -- ^ The 's3' record selector } @@ -240,11 +240,11 @@ using double quotes: "Foo". We can add emphasis /like this/. - This is the next item (different kind of bullet) (1) This is an ordered list - + 2. This is the next item (different kind of bullet) - + [cat] a small, furry, domesticated mammal - + [pineapple] a fruit grown in the tropics @ @@ -350,15 +350,15 @@ test2 -- $aux12 -- > foo --- +-- -- > bar --- +-- -- | A data-type using existential\/universal types -data Ex a +data Ex a = forall b . C b => Ex1 b | forall b . Ex2 b - | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file + | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file | Ex4 (forall a . a -> a) -- | This is a function with documentation for each argument @@ -374,7 +374,7 @@ k :: T () () -- ^ This argument has type 'T' l :: (Int, Int, Float) -- ^ takes a triple -> Int -- ^ returns an 'Int' --- | This function has some arg docs +-- | This function has some arg docs m :: R -> N1 () -- ^ one of the arguments -> IO Int -- ^ and the return value @@ -385,22 +385,22 @@ m :: R newn :: R -- ^ one of the arguments, an 'R' -> N1 () -- ^ one of the arguments -> IO Int -newn = undefined +newn = undefined -- | A foreign import with argument docs -foreign import ccall unsafe +foreign import ccall unsafe o :: Float -- ^ The input float -> IO Float -- ^ The output float -- | We should be able to escape this: \#\#\# --- p :: Int +-- p :: Int -- can't use the above original definition with GHC -newp :: Int +newp :: Int newp = undefined --- | a function with a prime can be referred to as 'f'' +-- | a function with a prime can be referred to as 'f'' -- but f' doesn't get link'd 'f\'' f' :: Int @@ -416,7 +416,7 @@ withType = 1 data T1 f = undefined f' = undefined -type CInt = Int +type CInt = Int k = undefined l = undefined m = undefined diff --git a/html-test/src/Ticket75.hs b/html-test/src/Ticket75.hs index 94a2f115..5fc704d6 100644 --- a/html-test/src/Ticket75.hs +++ b/html-test/src/Ticket75.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} module Ticket75 where data a :- b = Q diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs index 81e274ed..43a2b169 100644 --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -12,9 +12,9 @@ module Haddock.Parser (parseString, parseParas) where import Control.Applicative -import Data.Attoparsec.ByteString hiding (takeWhile1, take, inClass) +import Data.Attoparsec.ByteString hiding (parse, takeWhile1, take, inClass) import qualified Data.Attoparsec.ByteString.Char8 as A8 -import Data.Attoparsec.ByteString.Char8 hiding (take, string) +import Data.Attoparsec.ByteString.Char8 hiding (parse, take, string) import qualified Data.ByteString as BS import Data.Char (chr) import Data.List (stripPrefix) @@ -31,16 +31,15 @@ import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) import Haddock.Utf8 -default (Int) +parse :: Parser a -> String -> Maybe a +parse p = either (const Nothing) Just . parseOnly (p <* endOfInput) . encodeUtf8 -- | Main entry point to the parser. Appends the newline character -- to the input string. parseParas :: DynFlags -> String -- ^ String to parse -> Maybe (Doc RdrName) -parseParas d s = case parseOnly (p <* skipSpace) (encodeUtf8 $ s ++ "\n") of - Right r -> Just $ combineStringNodes r - _ -> Nothing +parseParas d = fmap combineStringNodes . parse (p <* skipSpace) . (++ "\n") where p :: Parser (Doc RdrName) -- make sure that we don't swallow up whitespace belonging to next paragraph @@ -51,7 +50,7 @@ parseParas d s = case parseOnly (p <* skipSpace) (encodeUtf8 $ s ++ "\n") of -- Drops any whitespace in front of the input string. It's dropped for the sake of -- section headings. parseString :: DynFlags -> String -> Maybe (Doc RdrName) -parseString d = parseString'' d . dropWhile isSpace +parseString d = parseString' d . dropWhile isSpace -- | A parser that parsers separate lines of the comments. Eventually -- called by 'parseParas'. Appends a newline character to the input string. @@ -62,9 +61,7 @@ parseString'' d = parseString' d . (++ "\n") -- | An internal use function. Split from the 'parseString' is useful -- as we can specify separately when we want the newline to be appended. parseString' :: DynFlags -> String -> Maybe (Doc RdrName) -parseString' d s = case parseOnly p (encodeUtf8 s) of - Right r -> Just $ combineStringNodes r - _ -> Nothing +parseString' d = fmap combineStringNodes . parse p where p :: Parser (Doc RdrName) p = mconcat <$> some (charEscape <|> monospace d <|> anchor <|> identifier d @@ -94,7 +91,7 @@ string' = DocString . decodeUtf8 <$> takeWhile1 (`notElem` "/<@\" &'`\\") -- >>> parseOnly emphasis "/Hello world/" -- Right (DocEmphasis (DocString "Hello world")) emphasis :: DynFlags -> Parser (Doc RdrName) -emphasis d = stringBlock d id DocEmphasis "/" "/" "\n" +emphasis d = DocEmphasis <$> stringBlock d "/" "/" "\n" -- | Skips a single character and treats it as a plain string. -- This is done to skip over any special characters belonging to other @@ -119,17 +116,14 @@ anchor = DocAName . decodeUtf8 <$> ("#" *> takeWhile1 (`notElem` "#\n") <* "#") -- | Helper for markup structures surrounded with delimiters. stringBlock :: DynFlags - -> (String -> String) -- ^ Function used to transform parsed out text - -- before we send it to 'parseString'' - -> (Doc RdrName -> Doc RdrName) -- ^ 'Doc' to wrap around the result -> String -- ^ Opening delimiter -> String -- ^ Closing delimiter -> String -- ^ Additional characters to terminate parsing on -> Parser (Doc RdrName) -stringBlock d f doc op ed n = do +stringBlock d op ed n = do inner <- block op ed n - case parseString' d (f inner) of - Just r -> return $ doc r + case parseString' d inner of + Just r -> return r _ -> fail $ "inner parse fail with op: ‘" ++ op ++ "’, ed: ‘" ++ ed ++ "’" -- | Returns sections of text delimited by specified text. @@ -171,7 +165,7 @@ takeWithSkip s n = do -- >>> parseOnly (monospace dynflags) "@cruel@" -- Right (DocMonospaced (DocString "cruel")) monospace :: DynFlags -> Parser (Doc RdrName) -monospace d = stringBlock d id DocMonospaced "@" "@" "" +monospace d = DocMonospaced <$> stringBlock d "@" "@" "" -- | Module name parser, surrounded by double quotes. This does a very primitive and -- purely syntactic checking so that obviously invalid names are not treated as valid diff --git a/test/Haddock/ParserSpec.hs b/test/Haddock/ParserSpec.hs index 20d9c2cf..b0a6e41b 100644 --- a/test/Haddock/ParserSpec.hs +++ b/test/Haddock/ParserSpec.hs @@ -6,7 +6,6 @@ module Haddock.ParserSpec (main, spec) where import Control.Applicative -import Data.Maybe (isJust) import Data.Monoid import Data.String import Haddock.Doc (combineStringNodes) @@ -43,7 +42,6 @@ main = hspec spec spec :: Spec spec = do - let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) describe "parseString" $ do @@ -53,65 +51,84 @@ spec = do it "is total" $ do property $ \xs -> - -- filter out primes as we might end up with an identifier - -- which will fail due to undefined DynFlags - parseString (filter (/= '\'') xs) `shouldSatisfy` isJust + (length . show . parseString) xs `shouldSatisfy` (> 0) context "when parsing URLs" $ do it "parses a URL" $ do "" `shouldParseTo` - hyperlink "http://example.com/" Nothing <> "\n" + hyperlink "http://example.com/" Nothing it "accepts an optional label" $ do "" `shouldParseTo` - hyperlink "http://example.com/" "some link" <> "\n" + hyperlink "http://example.com/" "some link" it "finishes URL parsing as soon as it sees >, even if it's escaped" $ do "le.com" `shouldParseTo` - hyperlink "http://examp\\" Nothing <> "le.com\n" + hyperlink "http://examp\\" Nothing <> "le.com" "mp\\>le.com>" `shouldParseTo` - hyperlink "http://exa\\" Nothing <> "mp>le.com>\n" + hyperlink "http://exa\\" Nothing <> "mp>le.com>" -- Likewise in label "oo>" `shouldParseTo` - hyperlink "http://example.com" "f\\" <> "oo>\n" + hyperlink "http://example.com" "f\\" <> "oo>" it "parses inline URLs" $ do "Not yet working, see \n , isEmptyChan" `shouldParseTo` "Not yet working, see " <> hyperlink "http://trac.haskell.org/haddock/ticket/223" Nothing - <> "\n , isEmptyChan\n" + <> "\n , isEmptyChan" context "when autolinking URLs" $ do it "autolinks HTTP URLs" $ do "http://example.com/" `shouldParseTo` - hyperlink "http://example.com/" Nothing <> "\n" + hyperlink "http://example.com/" Nothing it "autolinks HTTPS URLs" $ do "https://www.example.com/" `shouldParseTo` - hyperlink "https://www.example.com/" Nothing <> "\n" + hyperlink "https://www.example.com/" Nothing it "autolinks FTP URLs" $ do "ftp://example.com/" `shouldParseTo` - hyperlink "ftp://example.com/" Nothing <> "\n" + hyperlink "ftp://example.com/" Nothing it "does not include a trailing exclamation mark" $ do "http://example.com/! Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> "! Some other sentence.\n" + hyperlink "http://example.com/" Nothing <> "! Some other sentence." it "does not include a trailing comma" $ do "http://example.com/, Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> ", Some other sentence.\n" + hyperlink "http://example.com/" Nothing <> ", Some other sentence." it "does not include a trailing dot" $ do "http://example.com/. Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> ". Some other sentence.\n" + hyperlink "http://example.com/" Nothing <> ". Some other sentence." it "does not include a trailing question mark" $ do "http://example.com/? Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> "? Some other sentence.\n" + hyperlink "http://example.com/" Nothing <> "? Some other sentence." + + context "when parsing emphasised text" $ do + it "emphasises a word on its own" $ do + "/foo/" `shouldParseTo` DocEmphasis "foo" + + it "emphasises inline correctly" $ do + "foo /bar/ baz" `shouldParseTo` "foo " <> DocEmphasis "bar" <> " baz" + + it "emphasises unicode" $ do + "/灼眼のシャナ/" `shouldParseTo` DocEmphasis "灼眼のシャナ" + + it "does not emphasise multi-line strings" $ do + " /foo\nbar/" `shouldParseTo` "/foo\nbar/" + + it "does not emphasise the empty string" $ do + "//" `shouldParseTo` "//" + + it "parses escaped slashes literally" $ do + "/foo\\/bar/" `shouldParseTo` DocEmphasis "foo/bar" + it "recognizes other markup constructs within emphasised text" $ do + "/foo @bar@ baz/" `shouldParseTo` DocEmphasis ("foo " <> DocMonospaced "bar" <> " baz") describe "parseParas" $ do let infix 1 `shouldParseTo` @@ -121,9 +138,7 @@ spec = do it "is total" $ do property $ \xs -> - -- filter out primes as we might end up with an identifier - -- which will fail due to undefined DynFlags - parseParas (filter (/= '\'') xs) `shouldSatisfy` isJust + (length . show . parseParas) xs `shouldSatisfy` (> 0) it "parses a paragraph" $ do "foobar" `shouldParseTo` DocParagraph "foobar\n" @@ -154,23 +169,6 @@ spec = do "This is a \"Module\"." `shouldParseTo` DocParagraph ("This is a " <> (DocModule "Module" <> ".\n")) - context "when parsing emphasised strings" $ do - it "emphasises a word on its own" $ do - "/quux/" `shouldParseTo` (DocParagraph $ DocEmphasis "quux" <> "\n") - - it "emphasises inline correctly" $ do - "This comment applies to the /following/ declaration" `shouldParseTo` - (DocParagraph $ "This comment applies to the " - <> DocEmphasis "following" <> " declaration\n") - - it "emphasises unicode" $ do - "/灼眼のシャナ/" `shouldParseTo` - (DocParagraph $ DocEmphasis "灼眼のシャナ" <> "\n") - - it "does not do /multi-line\\n emphasis/" $ do - " /multi-line\n emphasis/" `shouldParseTo` - DocParagraph "/multi-line\n emphasis/\n" - context "when parsing codeblocks" $ do it "codeblock a word on its own" $ do "@quux@" `shouldParseTo` DocCodeBlock "quux" @@ -565,9 +563,6 @@ spec = do DocDefList [(DocMonospaced ("q" <> DocEmphasis "uu" <> "x"), " h\ney\n")] - it "/qu\\nux/" $ do - "/qu\nux/" `shouldParseTo` DocParagraph "/qu\nux/\n" - -- regression test it "requires markup to be fully closed, even if nested" $ do "@hel/lo" `shouldParseTo` DocParagraph "@hel/lo\n" -- cgit v1.2.3