From e88a63783fe716adbb96966c335f60009573dfc3 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 24 Jan 2021 14:27:14 +0200 Subject: Add import list to Data.List --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index c114e84d..58809f73 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -31,7 +31,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Data.Char -import Data.List +import Data.List (intercalate, isPrefixOf) import Data.Maybe import Data.Version -- cgit v1.2.3 From 2b2bf07fb10da33ca2edf060a6049ad7dc7b7b4c Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sun, 24 Jan 2021 16:03:45 +0300 Subject: Cleanup: fix build warnings --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Parser.hs | 2 +- haddock-test/src/Test/Haddock/Config.hs | 2 +- 6 files changed, 7 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 6ef07434..03be8c22 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -18,7 +18,7 @@ import Data.Maybe import System.Directory import System.FilePath -import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..), SourcedNodeInfo(..) ) +import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7fb71d4b..c4988480 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -624,7 +624,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just synifiedDecl -> pure synifiedDecl Nothing -> O.pprPanic "availExportItem" (O.text err) - availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn + availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) @@ -979,7 +979,7 @@ extractDecl declMap name decl _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of [] -> Left . O.showSDocUnsafe $ diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index a084af90..ad2f61c2 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -313,7 +313,7 @@ renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr fla renameLBinder = located renameBinder -- | Core renaming logic. -renameName :: (Eq name, SetName name) => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 0b8bb9f2..35f21f6c 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -159,7 +159,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m +nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 0604a831..e335ee19 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -24,7 +24,7 @@ import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Reader ( RdrName(..) ) -import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..), unLoc ) +import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import GHC.Data.StringBuffer ( stringToStringBuffer ) diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 94ca7759..e4829588 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -18,7 +18,7 @@ import Data.Maybe import Distribution.Text import Distribution.Types.PackageName import Distribution.InstalledPackageInfo -import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.Compiler import Distribution.Simple.GHC import Distribution.Simple.PackageIndex import Distribution.Simple.Program -- cgit v1.2.3 From 62bf25cb0931e761e8b2ff082a703d79386fc8bc Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Wed, 16 Dec 2020 20:03:14 +0100 Subject: Display linear/multiplicity arrows correctly (#1238) Previously we were ignoring multiplicity and displayed a %1 -> b as a -> b. (cherry picked from commit b4b4d896d2d68d6c48e7db7bfe95c185ca0709cb) --- haddock-api/src/Haddock/Backends/LaTeX.hs | 14 ++- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 9 +- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 9 +- html-test/ref/LinearTypes.html | 108 ++++++++++++++++++++++++ html-test/src/LinearTypes.hs | 14 +++ latex-test/ref/LinearTypes/LinearTypes.tex | 30 +++++++ latex-test/ref/LinearTypes/haddock.sty | 57 +++++++++++++ latex-test/ref/LinearTypes/main.tex | 11 +++ latex-test/src/LinearTypes/LinearTypes.hs | 14 +++ 9 files changed, 259 insertions(+), 7 deletions(-) create mode 100644 html-test/ref/LinearTypes.html create mode 100644 html-test/src/LinearTypes.hs create mode 100644 latex-test/ref/LinearTypes/LinearTypes.tex create mode 100644 latex-test/ref/LinearTypes/haddock.sty create mode 100644 latex-test/ref/LinearTypes/main.tex create mode 100644 latex-test/src/LinearTypes/LinearTypes.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index df81fd6e..45574e06 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1072,9 +1072,13 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode , ppr_mono_lty ty unicode ] -ppr_mono_ty (HsFunTy _ _ ty1 ty2) u +ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u - , arrow u <+> ppr_mono_lty ty2 u ] + , arr <+> ppr_mono_lty ty2 u ] + where arr = case mult of + HsLinearArrow _ -> lollipop u + HsUnrestrictedArrow _ -> arrow u + HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name @@ -1363,14 +1367,18 @@ quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX +dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") +lollipop unicode = text (if unicode then "⊸" else "%1 ->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") starSymbol unicode = text (if unicode then "★" else "*") atSign unicode = text (if unicode then "@" else "@") +multAnnotation :: LaTeX +multAnnotation = text "%" + dot :: LaTeX dot = char '.' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index eeb9fa94..0b0050df 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1213,10 +1213,15 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") -ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e = +ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts - , arrow u <+> ppr_mono_lty ty2 u q e + , arr <+> ppr_mono_lty ty2 u q e ] + where arr = case mult of + HsLinearArrow _ -> lollipop u + HsUnrestrictedArrow _ -> arrow u + HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsSumTy _ tys) u q _ = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index f5f64f51..238f0046 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -21,7 +21,8 @@ module Haddock.Backends.Xhtml.Utils ( keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + multAnnotation, atSign, hsep, vcat, @@ -187,13 +188,17 @@ ubxparens :: Html -> Html ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html +dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->") +lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" atSign unicode = toHtml (if unicode then "@" else "@") +multAnnotation :: Html +multAnnotation = toHtml "%" + dot :: Html dot = toHtml "." diff --git a/html-test/ref/LinearTypes.html b/html-test/ref/LinearTypes.html new file mode 100644 index 00000000..48ad04e2 --- /dev/null +++ b/html-test/ref/LinearTypes.html @@ -0,0 +1,108 @@ +LinearTypes
Safe HaskellSafe-Inferred

LinearTypes

Synopsis

Documentation

unrestricted :: a -> b #

Does something unrestricted.

linear :: a %1 -> b #

Does something linear.

poly :: a %m -> b #

Does something polymorphic.

diff --git a/html-test/src/LinearTypes.hs b/html-test/src/LinearTypes.hs new file mode 100644 index 00000000..cb4eb138 --- /dev/null +++ b/html-test/src/LinearTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LinearTypes #-} +module LinearTypes where + +-- | Does something unrestricted. +unrestricted :: a -> b +unrestricted = undefined + +-- | Does something linear. +linear :: a %1 -> b +linear = linear + +-- | Does something polymorphic. +poly :: a %m -> b +poly = poly diff --git a/latex-test/ref/LinearTypes/LinearTypes.tex b/latex-test/ref/LinearTypes/LinearTypes.tex new file mode 100644 index 00000000..cb583ca8 --- /dev/null +++ b/latex-test/ref/LinearTypes/LinearTypes.tex @@ -0,0 +1,30 @@ +\haddockmoduleheading{LinearTypes} +\label{module:LinearTypes} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module LinearTypes ( + unrestricted, linear, poly + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +unrestricted :: a -> b +\end{tabular}] +{\haddockbegindoc +Does something unrestricted.\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +linear :: a {\char '45}1 -> b +\end{tabular}] +{\haddockbegindoc +Does something linear.\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +poly :: a {\char '45}m -> b +\end{tabular}] +{\haddockbegindoc +Does something polymorphic.\par} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/LinearTypes/haddock.sty b/latex-test/ref/LinearTypes/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/LinearTypes/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/LinearTypes/main.tex b/latex-test/ref/LinearTypes/main.tex new file mode 100644 index 00000000..655261c3 --- /dev/null +++ b/latex-test/ref/LinearTypes/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{LinearTypes} +\end{document} \ No newline at end of file diff --git a/latex-test/src/LinearTypes/LinearTypes.hs b/latex-test/src/LinearTypes/LinearTypes.hs new file mode 100644 index 00000000..cb4eb138 --- /dev/null +++ b/latex-test/src/LinearTypes/LinearTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LinearTypes #-} +module LinearTypes where + +-- | Does something unrestricted. +unrestricted :: a -> b +unrestricted = undefined + +-- | Does something linear. +linear :: a %1 -> b +linear = linear + +-- | Does something polymorphic. +poly :: a %m -> b +poly = poly -- cgit v1.2.3 From c31c156422785751e33c9a7a4f021ac8da77d364 Mon Sep 17 00:00:00 2001 From: Iñaki García Etxebarria Date: Wed, 31 Jul 2019 16:28:00 +0100 Subject: Add support for labeled module references Support a markdown-style way of annotating module references. For instance -- | [label]("Module.Name#anchor") will create a link that points to the same place as the module reference "Module.Name#anchor" but the text displayed on the link will be "label". --- doc/markup.rst | 5 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 7 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 15 ++-- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 9 ++- haddock-api/src/Haddock/Interface/Json.hs | 4 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 41 +++++++++-- haddock-api/src/Haddock/Types.hs | 3 + haddock-library/fixtures/Fixtures.hs | 3 + .../src/Documentation/Haddock/Markup.hs | 4 +- .../src/Documentation/Haddock/Parser.hs | 54 ++++++++++---- haddock-library/src/Documentation/Haddock/Types.hs | 14 ++-- .../test/Documentation/Haddock/ParserSpec.hs | 84 +++++++++++++++++++--- 14 files changed, 198 insertions(+), 49 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/doc/markup.rst b/doc/markup.rst index 8935b765..c0b08a40 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -982,6 +982,11 @@ is valid before turning it into a link but unlike with identifiers, whether the module is in scope isn't checked and will always be turned into a link. +It is also possible to specify alternate text for the generated link +using syntax analogous to that used for URLs: :: + + -- | This is a reference to [the main module]("Module.Main"). + Itemized and Enumerated Lists ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 58809f73..9a304030 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -325,7 +325,7 @@ markupTag dflags = Markup { markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), - markupModule = box (TagInline "a") . str, + markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label), markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupBold = box (TagInline "b"), diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index df81fd6e..2371695f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1210,7 +1210,12 @@ latexMarkup = Markup , markupAppend = \l r v -> l v . r v , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) - , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) + , markupModule = + \(ModLink m mLabel) v -> + case mLabel of + Just lbl -> inlineElem . tt $ lbl v empty + Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m + in (tt (text mdl))) , markupWarning = \p v -> p v , markupEmphasis = \p v -> inlineElem (emph (p v empty)) , markupBold = \p v -> inlineElem (bold (p v empty)) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 378d0559..7670b193 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -44,13 +44,14 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupAppend = (+++), markupIdentifier = thecode . ppId insertAnchors, markupIdentifierUnchecked = thecode . ppUncheckedLink qual, - markupModule = \m -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style - -- foo\#bar anchors - mdl' = case reverse mdl of - '\\':_ -> init mdl - _ -> mdl - in ppModuleRef (mkModuleName mdl') ref, + markupModule = \(ModLink m lbl) -> + let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef lbl (mkModuleName mdl') ref, markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupBold = strong, diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 8553cdfb..b324fa38 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -186,9 +186,12 @@ ppModule mdl = anchor ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: ModuleName -> String -> Html -ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] - << toHtml (moduleNameString mdl) +ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) +ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << lbl + -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used. diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 4e271602..95889a63 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -98,9 +98,9 @@ jsonDoc (DocIdentifierUnchecked modName) = jsonObject , ("modName", jsonString (showModName modName)) ] -jsonDoc (DocModule s) = jsonObject +jsonDoc (DocModule (ModLink m _l)) = jsonObject [ ("tag", jsonString "DocModule") - , ("string", jsonString s) + , ("string", jsonString m) ] jsonDoc (DocWarning x) = jsonObject diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index d1d6bb31..87210273 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -148,7 +148,7 @@ rename dflags gre = rn DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) - DocModule str -> pure (DocModule str) + DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l DocPic str -> pure (DocPic str) DocMathInline str -> pure (DocMathInline str) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 35f21f6c..966901df 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -46,6 +46,8 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique +import Documentation.Haddock.Parser (parseModLink) + data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, @@ -69,6 +71,18 @@ ifUnitId if_ = binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface +-- Note [The DocModule story] +-- +-- Breaking changes to the DocH type result in Haddock being unable to read +-- existing interfaces. This is especially painful for interfaces shipped +-- with GHC distributions since there is no easy way to regenerate them! +-- +-- PR #1315 introduced a breaking change to the DocModule constructor. To +-- maintain backward compatibility we +-- +-- Parse the old DocModule constructor format (tag 5) and parse the contained +-- string into a proper ModLink structure. When writing interfaces we exclusively +-- use the new DocModule format (tag 24) -- IMPORTANT: Since datatypes in the GHC API might change between major -- versions, and because we store GHC datatypes in our interface files, we need @@ -84,10 +98,10 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) -binaryInterfaceVersion = 37 +binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16] -binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] +binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion] #else #error Unsupported GHC version #endif @@ -444,6 +458,15 @@ instance Binary a => Binary (Hyperlink a) where label <- get bh return (Hyperlink url label) +instance Binary a => Binary (ModLink a) where + put_ bh (ModLink m label) = do + put_ bh m + put_ bh label + get bh = do + m <- get bh + label <- get bh + return (ModLink m label) + instance Binary Picture where put_ bh (Picture uri title) = do put_ bh uri @@ -522,9 +545,6 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocIdentifier ae) = do putByte bh 4 put_ bh ae - put_ bh (DocModule af) = do - putByte bh 5 - put_ bh af put_ bh (DocEmphasis ag) = do putByte bh 6 put_ bh ag @@ -579,6 +599,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocTable x) = do putByte bh 23 put_ bh x + -- See note [The DocModule story] + put_ bh (DocModule af) = do + putByte bh 24 + put_ bh af get bh = do h <- getByte bh @@ -598,9 +622,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 4 -> do ae <- get bh return (DocIdentifier ae) + -- See note [The DocModule story] 5 -> do af <- get bh - return (DocModule af) + return (parseModLink af) 6 -> do ag <- get bh return (DocEmphasis ag) @@ -655,6 +680,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 23 -> do x <- get bh return (DocTable x) + -- See note [The DocModule story] + 24 -> do + af <- get bh + return (DocModule af) _ -> error "invalid binary data found in the interface file" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index aa76f8f6..53d01565 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -501,6 +501,9 @@ instance NFData id => NFData (Header id) where instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (ModLink id) where + rnf (ModLink a b) = a `deepseq` b `deepseq` () + instance NFData Picture where rnf (Picture a b) = a `deepseq` b `deepseq` () diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs index 72ea8525..101bce65 100644 --- a/haddock-library/fixtures/Fixtures.hs +++ b/haddock-library/fixtures/Fixtures.hs @@ -149,6 +149,9 @@ instance ToExpr id => ToExpr (Header id) deriving instance Generic (Hyperlink id) instance ToExpr id => ToExpr (Hyperlink id) +deriving instance Generic (ModLink id) +instance ToExpr id => ToExpr (ModLink id) + deriving instance Generic Picture instance ToExpr Picture diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index 365041ee..0919737f 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -16,7 +16,7 @@ markup m (DocString s) = markupString m s markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 +markup m (DocModule (ModLink mo l)) = markupModule m (ModLink mo (fmap (markup m) l)) markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocBold d) = markupBold m (markup m d) @@ -78,7 +78,7 @@ plainMarkup plainMod plainIdent = Markup { markupAppend = (++), markupIdentifier = plainIdent, markupIdentifierUnchecked = plainMod, - markupModule = id, + markupModule = \(ModLink m lbl) -> fromMaybe m lbl, markupWarning = id, markupEmphasis = id, markupBold = id, diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index a3bba38a..bb8745a5 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -18,6 +18,7 @@ module Documentation.Haddock.Parser ( parseString, parseParas, + parseModLink, overIdentifier, toRegular, Identifier @@ -72,7 +73,7 @@ overIdentifier f d = g d g (DocString x) = DocString x g (DocParagraph x) = DocParagraph $ g x g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x - g (DocModule x) = DocModule x + g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x)) g (DocWarning x) = DocWarning $ g x g (DocEmphasis x) = DocEmphasis $ g x g (DocMonospaced x) = DocMonospaced $ g x @@ -136,6 +137,9 @@ parseString = parseText . T.pack parseText :: Text -> DocH mod Identifier parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r') +parseModLink :: String -> DocH mod id +parseModLink s = snd $ parse moduleName (T.pack s) + parseParagraph :: Text -> DocH mod Identifier parseParagraph = snd . parse p where @@ -148,6 +152,7 @@ parseParagraph = snd . parse p , mathDisplay , mathInline , markdownImage + , markdownLink , hyperlink , bold , emphasis @@ -242,7 +247,12 @@ monospace = DocMonospaced . parseParagraph -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) -moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"") +moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"") + +-- | A module name, optionally with an anchor +-- +moduleNameString :: Parser String +moduleNameString = modid `maybeFollowedBy` anchor_ where modid = intercalate "." <$> conid `Parsec.sepBy1` "." anchor_ = (++) @@ -250,13 +260,30 @@ moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"") <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c))) maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf - + conid :: Parser String conid = (:) <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) <*> many conChar conChar = Parsec.alphaNum <|> Parsec.char '_' +-- | A labeled link to an indentifier, module or url using markdown +-- syntax. +markdownLink :: Parser (DocH mod Identifier) +markdownLink = do + lbl <- markdownLinkText + choice' [ markdownModuleName lbl, markdownURL lbl ] + where + markdownModuleName lbl = do + mn <- "(" *> skipHorizontalSpace *> + "\"" *> moduleNameString <* "\"" + <* skipHorizontalSpace <* ")" + pure $ DocModule (ModLink mn (Just lbl)) + + markdownURL lbl = do + target <- markdownLinkTarget + pure $ DocHyperlink $ Hyperlink target (Just lbl) + -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. -- @@ -290,9 +317,11 @@ mathDisplay = DocMathDisplay . T.unpack -- >>> parseString "![some /emphasis/ in a description](www.site.com)" -- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) markdownImage :: Parser (DocH mod Identifier) -markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) +markdownImage = do + text <- markup stringMarkup <$> ("!" *> markdownLinkText) + url <- markdownLinkTarget + pure $ DocPic (Picture url (Just text)) where - fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) stringMarkup = plainMarkup (const "") renderIdent renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] @@ -772,22 +801,21 @@ codeblock = | otherwise = Just $ c == '\n' hyperlink :: Parser (DocH mod Identifier) -hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] +hyperlink = choice' [ angleBracketLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod Identifier) -markdownLink = DocHyperlink <$> linkParser +-- | The text for a markdown link, enclosed in square brackets. +markdownLinkText :: Parser (DocH mod Identifier) +markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]") -linkParser :: Parser (Hyperlink (DocH mod Identifier)) -linkParser = flip Hyperlink <$> label <*> (whitespace *> url) +-- | The target for a markdown link, enclosed in parenthesis. +markdownLinkTarget :: Parser String +markdownLinkTarget = whitespace *> url where - label :: Parser (Maybe (DocH mod Identifier)) - label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]") - whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 12ccd28d..252eb425 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -73,6 +73,11 @@ data Hyperlink id = Hyperlink , hyperlinkLabel :: Maybe id } deriving (Eq, Show, Functor, Foldable, Traversable) +data ModLink id = ModLink + { modLinkName :: String + , modLinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) + data Picture = Picture { pictureUri :: String , pictureTitle :: Maybe String @@ -111,7 +116,8 @@ data DocH mod id | DocIdentifier id | DocIdentifierUnchecked mod -- ^ A qualified identifier that couldn't be resolved. - | DocModule String + | DocModule (ModLink (DocH mod id)) + -- ^ A link to a module, with an optional label. | DocWarning (DocH mod id) -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) @@ -142,7 +148,7 @@ instance Bifunctor DocH where bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) bimap _ g (DocIdentifier i) = DocIdentifier (g i) bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) - bimap _ _ (DocModule s) = DocModule s + bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl)) bimap f g (DocWarning doc) = DocWarning (bimap f g doc) bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) @@ -189,7 +195,7 @@ instance Bitraversable DocH where bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m - bitraverse _ _ (DocModule s) = pure (DocModule s) + bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl) bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc @@ -234,7 +240,7 @@ data DocMarkupH mod id a = Markup , markupAppend :: a -> a -> a , markupIdentifier :: id -> a , markupIdentifierUnchecked :: mod -> a - , markupModule :: String -> a + , markupModule :: ModLink a -> a , markupWarning :: a -> a , markupEmphasis :: a -> a , markupBold :: a -> a diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 1724c664..5fa73ecd 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -403,20 +403,20 @@ spec = do context "when parsing module strings" $ do it "should parse a module on its own" $ do "\"Module\"" `shouldParseTo` - DocModule "Module" + DocModule (ModLink "Module" Nothing) it "should parse a module inline" $ do "This is a \"Module\"." `shouldParseTo` - "This is a " <> DocModule "Module" <> "." + "This is a " <> DocModule (ModLink "Module" Nothing) <> "." it "can accept a simple module name" $ do - "\"Hello\"" `shouldParseTo` DocModule "Hello" + "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing) it "can accept a module name with dots" $ do - "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World" + "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing) it "can accept a module name with unicode" $ do - "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ" + "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing) it "parses a module name with a trailing dot as regular quoted string" $ do "\"Hello.\"" `shouldParseTo` "\"Hello.\"" @@ -428,19 +428,85 @@ spec = do "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\"" it "accepts a module name with unicode" $ do - "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ" + "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing) 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" + "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing) it "accepts anchor with hyphen as DocModule" $ do - "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo#bar-baz" + "\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing) it "accepts old anchor reference syntax as DocModule" $ do - "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" + "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing) + + context "when parsing labeled module links" $ do + it "parses a simple labeled module link" $ do + "[some label](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows escaping in label" $ do + "[some\\] label](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some] label")) + + it "strips leading and trailing whitespace from label" $ do + "[ some label ](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows whitespace in module name link" $ do + "[some label]( \"Some.Module\"\t )" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows inline markup in the label" $ do + "[something /emphasized/](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized"))) + + it "should parse a labeled module on its own" $ do + "[label](\"Module\")" `shouldParseTo` + DocModule (ModLink "Module" (Just "label")) + + it "should parse a labeled module inline" $ do + "This is a [label](\"Module\")." `shouldParseTo` + "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "." + + it "can accept a labeled module name with dots" $ do + "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label")) + + it "can accept a labeled module name with unicode" $ do + "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label")) + + it "parses a labeled module name with a trailing dot as a hyperlink" $ do + "[label](\"Hello.\")" `shouldParseTo` + hyperlink "\"Hello.\"" (Just "label") + + it "parses a labeled module name with a space as a regular string" $ do + "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")" + + it "parses a module name with invalid characters as a hyperlink" $ do + "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo` + hyperlink "\"Hello&[{}(=*+]!\"" (Just "label") + + it "accepts a labeled module name with unicode" $ do + "[label](\"Foo.Barλ\")" `shouldParseTo` + DocModule (ModLink "Foo.Barλ" (Just "label")) + + it "treats empty labeled module name as empty hyperlink" $ do + "[label](\"\")" `shouldParseTo` + hyperlink "\"\"" (Just "label") + + it "accepts anchor reference syntax for labeled module name" $ do + "[label](\"Foo#bar\")" `shouldParseTo` + DocModule (ModLink "Foo#bar" (Just "label")) + + it "accepts old anchor reference syntax for labeled module name" $ do + "[label](\"Foo\\#bar\")" `shouldParseTo` + DocModule (ModLink "Foo\\#bar" (Just "label")) + + it "interprets empty label as a unlabeled module name" $ do + "[](\"Module.Name\")" `shouldParseTo` + "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")" describe "parseParas" $ do let infix 1 `shouldParseTo` -- cgit v1.2.3 From 2f34d120c6da996d23518c3fa9065ccf0e05a551 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Sun, 7 Feb 2021 17:46:25 +0100 Subject: Remove dubious parseModLink Instead construct the ModLink value directly when parsing. --- haddock-api/src/Haddock/InterfaceFile.hs | 8 ++++---- haddock-library/src/Documentation/Haddock/Parser.hs | 4 ---- 2 files changed, 4 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 966901df..69201eb0 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -46,9 +46,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique -import Documentation.Haddock.Parser (parseModLink) - - data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, ifInstalledIfaces :: [InstalledInterface] @@ -625,7 +622,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where -- See note [The DocModule story] 5 -> do af <- get bh - return (parseModLink af) + return $ DocModule ModLink + { modLinkName = af + , modLinkLabel = Nothing + } 6 -> do ag <- get bh return (DocEmphasis ag) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index bb8745a5..de336d45 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -18,7 +18,6 @@ module Documentation.Haddock.Parser ( parseString, parseParas, - parseModLink, overIdentifier, toRegular, Identifier @@ -137,9 +136,6 @@ parseString = parseText . T.pack parseText :: Text -> DocH mod Identifier parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r') -parseModLink :: String -> DocH mod id -parseModLink s = snd $ parse moduleName (T.pack s) - parseParagraph :: Text -> DocH mod Identifier parseParagraph = snd . parse p where -- cgit v1.2.3 From 04da98934ad1c083d21ffc6a83a834c6c4b555d4 Mon Sep 17 00:00:00 2001 From: Willem Van Onsem <3482343+KommuSoft@users.noreply.github.com> Date: Tue, 8 Dec 2020 18:26:55 +0100 Subject: simplify calculating percentages fixing #1194 (#1236) --- haddock-api/src/Haddock/Interface.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 1501919b..b68cc4a9 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -186,7 +186,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + percentage = div (haddocked * 100) haddockable modString = moduleString (ifaceMod interface) coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString header = case ifaceDoc interface of @@ -245,4 +245,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env - -- cgit v1.2.3 From 05e2666af785f2b33395673839a5edf549901d36 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 7 Jan 2021 16:43:18 +0100 Subject: Update for Logger --- haddock-api/src/Haddock.hs | 36 ++++++++++++---------- haddock-api/src/Haddock/Interface.hs | 18 ++++++----- .../src/Haddock/Interface/AttachInstances.hs | 3 +- 3 files changed, 31 insertions(+), 26 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 2b6e2d57..49a63604 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -185,12 +185,13 @@ haddockWithGhc ghc args = handleTopExceptions $ do ghc flags' $ withDir $ do dflags <- getDynFlags + logger <- getLogger unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile)) + putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -203,7 +204,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -213,7 +214,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags unit_state flags sinceQual qual packages [] + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -262,9 +263,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption +renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do +renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -273,12 +274,12 @@ renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] +render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do +render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -368,7 +369,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do - withTiming dflags' "ppHtmlIndex" (const ()) $ do + withTiming logger dflags' "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls @@ -378,7 +379,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do - withTiming dflags' "ppHtmlContents" (const ()) $ do + withTiming logger dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls @@ -388,7 +389,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - withTiming dflags' "ppHtml" (const ()) $ do + withTiming logger dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue @@ -423,14 +424,14 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = ] when (Flag_LaTeX `elem` flags) $ do - withTiming dflags' "ppLatex" (const ()) $ do + withTiming logger dflags' "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do - withTiming dflags' "ppHyperlinkedSource" (const ()) $ do + withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () @@ -469,7 +470,8 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do -- compilation and linking. Then run the given 'Ghc' action. withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do - dynflags' <- parseGhcFlags =<< getSessionDynFlags + logger <- getLogger + dynflags' <- parseGhcFlags logger =<< getSessionDynFlags -- We disable pattern match warnings because than can be very -- expensive to check @@ -493,8 +495,8 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do go arg func True = arg : func True - parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags - parseGhcFlags dynflags = do + parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags + parseGhcFlags logger dynflags = do -- TODO: handle warnings? let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] @@ -506,7 +508,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do } flags' = filterRtsFlags flags - (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags') + (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') else return dynflags'' diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index fa1f3ee5..f3377965 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -59,15 +59,15 @@ import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) import GHC.Driver.Env -import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) +import GHC.Driver.Monad import GHC.Data.FastString (unpackFS) +import GHC.Utils.Error import GHC.Tc.Types (TcM, TcGblEnv(..)) import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) -import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs import GHC.Runtime.Loader (initializePlugins) import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..), @@ -113,7 +113,7 @@ processModules verbosity modules flags extIfaces = do mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-} - withTimingD "attachInstances" (const ()) $ do + withTimingM "attachInstances" (const ()) $ do attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..." @@ -161,7 +161,7 @@ createIfaces verbosity modules flags instIfaceMap = do targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets - loadOk <- withTimingD "load" (const ()) $ + loadOk <- withTimingM "load" (const ()) $ {-# SCC load #-} GHC.load LoadAllTargets case loadOk of @@ -212,7 +212,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do | otherwise = do hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef - (iface, modules) <- withTimingD "processModule" (const ()) $ + (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env) + "processModule" (const ()) $ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env liftIO $ do @@ -263,8 +264,11 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env unit_state = hsc_units hsc_env - (!interface, messages) <- {-# SCC createInterface #-} - withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + (!interface, messages) <- do + logger <- getLogger + dflags <- getDynFlags + {-# SCC createInterface #-} + withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 6ef0ed19..317258eb 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -127,9 +127,8 @@ attachToExportItem index expInfo getInstDoc getFixity export = cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do - dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text - liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e -- cgit v1.2.3