diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,9 @@
+Changes in version 2.14.3
+
+ * Fix parsing of identifiers with ^ or ⋆ in them (#298)
+
+ * Fix anchors (#308)
+
Changes in version 2.14.2
* Always drop --split-objs GHC flag for performance reasons (#292)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Setup.lhs b/Setup.lhs
deleted file mode 100644
--- a/Setup.lhs
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/usr/bin/env runhaskell
-> import Distribution.Simple
-> main = defaultMain
diff --git a/doc/haddock.xml b/doc/haddock.xml
--- a/doc/haddock.xml
+++ b/doc/haddock.xml
@@ -21,7 +21,7 @@
Simon Marlow, David Waern
- This document describes Haddock version 2.14.1, a Haskell
+ This document describes Haddock version 2.14.3, a Haskell
documentation tool.
@@ -2101,8 +2101,12 @@
"module#label"
where module is the module name
containing the anchor, and label is
- the anchor label. The module does not have to be local, it
- can be imported via an interface.
+ the anchor label. The module does not have to be local, it can
+ be imported via an interface. Please note that in Haddock
+ versions 2.13.x and earlier, the syntax was
+ "module\#label".
+ This is deprecated as of version 2.14.3 and will be removed in
+ future versions.
diff --git a/haddock.cabal b/haddock.cabal
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -1,5 +1,5 @@
name: haddock
-version: 2.14.2
+version: 2.14.3
synopsis: A documentation-generation tool for Haskell libraries
description: Haddock is a documentation-generation tool for Haskell
libraries
@@ -8,7 +8,7 @@
author: Simon Marlow, David Waern
maintainer: Simon Hengel , Mateusz Kowalczyk
homepage: http://www.haskell.org/haddock/
-bug-reports: http://trac.haskell.org/haddock
+bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
@@ -83,7 +83,7 @@
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.10,
- ghc >= 7.7 && < 7.10,
+ ghc == 7.8.*,
bytestring
other-modules:
@@ -143,7 +143,7 @@
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.10,
- ghc >= 7.4 && < 7.10
+ ghc == 7.8.*
if flag(in-ghc-tree)
cpp-options: -DIN_GHC_TREE
diff --git a/html-test/ref/Bug298.html b/html-test/ref/Bug298.html
new file mode 100644
--- /dev/null
+++ b/html-test/ref/Bug298.html
@@ -0,0 +1,133 @@
+
+Bug298
diff --git a/html-test/run.lhs b/html-test/run.lhs
--- a/html-test/run.lhs
+++ b/html-test/run.lhs
@@ -134,9 +134,21 @@
else do
putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"
+-- | A rather nasty way to drop the Haddock version string from the
+-- end of the generated HTML files so that we don't have to change
+-- every single test every time we change versions. We rely on the the
+-- last paragraph of the document to be the version. We end up with
+-- malformed HTML but we don't care as we never look at it ourselves.
+dropVersion :: String -> String
+dropVersion = reverse . dropTillP . reverse
+ where
+ dropTillP [] = []
+ dropTillP ('p':'<':xs) = xs
+ dropTillP (_:xs) = dropTillP xs
haddockEq :: String -> String -> Bool
-haddockEq file1 file2 = stripLinks file1 == stripLinks file2
+haddockEq file1 file2 =
+ stripLinks (dropVersion file1) == stripLinks (dropVersion file2)
stripLinks :: String -> String
stripLinks str =
diff --git a/html-test/src/Bug298.hs b/html-test/src/Bug298.hs
new file mode 100644
--- /dev/null
+++ b/html-test/src/Bug298.hs
@@ -0,0 +1,22 @@
+-- We introduced a regression in 2.14.x where we don't consider
+-- identifiers with ^ as valid. We test that the regression goes away
+-- here. It's a silly typo in the parser, really. Same with ★ which is a valid
+-- symbol according to the 2010 report.
+module Bug298 where
+
+
+(<^>) :: (a -> a) -> a -> a
+x <^> y = x y
+
+(<^) :: a -> a -> a
+x <^ y = x
+
+(^>) :: a -> a -> a
+x ^> y = y
+
+(⋆^) :: a -> a -> a
+x ⋆^ y = y
+
+-- | Links to '<^>' and '^>', '<^' and '⋆^'.
+f :: ()
+f = ()
diff --git a/html-test/src/Bug308.hs b/html-test/src/Bug308.hs
new file mode 100644
--- /dev/null
+++ b/html-test/src/Bug308.hs
@@ -0,0 +1,21 @@
+-- From 2.14.x onwards we were forgetting to swallow ‘#’ as a special
+-- character resulting in broken anchors if they accured
+-- mid-paragraph. Here we check that anchors get generated as
+-- expected.
+module Bug308 where
+
+-- | start#startAnchor# followed by middle#middleAnchor# and end#endAnchor#
+f :: ()
+f = ()
+
+{-|
+start "Bug308#startAnchor"
+
+startOldStyle "Bug308\#startAnchor"
+
+middle "Bug308#middleAnchor"
+
+end "Bug308#middleAnchor"
+-}
+g :: ()
+g = ()
diff --git a/html-test/src/Bug308CrossModule.hs b/html-test/src/Bug308CrossModule.hs
new file mode 100644
--- /dev/null
+++ b/html-test/src/Bug308CrossModule.hs
@@ -0,0 +1,17 @@
+-- Just like Bug308 module but here we test that referring to anchors
+-- from other modules works.
+module Bug308CrossModule where
+
+import Bug308
+
+{-|
+start "Bug308#startAnchor"
+
+startOldStyle "Bug308\#startAnchor"
+
+middle "Bug308#middleAnchor"
+
+end "Bug308#middleAnchor"
+-}
+h :: ()
+h = ()
diff --git a/html-test/src/Bug85.hs b/html-test/src/Bug85.hs
--- a/html-test/src/Bug85.hs
+++ b/html-test/src/Bug85.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures #-}
-{-# OPTIONS_HADDOCK use-unicode #-}
module Bug85 where
-- explicitly stated non-trivial kind
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -42,7 +42,12 @@
markupIdentifier = thecode . ppId insertAnchors,
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
markupModule = \m -> let (mdl,ref) = break (=='#') m
- in ppModuleRef (mkModuleName mdl) ref,
+ -- Accomodate for old style
+ -- foo\#bar anchors
+ mdl' = case reverse mdl of
+ '\\':_ -> init mdl
+ _ -> mdl
+ in ppModuleRef (mkModuleName mdl') ref,
markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
markupBold = strong,
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -94,10 +94,10 @@
(synifyType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- let (_, _, (req_theta, prov_theta)) = patSynSig ps
+ let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
in SigD $ PatSynSig (synifyName ps)
(fmap (synifyType WithinType) (patSynTyDetails ps))
- (synifyType WithinType (patSynType ps))
+ (synifyType WithinType res_ty)
(synifyCtx req_theta)
(synifyCtx prov_theta)
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -364,7 +364,7 @@
where
decls = docs ++ defs ++ sigs ++ ats
docs = mkDecls tcdDocs DocD class_
- defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_
+ defs = mkDecls (bagToList . tcdMeths) ValD class_
sigs = mkDecls tcdSigs SigD class_
ats = mkDecls tcdATs (TyClD . FamDecl) class_
@@ -384,13 +384,13 @@
ungroup :: HsGroup Name -> [LHsDecl Name]
ungroup group_ =
mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls hs_instds InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
- mkDecls (map snd . valbinds . hs_valds) ValD group_
+ mkDecls hs_derivds DerivD group_ ++
+ mkDecls hs_defds DefD group_ ++
+ mkDecls hs_fords ForD group_ ++
+ mkDecls hs_docs DocD group_ ++
+ mkDecls hs_instds InstD group_ ++
+ mkDecls (typesigs . hs_valds) SigD group_ ++
+ mkDecls (valbinds . hs_valds) ValD group_
where
typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
typesigs _ = error "expected ValBindsOut"
diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs
--- a/src/Haddock/Parser.hs
+++ b/src/Haddock/Parser.hs
@@ -85,8 +85,11 @@
num = hex <|> decimal
hex = ("x" <|> "X") *> hexadecimal
+-- | List of characters that we use to delimit any special markup.
+-- 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
@@ -140,7 +143,8 @@
-- >>> parseOnly anchor "#Hello world#"
-- Right (DocAName "Hello world")
anchor :: Parser (Doc a)
-anchor = DocAName . decodeUtf8 <$> ("#" *> takeWhile1 (`notElem` "#\n") <* "#")
+anchor = DocAName . decodeUtf8 <$>
+ disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")
-- | Monospaced strings.
--
@@ -158,7 +162,8 @@
-- NOTE: According to Haskell 2010 we shouldd actually only
-- accept {small | large | digit | ' } here. But as we can't
-- match on unicode characters, this is currently not possible.
- <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!#|@/;,^?\"\n"))
+ -- Note that we allow ‘#’ to suport anchors.
+ <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!|@/;,^?\"\n"))
-- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify
-- a title for the picture.
@@ -419,13 +424,21 @@
-- characters and does no actual validation itself.
parseValid :: Parser String
parseValid = do
- vs <- many' $ satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:") <|> digit <|> letter_ascii
+ vs' <- many' $ utf8String "⋆" <|> return <$> idChar
+ let vs = concat vs'
c <- peekChar
case c of
Just '`' -> return vs
Just '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> parseValid)
<|> return vs
_ -> fail "outofvalid"
+ where
+ idChar = satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:^")
+ <|> digit <|> letter_ascii
+
+-- | Parses UTF8 strings from ByteString streams.
+utf8String :: String -> Parser String
+utf8String x = decodeUtf8 <$> string (encodeUtf8 x)
-- | Parses identifiers with help of 'parseValid'. Asks GHC for 'RdrName' from the
-- string it deems valid.
diff --git a/test/Haddock/ParserSpec.hs b/test/Haddock/ParserSpec.hs
--- a/test/Haddock/ParserSpec.hs
+++ b/test/Haddock/ParserSpec.hs
@@ -185,6 +185,13 @@
it "does not accept newlines in anchors" $ do
"#foo\nbar#" `shouldParseTo` "#foo\nbar#"
+ it "accepts anchors mid-paragraph" $ do
+ "Hello #someAnchor# world!"
+ `shouldParseTo` "Hello " <> DocAName "someAnchor" <> " world!"
+
+ it "does not accept empty anchors" $ do
+ "##" `shouldParseTo` "##"
+
context "when parsing emphasised text" $ do
it "emphasises a word on its own" $ do
"/foo/" `shouldParseTo` DocEmphasis "foo"
@@ -307,6 +314,12 @@
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"
+
+ it "accepts old anchor reference syntax as DocModule" $ do
+ "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar"
describe "parseParas" $ do
let infix 1 `shouldParseTo`