From e88a63783fe716adbb96966c335f60009573dfc3 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
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')
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 <vlad.z.4096@gmail.com>
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')
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 <krzysztof.gogolewski@tweag.io>
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')
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 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >LinearTypes</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >LinearTypes</p
+ ></div
+ ><div id="synopsis"
+ ><details id="syn"
+ ><summary
+ >Synopsis</summary
+ ><ul class="details-toggle" data-details-id="syn"
+ ><li class="src short"
+ ><a href="#"
+ >unrestricted</a
+ > :: a -> b</li
+ ><li class="src short"
+ ><a href="#"
+ >linear</a
+ > :: a %1 -> b</li
+ ><li class="src short"
+ ><a href="#"
+ >poly</a
+ > :: a %m -> b</li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:unrestricted" class="def"
+ >unrestricted</a
+ > :: a -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >Does something unrestricted.</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:linear" class="def"
+ >linear</a
+ > :: a %1 -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >Does something linear.</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:poly" class="def"
+ >poly</a
+ > :: a %m -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >Does something polymorphic.</p
+ ></div
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
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 <git@inaki.blueleaf.cc>
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')
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 ""
-- 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 <alexbiehl@gmail.com>
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')
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')
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 <sylvain@haskus.fr>
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')
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