From dd47029cb29c80b1ab4db520c9c2ce4dca37f833 Mon Sep 17 00:00:00 2001
From: Alec Theriault
Date: Thu, 19 Jul 2018 11:42:26 -0700
Subject: Support value/type namespaces on identifier links
Identifier links can be prefixed with a 'v' or 't' to indicate the value or
type namespace of the desired identifier. For example:
-- | Some link to a value: v'Data.Functor.Identity'
--
-- Some link to a type: t'Data.Functor.Identity'
The default is still the type (with a warning about the ambiguity)
---
haddock-api/src/Haddock/Types.hs | 6 ++++++
1 file changed, 6 insertions(+)
(limited to 'haddock-api/src/Haddock/Types.hs')
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a4ef5f82..e8da4120 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -284,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty)
-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
+-- | An 'RdrName' tagged with some type/value namespace information.
+data NsRdrName = NsRdrName
+ { namespace :: !Namespace
+ , rdrName :: !RdrName
+ }
+
-- | Extends 'Name' with cross-reference information.
data DocName
= Documented Name Module
--
cgit v1.2.3
From a5199600c39d25d7b71dcb2328000c1c49ad95a2 Mon Sep 17 00:00:00 2001
From: Alec Theriault
Date: Wed, 6 Feb 2019 01:01:41 -0800
Subject: Better identifier parsing
* '(<|>)' and '`elem`' now get parsed and rendered properly as links
* 'DbModule'/'DbUnitId' now properly get split apart into two links
* tuple names now get parsed properly
* some more small niceties...
The identifier parsing code is more precise and more efficient (although to be
fair: it is also longer and in its own module). On the rendering side, we need
to pipe through information about backticks/parens/neither all the way through
from renaming to the backends.
In terms of impact: a total of 35 modules in the entirety of the bootlib + ghc
lib docs change. The only "regression" is things like '\0'. These should be
changed to @\\0@ (the path by which this previously worked seems accidental).
---
doc/markup.rst | 9 +-
haddock-api/src/Haddock.hs | 2 +-
haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +-
haddock-api/src/Haddock/Backends/LaTeX.hs | 19 +-
.../src/Haddock/Backends/Xhtml/DocMarkup.hs | 16 +-
haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 28 +-
haddock-api/src/Haddock/Interface/Json.hs | 5 +-
haddock-api/src/Haddock/Interface/LexParseRn.hs | 58 +++--
haddock-api/src/Haddock/Interface/Rename.hs | 4 +-
haddock-api/src/Haddock/InterfaceFile.hs | 27 +-
haddock-api/src/Haddock/Parser.hs | 19 +-
haddock-api/src/Haddock/Types.hs | 28 +-
haddock-library/haddock-library.cabal | 2 +
.../src/Documentation/Haddock/Parser.hs | 63 +----
.../src/Documentation/Haddock/Parser/Identifier.hs | 186 ++++++++++++++
.../src/Documentation/Haddock/Parser/Monad.hs | 13 +-
.../test/Documentation/Haddock/ParserSpec.hs | 9 +-
haddock.cabal | 1 +
html-test/ref/Identifiers.html | 286 +++++++++++++++++++++
html-test/ref/Test.html | 2 +-
html-test/src/Identifiers.hs | 35 +++
21 files changed, 679 insertions(+), 135 deletions(-)
create mode 100644 haddock-library/src/Documentation/Haddock/Parser/Identifier.hs
create mode 100644 html-test/ref/Identifiers.html
create mode 100644 html-test/src/Identifiers.hs
(limited to 'haddock-api/src/Haddock/Types.hs')
diff --git a/doc/markup.rst b/doc/markup.rst
index 48a6f4ad..56238855 100644
--- a/doc/markup.rst
+++ b/doc/markup.rst
@@ -932,14 +932,9 @@ necessary to escape the single quote when used as an apostrophe: ::
Nothing special is needed to hyperlink identifiers which contain
apostrophes themselves: to hyperlink ``foo'`` one would simply type
-``'foo''``. Hyperlinking operators works in exactly the same way.
+``'foo''``. Hyperlinking operators works in exactly the same way. ::
-Note that it is not possible to directly hyperlink an identifier in infix
-form or an operator in prefix form. The next best thing to do is to wrap
-the whole identifier in monospaced text and put the parentheses/backticks
-outside of the identifier, but inside the link: ::
-
- -- | A prefix operator @('++')@ and an infix identifier @\``elem`\`@.
+ -- | A prefix operator @'(++)'@ and an infix identifier @'`elem`'@.
Emphasis, Bold and Monospaced Text
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 1378c173..3e0332b5 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -663,7 +663,7 @@ getPrologue dflags flags =
h <- openFile filename ReadMode
hSetEncoding h utf8
str <- hGetContents h -- semi-closes the handle
- return . Just $! second rdrName $ parseParas dflags Nothing str
+ return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str
_ -> throwE "multiple -p/--prologue options"
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9e3186e5..f581c01a 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -334,7 +334,7 @@ markupTag dflags = Markup {
markupString = str,
markupAppend = (++),
markupIdentifier = box (TagInline "a") . str . out dflags,
- markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
+ markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd),
markupModule = box (TagInline "a") . str,
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d0752506..85769b13 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1106,8 +1106,8 @@ ppSymName name
| otherwise = ppName name
-ppVerbOccName :: OccName -> LaTeX
-ppVerbOccName = text . latexFilter . occNameString
+ppVerbOccName :: Wrap OccName -> LaTeX
+ppVerbOccName = text . latexFilter . showWrapped occNameString
ppIPName :: HsIPName -> LaTeX
ppIPName = text . ('?':) . unpackFS . hsIPNameFS
@@ -1115,13 +1115,12 @@ ppIPName = text . ('?':) . unpackFS . hsIPNameFS
ppOccName :: OccName -> LaTeX
ppOccName = text . occNameString
+ppVerbDocName :: Wrap DocName -> LaTeX
+ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName)
-ppVerbDocName :: DocName -> LaTeX
-ppVerbDocName = ppVerbOccName . nameOccName . getName
-
-ppVerbRdrName :: RdrName -> LaTeX
-ppVerbRdrName = ppVerbOccName . rdrNameOcc
+ppVerbRdrName :: Wrap RdrName -> LaTeX
+ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc)
ppDocName :: DocName -> LaTeX
@@ -1182,7 +1181,7 @@ parLatexMarkup ppId = Markup {
markupString = \s v -> text (fixString v s),
markupAppend = \l r v -> l v <> r v,
markupIdentifier = markupId ppId,
- markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
+ markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd),
markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
markupWarning = \p v -> emph (p v),
markupEmphasis = \p v -> emph (p v),
@@ -1239,11 +1238,11 @@ parLatexMarkup ppId = Markup {
where theid = ppId_ id
-latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
+latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX)
latexMarkup = parLatexMarkup ppVerbDocName
-rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
+rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX)
rdrLatexMarkup = parLatexMarkup ppVerbRdrName
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 09aabc0c..1901cf05 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -171,12 +171,12 @@ flatten x = [x]
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- 'CollapsingHeader', we attach extra info to the generated 'Html'
-- that allows us to expand/collapse the content.
-hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html
hackMarkup fmt' currPkg h' =
let (html, ms) = hackMarkup' fmt' h'
in html +++ renderMeta fmt' currPkg (metaConcat ms)
where
- hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
+ hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id
-> (Html, [Meta])
hackMarkup' fmt h = case h of
UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
@@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml
-- | Goes through 'hackMarkup' to generate the 'Html' rather than
-- skipping straight to 'markup': this allows us to employ XHtml
-- specific hacks to the tree first.
-markupHacked :: DocMarkup id Html
+markupHacked :: DocMarkup (Wrap id) Html
-> Maybe Package -- this package
-> Maybe String
-> MDoc id
@@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See
-> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
- where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
+ where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw)
-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
@@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
-> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
- where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+ where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw)
origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
- where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+ where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw))
rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
- where fmt = parHtmlMarkup qual True (const ppRdrName)
+ where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap))
docElement :: (Html -> Html) -> Html -> Html
@@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists)
unParagraph (DocParagraph d) = d
unParagraph doc = doc
- fmtUnParagraphLists :: DocMarkup a (Doc a)
+ fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
fmtUnParagraphLists = idMarkup {
markupUnorderedList = DocUnorderedList . map unParagraph,
markupOrderedList = DocOrderedList . map unParagraph
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 574045e0..6a047747 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -13,7 +13,8 @@
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinderInfix, ppBinder',
- ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
+ ppModule, ppModuleRef, ppIPName, linkId, Notation(..),
+ ppWrappedDocName, ppWrappedName,
) where
@@ -24,7 +25,7 @@ import Haddock.Utils
import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
-import qualified Data.List as List
+import Data.List ( stripPrefix )
import GHC hiding (LexicalFixity(..))
import Name
@@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html
ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
-ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
-ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
-
+ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
+ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
+ where
+ (mdl, occ) = unwrap x
+ occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
-- The Bool indicates if it is to be rendered in infix notation
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
@@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName =
ppQualifyName qual notation name (nameModule name)
| otherwise -> ppName notation name
+
+ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
+ppWrappedDocName qual notation insertAnchors docName = case docName of
+ Unadorned n -> ppDocName qual notation insertAnchors n
+ Parenthesized n -> ppDocName qual Prefix insertAnchors n
+ Backticked n -> ppDocName qual Infix insertAnchors n
+
+ppWrappedName :: Notation -> Wrap Name -> Html
+ppWrappedName notation docName = case docName of
+ Unadorned n -> ppName notation n
+ Parenthesized n -> ppName Prefix n
+ Backticked n -> ppName Infix n
+
-- | Render a name depending on the selected qualification mode
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName qual notation name mdl =
@@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl =
then ppName notation name
else ppFullQualName notation mdl name
RelativeQual localmdl ->
- case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+ case stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
Just [] -> ppName notation name
-- sub-module, A.B.x -> B.x
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 636d3e19..a9834fa0 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} =
]
jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+jsonDoc doc = jsonString (show (bimap showModName showName doc))
+ where
+ showModName = showWrapped (moduleNameString . fst)
+ showName = showWrapped nameStableString
jsonModule :: Module -> JsonDoc
jsonModule = JSString . moduleStableString
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 66083cf5..faf23728 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -22,6 +22,7 @@ module Haddock.Interface.LexParseRn
import Avail
import Control.Arrow
import Control.Monad
+import Data.Functor (($>))
import Data.List
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
@@ -95,8 +96,9 @@ rename dflags gre = rn
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
DocParagraph doc -> DocParagraph <$> rn doc
- DocIdentifier (NsRdrName ns x) -> do
- let occ = rdrNameOcc x
+ DocIdentifier i -> do
+ let NsRdrName ns x = unwrap i
+ occ = rdrNameOcc x
isValueName = isDataOcc occ || isVarOcc occ
let valueNsChoices | isValueName = [x]
@@ -119,7 +121,7 @@ rename dflags gre = rn
case choices of
-- The only way this can happen is if a value namespace was
-- specified on something that cannot be a value.
- [] -> invalidValue dflags x
+ [] -> invalidValue dflags i
-- There was nothing in the environment so we need to
-- pick some default from what's available to us. We
@@ -129,14 +131,14 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> outOfScope dflags ns a
+ a:_ -> outOfScope dflags ns (i $> a)
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier (gre_name a))
+ [a] -> pure (DocIdentifier (i $> gre_name a))
-- There are multiple names available.
- gres -> ambiguous dflags x gres
+ gres -> ambiguous dflags i gres
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -168,13 +170,13 @@ rename dflags gre = rn
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a)
+outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
outOfScope dflags ns x =
- case x of
- Unqual occ -> warnAndMonospace occ
- Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
- Orig _ occ -> warnAndMonospace occ
- Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
+ case unwrap x of
+ Unqual occ -> warnAndMonospace (x $> occ)
+ Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+ Orig _ occ -> warnAndMonospace (x $> occ)
+ Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
where
prefix = case ns of
Value -> "the value "
@@ -182,11 +184,11 @@ outOfScope dflags ns x =
None -> ""
warnAndMonospace a = do
- tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++
- " If you qualify the identifier, haddock can try to link it\n" ++
- " it anyway."]
- pure (monospaced a)
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
+ let a' = showWrapped (showPpr dflags) a
+ tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
+ " If you qualify the identifier, haddock can try to link it anyway."]
+ pure (monospaced a')
+ monospaced = DocMonospaced . DocString
-- | Handle ambiguous identifiers.
--
@@ -194,36 +196,42 @@ outOfScope dflags ns x =
--
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
ambiguous :: DynFlags
- -> RdrName
+ -> Wrap NsRdrName
-> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
-> ErrMsgM (Doc Name)
ambiguous dflags x gres = do
let noChildren = map availName (gresToAvailInfo gres)
dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
+ msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
" You may be able to disambiguate the identifier by qualifying it or\n" ++
" by specifying the type/value namespace explicitly.\n" ++
- " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ " Defaulting to the one defined " ++ defnLoc dflt
-- TODO: Once we have a syntax for namespace qualification (#667) we may also
-- want to emit a warning when an identifier is a data constructor for a type
-- of the same name, but not the only constructor.
-- For example, for @data D = C | D@, someone may want to reference the @D@
-- constructor.
when (length noChildren > 1) $ tell [msg]
- pure (DocIdentifier dflt)
+ pure (DocIdentifier (x $> dflt))
where
isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
isLocalName _ = False
- x_str = '\'' : showPpr dflags x ++ "'"
defnLoc = showSDoc dflags . pprNameDefnLoc
-- | Handle value-namespaced names that cannot be for values.
--
-- Emits a warning that the value-namespace is invalid on a non-value identifier.
-invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a)
+invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
invalidValue dflags x = do
- tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++
+ tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
" namespaced as such. Did you mean to specify a type namespace\n" ++
" instead?"]
- pure (DocMonospaced (DocString (showPpr dflags x)))
+ pure (DocMonospaced (DocString (showNsRdrName dflags x)))
+
+-- | Printable representation of a wrapped and namespaced name
+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
+ where
+ ident = showWrapped (showPpr dflags . rdrName)
+ prefix = renderNs . namespace . unwrap
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 57e6d699..88238f04 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -173,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
renameLDocHsSyn = return
-renameDoc :: Traversable t => t Name -> RnM (t DocName)
-renameDoc = traverse rename
+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
+renameDoc = traverse (traverse rename)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index e1d8dbe1..7645b1bb 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
-binaryInterfaceVersion = 34
+binaryInterfaceVersion = 35
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -701,3 +701,28 @@ instance Binary DocName where
name <- get bh
return (Undocumented name)
_ -> error "get DocName: Bad h"
+
+instance Binary n => Binary (Wrap n) where
+ put_ bh (Unadorned n) = do
+ putByte bh 0
+ put_ bh n
+ put_ bh (Parenthesized n) = do
+ putByte bh 1
+ put_ bh n
+ put_ bh (Backticked n) = do
+ putByte bh 2
+ put_ bh n
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ name <- get bh
+ return (Unadorned name)
+ 1 -> do
+ name <- get bh
+ return (Parenthesized name)
+ 2 -> do
+ name <- get bh
+ return (Backticked name)
+ _ -> error "get Wrap: Bad h"
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index 8b7dda7c..6d5dc103 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -15,27 +15,32 @@ module Haddock.Parser ( parseParas
import qualified Documentation.Haddock.Parser as P
import Documentation.Haddock.Types
-import Haddock.Types (NsRdrName(..))
+import Haddock.Types
import DynFlags ( DynFlags )
import FastString ( fsLit )
import Lexer ( mkPState, unP, ParseResult(POk) )
import Parser ( parseIdentifier )
-import RdrName ( RdrName )
import SrcLoc ( mkRealSrcLoc, GenLocated(..) )
import StringBuffer ( stringToStringBuffer )
-parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName
+
+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
-parseString :: DynFlags -> String -> DocH mod NsRdrName
+parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
parseString d = P.overIdentifier (parseIdent d) . P.parseString
-parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName
+parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
parseIdent dflags ns str0 =
- let buffer = stringToStringBuffer str0
+ let buffer = stringToStringBuffer str1
realSrcLc = mkRealSrcLoc (fsLit "") 0 0
pstate = mkPState dflags buffer realSrcLc
+ (wrap,str1) = case str0 of
+ '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names
+ -> (Parenthesized, init s)
+ '`' : s@(_ : _) -> (Backticked, init s)
+ _ -> (Unadorned, str0)
in case unP parseIdentifier pstate of
- POk _ (L _ name) -> Just (NsRdrName ns name)
+ POk _ (L _ name) -> Just (wrap (NsRdrName ns name))
_ -> Nothing
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e8da4120..cd4ac1a1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -42,7 +42,7 @@ import GHC
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
import OccName
-import Outputable
+import Outputable hiding ((<>))
-----------------------------------------------------------------------------
-- * Convenient synonyms
@@ -334,6 +334,26 @@ instance SetName DocName where
setName name' (Documented _ mdl) = Documented name' mdl
setName name' (Undocumented _) = Undocumented name'
+-- | Adds extra "wrapper" information to a name.
+--
+-- This is to work around the fact that most name types in GHC ('Name', 'RdrName',
+-- 'OccName', ...) don't include backticks or parens.
+data Wrap n
+ = Unadorned { unwrap :: n } -- ^ don't do anything to the name
+ | Parenthesized { unwrap :: n } -- ^ add parentheses around the name
+ | Backticked { unwrap :: n } -- ^ add backticks around the name
+ deriving (Show, Functor, Foldable, Traversable)
+
+-- | Useful for debugging
+instance Outputable n => Outputable (Wrap n) where
+ ppr (Unadorned n) = ppr n
+ ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ]
+ ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ]
+
+showWrapped :: (a -> String) -> Wrap a -> String
+showWrapped f (Unadorned n) = f n
+showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"
+showWrapped f (Backticked n) = "`" ++ f n ++ "`"
-----------------------------------------------------------------------------
@@ -429,10 +449,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where
type LDoc id = Located (Doc id)
-type Doc id = DocH (ModuleName, OccName) id
-type MDoc id = MetaDoc (ModuleName, OccName) id
+type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id)
+type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id)
-type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index b24db5d4..5475d61b 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -49,6 +49,7 @@ library
other-modules:
Documentation.Haddock.Parser.Util
Documentation.Haddock.Parser.Monad
+ Documentation.Haddock.Parser.Identifier
test-suite spec
import: lib-defaults
@@ -70,6 +71,7 @@ test-suite spec
Documentation.Haddock.Parser.UtilSpec
Documentation.Haddock.ParserSpec
Documentation.Haddock.Types
+ Documentation.Haddock.Parser.Identifier
build-depends:
, base-compat ^>= 0.9.3 || ^>= 0.10.0
diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs
index e9b1c496..36c8bb5b 100644
--- a/haddock-library/src/Documentation/Haddock/Parser.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser.hs
@@ -27,8 +27,7 @@ module Documentation.Haddock.Parser (
import Control.Applicative
import Control.Arrow (first)
import Control.Monad
-import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace)
-import Data.Foldable (asum)
+import Data.Char (chr, isUpper, isAlpha, isSpace)
import Data.List (intercalate, unfoldr, elemIndex)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
@@ -37,6 +36,7 @@ import Documentation.Haddock.Doc
import Documentation.Haddock.Markup ( markup, plainMarkup )
import Documentation.Haddock.Parser.Monad
import Documentation.Haddock.Parser.Util
+import Documentation.Haddock.Parser.Identifier
import Documentation.Haddock.Types
import Prelude hiding (takeWhile)
import qualified Prelude as P
@@ -47,37 +47,10 @@ import Text.Parsec (try)
import qualified Data.Text as T
import Data.Text (Text)
-#if MIN_VERSION_base(4,9,0)
-import Text.Read.Lex (isSymbolChar)
-#else
-import Data.Char (GeneralCategory (..),
- generalCategory)
-#endif
-- $setup
-- >>> :set -XOverloadedStrings
-#if !MIN_VERSION_base(4,9,0)
--- inlined from base-4.10.0.0
-isSymbolChar :: Char -> Bool
-isSymbolChar c = not (isPuncChar c) && case generalCategory c of
- MathSymbol -> True
- CurrencySymbol -> True
- ModifierSymbol -> True
- OtherSymbol -> True
- DashPunctuation -> True
- OtherPunctuation -> c `notElem` ("'\"" :: String)
- ConnectorPunctuation -> c /= '_'
- _ -> False
- where
- -- | The @special@ character class as defined in the Haskell Report.
- isPuncChar :: Char -> Bool
- isPuncChar = (`elem` (",;()[]{}`" :: String))
-#endif
-
--- | Identifier string surrounded with opening and closing quotes/backticks.
-data Identifier = Identifier !Namespace !Char String !Char
-
-- | Drops the quotes/backticks around all identifiers, as if they
-- were valid but still 'String's.
toRegular :: DocH mod Identifier -> DocH mod String
@@ -838,34 +811,6 @@ autoUrl = mkLink <$> url
mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing
-
--- | Parses strings between identifier delimiters. Consumes all input that it
--- deems to be valid in an identifier. Note that it simply blindly consumes
--- characters and does no actual validation itself.
-parseValid :: Parser String
-parseValid = p some
- where
- idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_')
-
- p p' = do
- vs <- p' idChar
- c <- peekChar'
- case c of
- '`' -> return vs
- '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ]
- _ -> fail "outofvalid"
-
--- | Parses identifiers with help of 'parseValid'. Asks GHC for
--- 'String' from the string it deems valid.
+-- | Parses identifiers with help of 'parseValid'.
identifier :: Parser (DocH mod Identifier)
-identifier = do
- ns <- asum [ Value <$ Parsec.char 'v'
- , Type <$ Parsec.char 't'
- , pure None
- ]
- o <- idDelim
- vid <- parseValid
- e <- idDelim
- return $ DocIdentifier (Identifier ns o vid e)
- where
- idDelim = Parsec.oneOf "'`"
+identifier = DocIdentifier <$> parseValid
diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs
new file mode 100644
index 00000000..7bc98b62
--- /dev/null
+++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs
@@ -0,0 +1,186 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+-- |
+-- Module : Documentation.Haddock.Parser.Identifier
+-- Copyright : (c) Alec Theriault 2019,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Functionality for parsing identifiers and operators
+
+module Documentation.Haddock.Parser.Identifier (
+ Identifier(..),
+ parseValid,
+) where
+
+import Documentation.Haddock.Types ( Namespace(..) )
+import Documentation.Haddock.Parser.Monad
+import qualified Text.Parsec as Parsec
+import Text.Parsec.Pos ( updatePosChar )
+import Text.Parsec ( State(..)
+ , getParserState, setParserState )
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Data.Char (isAlpha, isAlphaNum)
+import Control.Monad (guard)
+import Data.Functor (($>))
+#if MIN_VERSION_base(4,9,0)
+import Text.Read.Lex (isSymbolChar)
+#else
+import Data.Char (GeneralCategory (..),
+ generalCategory)
+#endif
+
+import Data.Maybe
+
+-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks.
+data Identifier = Identifier !Namespace !Char String !Char
+ deriving (Show, Eq)
+
+parseValid :: Parser Identifier
+parseValid = do
+ s@State{ stateInput = inp, statePos = pos } <- getParserState
+
+ case takeIdentifier inp of
+ Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier"
+ Just (ns, op, ident, cl, inp') ->
+ let posOp = updatePosChar pos op
+ posIdent = T.foldl updatePosChar posOp ident
+ posCl = updatePosChar posIdent cl
+ s' = s{ stateInput = inp', statePos = posCl }
+ in setParserState s' $> Identifier ns op (T.unpack ident) cl
+
+
+#if !MIN_VERSION_base(4,9,0)
+-- inlined from base-4.10.0.0
+isSymbolChar :: Char -> Bool
+isSymbolChar c = not (isPuncChar c) && case generalCategory c of
+ MathSymbol -> True
+ CurrencySymbol -> True
+ ModifierSymbol -> True
+ OtherSymbol -> True
+ DashPunctuation -> True
+ OtherPunctuation -> c `notElem` "'\""
+ ConnectorPunctuation -> c /= '_'
+ _ -> False
+ where
+ -- | The @special@ character class as defined in the Haskell Report.
+ isPuncChar :: Char -> Bool
+ isPuncChar = (`elem` (",;()[]{}`" :: String))
+#endif
+
+-- | Try to parse a delimited identifier off the front of the given input.
+--
+-- This tries to match as many valid Haskell identifiers/operators as possible,
+-- to the point of sometimes accepting invalid things (ex: keywords). Some
+-- considerations:
+--
+-- - operators and identifiers can have module qualifications
+-- - operators can be wrapped in parens (for prefix)
+-- - identifiers can be wrapped in backticks (for infix)
+-- - delimiters are backticks or regular ticks
+-- - since regular ticks are also valid in identifiers, we opt for the
+-- longest successful parse
+--
+-- This function should make /O(1)/ allocations
+takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text)
+takeIdentifier input = listToMaybe $ do
+
+ -- Optional namespace
+ let (ns, input') = case T.uncons input of
+ Just ('v', i) -> (Value, i)
+ Just ('t', i) -> (Type, i)
+ _ -> (None, input)
+
+ -- Opening tick
+ (op, input'') <- maybeToList (T.uncons input')
+ guard (op == '\'' || op == '`')
+
+ -- Identifier/operator
+ (ident, input''') <- wrapped input''
+
+ -- Closing tick
+ (cl, input'''') <- maybeToList (T.uncons input''')
+ guard (cl == '\'' || cl == '`')
+
+ pure (ns, op, ident, cl, input'''')
+
+ where
+
+ -- | Parse out a wrapped, possibly qualified, operator or identifier
+ wrapped t = do
+ (c, t' ) <- maybeToList (T.uncons t)
+ -- Tuples
+ case c of
+ '(' | Just (c', _) <- T.uncons t'
+ , c' == ',' || c' == ')'
+ -> do let (commas, t'') = T.span (== ',') t'
+ (')', t''') <- maybeToList (T.uncons t'')
+ pure (T.take (T.length commas + 2) t, t''')
+
+ -- Parenthesized
+ '(' -> do (n, t'' ) <- general False 0 [] t'
+ (')', t''') <- maybeToList (T.uncons t'')
+ pure (T.take (n + 2) t, t''')
+
+ -- Backticked
+ '`' -> do (n, t'' ) <- general False 0 [] t'
+ ('`', t''') <- maybeToList (T.uncons t'')
+ pure (T.take (n + 2) t, t''')
+
+ -- Unadorned
+ _ -> do (n, t'' ) <- general False 0 [] t
+ pure (T.take n t, t'')
+
+ -- | Parse out a possibly qualified operator or identifier
+ general :: Bool -- ^ refuse inputs starting with operators
+ -> Int -- ^ total characters \"consumed\" so far
+ -> [(Int, Text)] -- ^ accumulated results
+ -> Text -- ^ current input
+ -> [(Int, Text)] -- ^ total characters parsed & what remains
+ general !identOnly !i acc t
+ -- Starts with an identifier (either just an identifier, or a module qual)
+ | Just (n, rest) <- identLike t
+ = if T.null rest
+ then acc
+ else case T.head rest of
+ '`' -> (n + i, rest) : acc
+ ')' -> (n + i, rest) : acc
+ '.' -> general False (n + i + 1) acc (T.tail rest)
+ '\'' -> let (m, rest') = quotes rest
+ in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest')
+ _ -> acc
+
+ -- An operator
+ | Just (n, rest) <- optr t
+ , not identOnly
+ = (n + i, rest) : acc
+
+ -- Anything else
+ | otherwise
+ = acc
+
+ -- | Parse an identifier off the front of the input
+ identLike t
+ | T.null t = Nothing
+ | isAlpha (T.head t) || '_' == T.head t
+ = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t
+ !(octos, rest') = T.span (== '#') rest
+ in Just (T.length idt + T.length octos, rest')
+ | otherwise = Nothing
+
+ -- | Parse all but the last quote off the front of the input
+ -- PRECONDITION: T.head t == '\''
+ quotes :: Text -> (Int, Text)
+ quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1
+ in (n, T.drop n t)
+
+ -- | Parse an operator off the front of the input
+ optr t = let !(op, rest) = T.span isSymbolChar t
+ in if T.null op then Nothing else Just (T.length op, rest)
diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs
index 8f5bd217..fa46f536 100644
--- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs
+++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs
@@ -4,6 +4,18 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
+-- |
+-- Module : Documentation.Haddock.Parser.Monad
+-- Copyright : (c) Alec Theriault 2018-2019,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Defines the Parsec monad over which all parsing is done and also provides
+-- more efficient versions of the usual parsec combinator functions (but
+-- specialized to 'Text').
module Documentation.Haddock.Parser.Monad where
@@ -96,7 +108,6 @@ takeWhile f = do
s' = s{ stateInput = inp', statePos = pos' }
setParserState s' $> t
-
-- | Like 'takeWhile', but fails if no characters matched.
--
-- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient.
diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
index e186a5cf..bc40a0a2 100644
--- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs
+++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs
@@ -112,7 +112,7 @@ spec = do
"``" `shouldParseTo` "``"
it "can parse an identifier in infix notation enclosed within backticks" $ do
- "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`"
+ "``infix``" `shouldParseTo` DocIdentifier "`infix`"
it "can parse identifiers containing a single quote" $ do
"'don't'" `shouldParseTo` DocIdentifier "don't"
@@ -138,6 +138,13 @@ spec = do
it "can parse type-namespaced identifiers" $ do
"t'foo'" `shouldParseTo` DocIdentifier "foo"
+ it "can parse parenthesized operators and backticked identifiers" $ do
+ "'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)"
+ "'`elem`'" `shouldParseTo` DocIdentifier "`elem`"
+
+ it "can properly figure out the end of identifiers" $ do
+ "'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId"
+
context "when parsing operators" $ do
it "can parse an operator enclosed within single quotes" $ do
"'.='" `shouldParseTo` DocIdentifier ".="
diff --git a/haddock.cabal b/haddock.cabal
index 2b8ee6ff..91a5ea3d 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -89,6 +89,7 @@ executable haddock
other-modules:
Documentation.Haddock.Parser
Documentation.Haddock.Parser.Monad
+ Documentation.Haddock.Parser.Identifier
Documentation.Haddock.Types
Documentation.Haddock.Doc
Documentation.Haddock.Parser.Util
diff --git a/html-test/ref/Identifiers.html b/html-test/ref/Identifiers.html
new file mode 100644
index 00000000..1a0a18a5
--- /dev/null
+++ b/html-test/ref/Identifiers.html
@@ -0,0 +1,286 @@
+Identifiers
diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html
index b76622e7..aefc4d14 100644
--- a/html-test/ref/Test.html
+++ b/html-test/ref/Test.html
@@ -2364,7 +2364,7 @@ is at the beginning of the line).f'
- but f' doesn't get link'd 'f\''
Date: Fri, 8 Mar 2019 13:23:37 -0800
Subject: Better support for default methods in classes
* default methods now get rendered differently
* default associated types get rendered
* fix a forgotten `s/TypeSig/ClassOpSig/` refactor in LaTeX backend
* LaTeX backend now renders default method signatures
NB: there is still no way to document default class members and the
NB: LaTeX backend still crashes on associated types
---
CHANGES.md | 3 +
haddock-api/src/Haddock/Backends/LaTeX.hs | 47 +++---
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 99 +++++++----
haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 +
haddock-api/src/Haddock/Types.hs | 3 +
html-test/ref/DefaultAssociatedTypes.html | 158 ++++++++++++++++++
html-test/ref/DefaultSignatures.html | 182 +++++++++++++++++++++
html-test/src/DefaultAssociatedTypes.hs | 14 ++
html-test/src/DefaultSignatures.hs | 19 +++
.../ref/DefaultSignatures/DefaultSignatures.tex | 41 +++++
latex-test/ref/DefaultSignatures/haddock.sty | 57 +++++++
latex-test/ref/DefaultSignatures/main.tex | 11 ++
.../src/DefaultSignatures/DefaultSignatures.hs | 19 +++
13 files changed, 606 insertions(+), 51 deletions(-)
create mode 100644 html-test/ref/DefaultAssociatedTypes.html
create mode 100644 html-test/ref/DefaultSignatures.html
create mode 100644 html-test/src/DefaultAssociatedTypes.hs
create mode 100644 html-test/src/DefaultSignatures.hs
create mode 100644 latex-test/ref/DefaultSignatures/DefaultSignatures.tex
create mode 100644 latex-test/ref/DefaultSignatures/haddock.sty
create mode 100644 latex-test/ref/DefaultSignatures/main.tex
create mode 100644 latex-test/src/DefaultSignatures/DefaultSignatures.hs
(limited to 'haddock-api/src/Haddock/Types.hs')
diff --git a/CHANGES.md b/CHANGES.md
index 15a88221..bd4317bf 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -23,6 +23,9 @@
* `--show-interface` now outputs to stdout (instead of stderr)
+ * Render associated type defaults and also improve rendering of
+ default method signatures
+
## Changes in version 2.22.0
* Make `--package-version` optional for `--hoogle` (#899)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 119bbc01..d2baefac 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -295,7 +295,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
InstD _ _ -> empty
@@ -307,7 +307,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
- ppFunSig doc [name] (hsSigType typ) unicode
+ ppFunSig Nothing doc [name] (hsSigType typ) unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -414,17 +414,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI
- -> Bool -> LaTeX
-ppFunSig doc docnames (L _ typ) unicode =
+ppFunSig
+ :: Maybe LaTeX -- ^ a prefix to put right before the signature
+ -> DocForDecl DocName -- ^ documentation
+ -> [DocName] -- ^ pattern names in the pattern signature
+ -> LHsType DocNameI -- ^ type of the pattern synonym
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFunSig leader doc docnames (L _ typ) unicode =
ppTypeOrFunSig typ doc
- ( ppTypeSig names typ False
- , hsep . punctuate comma $ map ppSymName names
+ ( lead $ ppTypeSig names typ False
+ , lead $ hsep . punctuate comma $ map ppSymName names
, dcolon unicode
)
unicode
where
names = map getName docnames
+ lead = maybe id (<+>) leader
-- | Pretty-print a pattern synonym
ppLPatSig :: DocForDecl DocName -- ^ documentation
@@ -433,15 +439,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation
-> Bool -- ^ unicode
-> LaTeX
ppLPatSig doc docnames ty unicode
- = ppTypeOrFunSig typ doc
- ( keyword "pattern" <+> ppTypeSig names typ False
- , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names)
- , dcolon unicode
- )
- unicode
- where
- typ = unLoc (hsSigType ty)
- names = map getName docnames
+ = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode
-- | Pretty-print a type, adding documentation to the whole type and its
-- arguments as needed.
@@ -585,6 +583,7 @@ ppFds fds unicode =
hsep (map (ppDocName . unLoc) vars2)
+-- TODO: associated types, associated type defaults, docs on default methods
ppClassDecl :: [DocInstance DocNameI]
-> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocNameI -> Bool -> LaTeX
@@ -610,13 +609,15 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}" <> emph (text "Methods") $$
- vcat [ ppFunSig doc names (hsSigWcType typ) unicode
- | L _ (TypeSig _ lnames typ) <- lsigs
- , let doc = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames ]
- -- FIXME: is taking just the first name ok? Is it possible that
- -- there are different subdocs for different names in a single
- -- type signature?
+ vcat [ ppFunSig leader doc names (hsSigType typ) unicode
+ | L _ (ClassOpSig _ is_def lnames typ) <- lsigs
+ , let doc | is_def = noDocForDecl
+ | otherwise = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames
+ leader = if is_def then Just (keyword "default") else Nothing
+ ]
+ -- N.B. taking just the first name is ok. Signatures with multiple
+ -- names are expanded so that each name gets its own signature.
instancesBit = ppDocInstances unicode instances
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index f2cab635..56a79d57 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -36,6 +36,7 @@ import Text.XHtml hiding ( name, title, p, quote )
import BasicTypes (PromotionFlag(..), isPromoted)
import GHC hiding (LexicalFixity(..))
+import qualified GHC
import GHC.Exts
import Name
import BooleanFormula
@@ -75,14 +76,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
- ppFunSig summary links loc doc (map unLoc lnames) lty fixities
+ ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities
splice unicode pkg qual
-ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
- ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
+ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual =
+ ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)
splice unicode pkg qual HideEmptyContexts
where
pp_typ = ppLType unicode qual HideEmptyContexts typ
@@ -218,7 +219,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode pkg qual
- = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual
+ = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -496,7 +497,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc doc names (hsSigType typ)
+ [ ppFunSig summary links loc noHtml doc names (hsSigType typ)
[] splice unicode pkg qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -517,8 +518,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)
-> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
- decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
- , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm)
+ , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs
+ , tcdATs = ats, tcdATDefs = atsDefs })
splice unicode pkg qual
| summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual
| otherwise = classheader +++ docSection curname pkg qual d
@@ -535,28 +537,68 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Only the fixity relevant to the class header
fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
- nm = tcdName decl
-
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
- -- ToDo: add assocatied typ defaults
- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual
- | at <- ats
- , let n = unL . fdLName $ unL at
- doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
- subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
-
- methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)
- subfixs splice unicode pkg qual
- | L _ (ClassOpSig _ _ lnames typ) <- lsigs
- , name <- map unLoc lnames
- , let doc = lookupAnySubdoc name subdocs
- subfixs = [ f | f@(n',_) <- fixities
- , name == n' ]
- ]
- -- N.B. taking just the first name is ok. Signatures with multiple names
- -- are expanded so that each name gets its own signature.
+ -- Associated types
+ atBit = subAssociatedTypes
+ [ ppAssocType summary links doc at subfixs splice unicode pkg qual
+ <+>
+ subDefaults (maybeToList defTys)
+ | at <- ats
+ , let name = unL . fdLName $ unL at
+ doc = lookupAnySubdoc name subdocs
+ subfixs = filter ((== name) . fst) fixities
+ defTys = ppDefaultAssocTy name <$> lookupDAT name
+ ]
+
+ -- Default associated types
+ ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl
+ splice unicode pkg qual
+ where
+ synDecl = SynDecl { tcdSExt = noExt
+ , tcdLName = noLoc n
+ , tcdTyVars = vs
+ , tcdFixity = GHC.Prefix
+ , tcdRhs = t }
+
+ lookupDAT name = Map.lookup (getName name) defaultAssocTys
+ defaultAssocTys = Map.fromList
+ [ (getName name, (vs, typ, doc))
+ | L _ (FamEqn { feqn_rhs = typ
+ , feqn_tycon = L _ name
+ , feqn_pats = vs }) <- atsDefs
+ , let doc = noDocForDecl -- TODO: get docs for associated type defaults
+ ]
+
+ -- Methods
+ methodBit = subMethods
+ [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ)
+ subfixs splice unicode pkg qual
+ <+>
+ subDefaults (maybeToList defSigs)
+ | ClassOpSig _ False lnames typ <- sigs
+ , name <- map unLoc lnames
+ , let doc = lookupAnySubdoc name subdocs
+ subfixs = filter ((== name) . fst) fixities
+ defSigs = ppDefaultFunSig name <$> lookupDM name
+ ]
+ -- N.B. taking just the first name is ok. Signatures with multiple names
+ -- are expanded so that each name gets its own signature.
+
+ -- Default methods
+ ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")
+ d' [n] (hsSigType t) [] splice unicode pkg qual
+
+ lookupDM name = Map.lookup (getOccString name) defaultMethods
+ defaultMethods = Map.fromList
+ [ (nameStr, (typ, doc))
+ | ClassOpSig _ True lnames typ <- sigs
+ , name <- map unLoc lnames
+ , let doc = noDocForDecl -- TODO: get docs for method defaults
+ nameStr = getOccString name
+ ]
+ -- Minimal complete definition
minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
@@ -565,7 +607,7 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Minimal complete definition = the only shown method
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns]
+ [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns]
-> noHtml
-- Minimal complete definition = nothing
@@ -580,6 +622,7 @@ ppClassDecl summary links instances fixities loc d subdocs
where wrap | p = parens | otherwise = id
ppMinimal p (Parens x) = ppMinimal p (unLoc x)
+ -- Instances
instancesBit = ppInstances links (OriginClass nm) instances
splice unicode pkg qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 25d8b07a..4535b897 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout (
subInstances, subOrphanInstances,
subInstHead, subInstDetails, subFamInstDetails,
subMethods,
+ subDefaults,
subMinimal,
topDeclElem, declElem,
@@ -259,6 +260,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid
subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock
+subDefaults :: [Html] -> Html
+subDefaults = divSubDecls "default" "" . subBlock
+
subMinimal :: Html -> Html
subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index cd4ac1a1..a72247e6 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -355,6 +355,9 @@ showWrapped f (Unadorned n) = f n
showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"
showWrapped f (Backticked n) = "`" ++ f n ++ "`"
+instance HasOccName DocName where
+
+ occName = occName . getName
-----------------------------------------------------------------------------
-- * Instances
diff --git a/html-test/ref/DefaultAssociatedTypes.html b/html-test/ref/DefaultAssociatedTypes.html
new file mode 100644
index 00000000..d456815f
--- /dev/null
+++ b/html-test/ref/DefaultAssociatedTypes.html
@@ -0,0 +1,158 @@
+DefaultAssociatedTypes
\ No newline at end of file
diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html
new file mode 100644
index 00000000..4bf261f7
--- /dev/null
+++ b/html-test/ref/DefaultSignatures.html
@@ -0,0 +1,182 @@
+DefaultSignatures
\ No newline at end of file
diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs
new file mode 100644
index 00000000..6ad197d3
--- /dev/null
+++ b/html-test/src/DefaultAssociatedTypes.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DefaultSignatures, TypeFamilies #-}
+
+module DefaultAssociatedTypes where
+
+-- | Documentation for Foo.
+class Foo a where
+ -- | Documentation for bar and baz.
+ bar, baz :: a -> String
+
+ -- | Doc for Qux
+ type Qux a :: *
+
+ -- | Doc for default Qux
+ type Qux a = [a]
diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs
new file mode 100644
index 00000000..52d68a96
--- /dev/null
+++ b/html-test/src/DefaultSignatures.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+module DefaultSignatures where
+
+-- | Documentation for Foo.
+class Foo a where
+ -- | Documentation for bar and baz.
+ bar, baz :: a -> String
+
+ -- | Documentation for the default signature of bar.
+ default bar :: Show a => a -> String
+ bar = show
+
+ -- | Documentation for baz'.
+ baz' :: String -> a
+
+ -- | Documentation for the default signature of baz'.
+ default baz' :: Read a => String -> a
+ baz' = read
diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex
new file mode 100644
index 00000000..4dbcda49
--- /dev/null
+++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex
@@ -0,0 +1,41 @@
+\haddockmoduleheading{DefaultSignatures}
+\label{module:DefaultSignatures}
+\haddockbeginheader
+{\haddockverb\begin{verbatim}
+module DefaultSignatures (
+ Foo(baz', baz, bar)
+ ) where\end{verbatim}}
+\haddockendheader
+
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+class\ Foo\ a\ where
+\end{tabular}]\haddockbegindoc
+Documentation for Foo.\par
+
+\haddockpremethods{}\emph{Methods}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+bar,\ baz\ ::\ a\ ->\ String
+\end{tabular}]\haddockbegindoc
+Documentation for bar and baz.\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String
+\end{tabular}]
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+baz'\ ::\ String\ ->\ a
+\end{tabular}]\haddockbegindoc
+Documentation for baz'.\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a
+\end{tabular}]
+\end{haddockdesc}
+\end{haddockdesc}
\ No newline at end of file
diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty
new file mode 100644
index 00000000..6e031a98
--- /dev/null
+++ b/latex-test/ref/DefaultSignatures/haddock.sty
@@ -0,0 +1,57 @@
+% Default Haddock style definitions. To use your own style, invoke
+% Haddock with the option --latex-style=mystyle.
+
+\usepackage{tabulary} % see below
+
+% make hyperlinks in the PDF, and add an expandabale index
+\usepackage[pdftex,bookmarks=true]{hyperref}
+
+\newenvironment{haddocktitle}
+ {\begin{center}\bgroup\large\bfseries}
+ {\egroup\end{center}}
+\newenvironment{haddockprologue}{\vspace{1in}}{}
+
+\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}
+
+\newcommand{\haddockbeginheader}{\hrulefill}
+\newcommand{\haddockendheader}{\noindent\hrulefill}
+
+% a little gap before the ``Methods'' header
+\newcommand{\haddockpremethods}{\vspace{2ex}}
+
+% inserted before \\begin{verbatim}
+\newcommand{\haddockverb}{\small}
+
+% an identifier: add an index entry
+\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}
+
+% The tabulary environment lets us have a column that takes up ``the
+% rest of the space''. Unfortunately it doesn't allow
+% the \end{tabulary} to be in the expansion of a macro, it must appear
+% literally in the document text, so Haddock inserts
+% the \end{tabulary} itself.
+\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+
+\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}
+\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}
+
+\makeatletter
+\newenvironment{haddockdesc}
+ {\list{}{\labelwidth\z@ \itemindent-\leftmargin
+ \let\makelabel\haddocklabel}}
+ {\endlist}
+\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}
+\makeatother
+
+% after a declaration, start a new line for the documentation.
+% Otherwise, the documentation starts right after the declaration,
+% because we're using the list environment and the declaration is the
+% ``label''. I tried making this newline part of the label, but
+% couldn't get that to work reliably (the space seemed to stretch
+% sometimes).
+\newcommand{\haddockbegindoc}{\hfill\\[1ex]}
+
+% spacing between paragraphs and no \parindent looks better
+\parskip=10pt plus2pt minus2pt
+\setlength{\parindent}{0cm}
diff --git a/latex-test/ref/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex
new file mode 100644
index 00000000..d30eb008
--- /dev/null
+++ b/latex-test/ref/DefaultSignatures/main.tex
@@ -0,0 +1,11 @@
+\documentclass{book}
+\usepackage{haddock}
+\begin{document}
+\begin{titlepage}
+\begin{haddocktitle}
+
+\end{haddocktitle}
+\end{titlepage}
+\tableofcontents
+\input{DefaultSignatures}
+\end{document}
\ No newline at end of file
diff --git a/latex-test/src/DefaultSignatures/DefaultSignatures.hs b/latex-test/src/DefaultSignatures/DefaultSignatures.hs
new file mode 100644
index 00000000..52d68a96
--- /dev/null
+++ b/latex-test/src/DefaultSignatures/DefaultSignatures.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+module DefaultSignatures where
+
+-- | Documentation for Foo.
+class Foo a where
+ -- | Documentation for bar and baz.
+ bar, baz :: a -> String
+
+ -- | Documentation for the default signature of bar.
+ default bar :: Show a => a -> String
+ bar = show
+
+ -- | Documentation for baz'.
+ baz' :: String -> a
+
+ -- | Documentation for the default signature of baz'.
+ default baz' :: Read a => String -> a
+ baz' = read
--
cgit v1.2.3